function
call for certain object, e.g., NewLabel( AParent, 'caption' ); }
{= Конструктор. Не следует вызывать его. Для конструирования объектов,
вызывайте соответствующую глобальную функцию New<имя-объекта>. Например,
NewLabel( MyForm, 'Метка№1' ); }
{-}
class function AncestorOfObject( Obj: Pointer ): Boolean;
{* Is intended to replace 'is' operator, which is not applicable to objects. }
{= }
function VmtAddr: Pointer;
{* Returns addres of virtual methods table of object. }
{= возвращает алрес таблицы виртуальных методов (VMT). }
{+}
property OnDestroy: TOnEvent read fOnDestroy write fOnDestroy;
{* This event is provided for any KOL object, so You can provide your own
OnDestroy event for it. }
{= Данное событие обеспечивается для всех объектов KOL. Позволяет сделать
что-нибудь в связи с разрушением объекта. }
procedure Add2AutoFree( Obj: PObj );
{* Adds an object to the list of objects, destroyed automatically
when the object is destroyed. Do not add here child controls of
the TControl (these are destroyed by another way). Only non-control
objects, which are not destroyed automatically, should be added here. }
procedure Add2AutoFreeEx( Proc: TObjectMethod );
{* Adds an event handler to the list of events, called in destructor.
This method is mainly for internal use, and allows to auto-destroy
VCL components, located on KOL form at design time (in MCK project). }
procedure RemoveFromAutoFree( Obj: PObj );
{* Removes an object from auto-free list }
procedure RemoveFromAutoFreeEx( Proc: TObjectMethod );
{* Removes a procedure from auto-free list }
property Tag: DWORD read fTag write fTag;
{* Custom data field. }
protected
{$IFDEF USE_NAMES}
fName: String;
fNamedObjList: Plist;
fOwnerObj: PObj;
{$ENDIF}
public
{$IFDEF USE_NAMES}
procedure SetName( NewOwnerObj: PObj; const NewName: String);
property Name: string read FName;
property NamedObjList : PList read fNamedObjList;
property OwnerObj: PObj read FOwnerObj;
function FindObj(const ObjName: string): PObj;
{$ENDIF}
end;
//[END OF TObj DEFINITION]
{ ---------------------------------------------------------------------
TList - object to implement list of pointers (or dwords)
---------------------------------------------------------------------- }
//[TList DEFINITION]
TList = object( TObj )
{* Simple list of pointers. It is used in KOL instead of standard VCL
TList to store any kind data (or pointers to these ones). Can be created
calling function NewList. }
{= Простой список указателей. }
protected
fItems: PPointerList;
fCount: Integer;
fCapacity: Integer;
fAddBy: Integer;
procedure SetCount(const Value: Integer);
procedure SetAddBy(Value: Integer);
{++}(*public*){--}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* Destroys list, freeing memory, allocated for pointers. Programmer
is resposible for destroying of data, referenced by the pointers. }
{= }
{++}(*protected*){--}
procedure SetCapacity( Value: Integer );
function Get( Idx: Integer ): Pointer;
procedure Put( Idx: Integer; Value: Pointer );
{$IFDEF USE_CONSTRUCTORS}
procedure Init; virtual;
{$ENDIF}
protected
{$IFDEF TLIST_FAST}
fUseBlocks: Boolean;
fBlockList: PList;
fLastKnownBlockIdx: Integer;
fLastKnownCountBefore: Integer;
{$ENDIF}
public
procedure Clear;
{* Makes Count equal to 0. Not responsible for freeing (or destroying)
data, referenced by released pointers. }
procedure Add( Value: Pointer );
{* Adds pointer to the end of list, increasing Count by one. }
procedure Insert( Idx: Integer; Value: Pointer );
{* Inserts pointer before given item. Returns Idx, i.e. index of
inserted item in the list. Indeces of items, located after insertion
point, are increasing. To add item to the end of list, pass Count
as index parameter. To insert item before first item, pass 0 there. }
function IndexOf( Value: Pointer ): Integer;
{* Searches first (from start) item pointer with given value and returns
its index (zero-based) if found. If not found, returns -1. }
procedure Delete( Idx: Integer );
{* Deletes given (by index) pointer item from the list, shifting all
follow item indeces up by one. }
procedure DeleteRange( Idx, Len: Integer );
{* Deletes Len items starting from Idx. }
procedure Remove( Value: Pointer );
{* Removes first entry of a Value in the list. }
property Count: Integer read fCount write SetCount;
{* Returns count of items in the list. It is possible to delete a number
of items at the end of the list, keeping only first Count items alive,
assigning new value to Count property (less then Count it is). }
property Capacity: Integer read fCapacity write SetCapacity;
{* Returns number of pointers which could be stored in the list
without reallocating of memory. It is possible change this value
for optimize usage of the list (for minimize number of reallocating
memory operations). }
property Items[ Idx: Integer ]: Pointer read Get write Put; default;
{* Provides access (read and write) to items of the list. Please note,
that TList is not responsible for freeing memory, referenced by stored
pointers. }
function Last: Pointer;
{* Returns the last item (or nil, if the list is empty). }
procedure Swap( Idx1, Idx2: Integer );
{* Swaps two items in list directly (fast, but without testing of
index bounds). }
procedure MoveItem( OldIdx, NewIdx: Integer );
{* Moves item to new position. Pass NewIdx >= Count to move item
after the last one. }
procedure Release;
{* Especially for lists of pointers to dynamically allocated memory.
Releases all pointed memory blocks and destroys object itself. }
procedure ReleaseObjects;
{* Especially for a list of objects derived from TObj.
Calls Free for every of the object in the list, and then calls
Free for the object itself. }
property AddBy: Integer read fAddBy write SetAddBy;
{* Value to increment capacity when new items are added or inserted
and capacity need to be increased. }
property DataMemory: PPointerList read fItems;
{* Raw data memory. Can be used for direct access to items of a list.
Do not use it for TLIST_FAST ! }
procedure Assign( SrcList: PList );
{* Copies all source list items. }
{$IFDEF _D4orHigher}
procedure AddItems( const AItems: array of Pointer );
{* Adds a list of items given by a dynamic array. }
{$ENDIF}
function ItemAddress( Idx: Integer ): Pointer;
{* Returns an address of memory occupying by the item with index Idx.
(If the item is a pointer, returned value is a pointer to a pointer).
Item with index requested must exist. }
end;
//[END OF TList DEFINITION]
//[NewList DECLARATION]
function NewList: PList;
{* Returns pointer to newly created TList object. Use it instead usual
TList.Create as it is done in VCL or XCL. }
{$IFDEF _D4orHigher}
function NewListInit( const AItems: array of Pointer ): PList;
{* Creates a list filling it initially with certain Items. }
{$ENDIF}
procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer );
{* Very fast adds Value to List elements from List[FromIdx] to List[FromIdx+Count-1].
Given elements must exist. Count must be > 0. }
procedure Free_And_Nil( var Obj );
{* Obj.Free and Obj := nil, where Obj *MUST* be TObj or its descendant
(TControl, TMenu, etc.) This procedure is not compatible with VCL's
FreeAndNil, which works with TObject, since this it has another name. }
//[DummyObjProc, DummyObjProcParam DECLARATION]
procedure DummyObjProc( Sender: PObj );
procedure DummyObjProcParam( Sender: PObj; Param: Pointer );
{$IFDEF WIN_GDI}
{ --- threads --- }
//[THREADS]
const
ABOVE_NORMAL_PRIORITY_CLASS = $8000; // only for Windows 2K
BELOW_NORMAL_PRIORITY_CLASS = $4000; // and higher !
type
{++}(*TThread = class;*){--}
PThread = {-}^{+}TThread;
TThreadMethod = procedure of object;
TThreadMethodEx = procedure( Sender: PThread; Param: Pointer ) of object;
TOnThreadExecute = function(Sender:PThread): Integer of object;
{* Event to be called when Execute method is called for TThread }
{ ---------------------------------------------------------------------
TThread object
---------------------------------------------------------------------- }
//[TThread DEFINITION]
TThread = object(TObj)
private
function GetPriorityBoost: Boolean;
procedure SetPriorityBoost(const Value: Boolean);
{* Thread object. It is possible not to derive Your own thread-based
object, but instead create thread Suspended and assign event
OnExecute. To create, use one of NewThread of NewThreadEx functions,
or derive Your own descendant object and write creation function
(or constructor) for it.
|
Aknowledgements. Originally class ZThread was developed for XCL:
|
* By: Tim Slusher : junior@nlcomm.com
|
* Home: http://www.nlcomm.com/~junior
}
protected
FSuspended,
FTerminated: boolean;
FHandle: THandle;
FThreadId: DWORD;
FOnSuspend: TObjectMethod;
FOnResume: TOnEvent;
FData : Pointer;
FOnExecute : TOnThreadExecute;
FMethod: TThreadMethod;
FMethodEx: TThreadMethodEx;
F_AutoFree: Boolean;
FPriority: Integer;
function GetPriorityCls: Integer;
function GetThrdPriority: Integer;
procedure SetPriorityCls(Value: Integer);
procedure SetThrdPriority(Value: Integer);
procedure Init; virtual;
{++}(*public*){--}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* }
public
{$IFDEF PSEUDO_THREADS}
FPrtyCls: Integer;
DoNotWakeUntil: DWORD;
AllThreads: PList; // only for MainThread
CurrentThread: PThread;
StackBottom: Pointer; // except for MainThread
CurStackPos: Pointer;
Stack_Empty: Boolean;
procedure SwitchToThread( T: PThread ); // methods of MainThread
procedure NextThread;
{$ENDIF}
public
FResult: Integer;
function Execute: integer; virtual;
{* Executes thread. Do not call this method from another thread! (Even do
not call this method at all!) Instead, use Resume.
|
Note also that in contrast to VCL, it is not necessary to create your
own descendant object from TThread and override Execute method. In KOL,
it is sufficient to create an instance of TThread object (see NewThread,
NewThreadEx, NewThreadAutoFree functions) and assign OnExecute event
handler for it. }
procedure Resume;
{* Continues executing. It is necessary to make call for every
nested Suspend. }
procedure Suspend;
{* Suspends thread until it will be resumed. Can be called from another
thread or from the thread itself. }
procedure Terminate;
{* Terminates thread. }
function WaitFor: Integer;
{* Waits (infinitively) until thead will be finished. }
function WaitForTime( T: DWORD ): Integer;
{* Waits (T milliseconds) until thead will be finished. }
property Handle: THandle read FHandle;
{* Thread handle. It is created immediately when object is created
(using NewThread). }
property Suspended: boolean read FSuspended;
{* True, if suspended. }
property Terminated: boolean read FTerminated;
{* True, if terminated. }
property ThreadId: DWORD read FThreadId;
{* Thread id. }
property PriorityClass: Integer read GetPriorityCls write SetPriorityCls;
{* Thread priority class. One of following values: HIGH_PRIORITY_CLASS,
IDLE_PRIORITY_CLASS, NORMAL_PRIORITY_CLASS, REALTIME_PRIORITY_CLASS. }
property ThreadPriority: Integer read GetThrdPriority write SetThrdPriority;
{* Thread priority value. One of following values: THREAD_PRIORITY_ABOVE_NORMAL,
THREAD_PRIORITY_BELOW_NORMAL, THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_IDLE,
THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_TIME_CRITICAL. }
property Data : Pointer read FData write FData;
{* Custom data pointer. Use it for Youe own purpose. }
property OnExecute: TOnThreadExecute read FOnExecute write FOnExecute;
{* Is called, when Execute is starting. }
property OnSuspend: TObjectMethod read FOnSuspend write FOnSuspend;
{* Is called, when Suspend is performed. }
property OnResume: TOnEvent read FOnResume write FOnResume;
{* Is called, when resumed. }
procedure Synchronize( Method: TThreadMethod );
{* Call it to execute given method in main thread context. Applet variable
must exist for that time. }
procedure SynchronizeEx( Method: TThreadMethodEx; Param: Pointer );
{* Call it to execute given method in main thread context, with a given
parameter. Applet variable must exist for that time. Param must not be nil. }
{$IFDEF USE_CONSTRUCTORS}
constructor ThreadCreate;
constructor ThreadCreateEx( const Proc: TOnThreadExecute );
{$ENDIF USE_CONSTRUCTORS}
property AutoFree: Boolean read F_AutoFree write F_AutoFree;
{* Set this property to true to provide automatic destroying of thread
object when its executing is finished. }
property PriorityBoost: Boolean read GetPriorityBoost write SetPriorityBoost;
{* By default, priority boost is enabled for all threads. }
end;
//[END OF TThread DEFINITION]
//[NewThread, NewThreadEx, NewThreadAutoFree DECLARATIONS]
function NewThread: PThread;
{* Creates thread object (always suspended). After creating, set event
OnExecute and perform Resume operation. }
function NewThreadEx( const Proc: TOnThreadExecute ): PThread; {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Creates thread object, assigns Proc to its OnExecute event and runs
it. }
function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread;
{* Creates thread object similar to NewThreadEx, but freeing automatically
when executing of such thread finished. Be sure that a thread is resumed
at least to provide its object keeper freeing. }
{$IFDEF PSEUDO_THREADS}
var MainThread: PThread;
PseudoThreadStackSize: DWORD = 1024 * 1024;
CreatingMainThread: Boolean;
function WaitForSingleObject( hHandle: THandle; dwMilliseconds: DWORD ): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
function WaitForMultipleObjects( nCount: DWORD;
lpHandles: PHandle; fWaitAll: BOOL; dwMilliseconds: DWORD ): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
procedure Sleep( n: DWORD );
{$ENDIF}
{ -- streams -- }
//[STREAMS]
{$ENDIF WIN_GDI}
type
TMoveMethod = ( spBegin, spCurrent, spEnd );
{$IFDEF WIN_GDI}
type
{++}(*TStream = class;*){--}
PStream = {-}^{+}TStream;
PStreamMethods = ^TStreamMethods;
TStreamMethods = {$ifndef wince}packed{$endif} Record
fSeek: function( Strm: PStream; MoveTo: Integer; MoveMethod: TMoveMethod ): DWORD;
fGetSiz: function( Strm: PStream ): DWORD;
fSetSiz: procedure( Strm: PStream; Value: DWORD );
fRead: function( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
fWrite: function( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
fClose: procedure( Strm: PStream );
fCustom: Pointer;
fWait: procedure( Strm: PStream );
end;
TStreamData = {$ifndef wince}packed{$endif} Record
fHandle: THandle;
fCapacity, fSize, fPosition: DWORD;
fThread: PThread;
end;
{ ---------------------------------------------------------------------
TStream - streaming objects incapsulation
---------------------------------------------------------------------- }
//[TStream DEFINITION]
TStream = object(TObj)
{* Simple stream object. Can be opened for file, or as memory stream (see
NewReadFileStream, NewWriteFileStream, NewMemoryStream, etc.). And, another
type of streaming object can be derived (without inheriting new object
type, just by writing another New...Stream method, which calls
_NewStream and pass methods record to it). }
protected
fPMethods: PStreamMethods;
fMethods: TStreamMethods;
fMemory: Pointer;
fData: TStreamData;
fParam1, fParam2: DWORD; // parameters to use in thread
function GetCapacity: DWORD;
procedure SetCapacity(Value: DWORD);
function DoAsyncRead( Sender: PThread ): Integer;
function DoAsyncWrite( Sender: PThread ): Integer;
function DoAsyncSeek( Sender: PThread ): Integer;
protected
function GetFileStreamHandle: THandle;
procedure SetPosition(Value: DWord);
function GetPosition: DWord;
function GetSize: DWord;
procedure SetSize(NewSize: DWord);
{++}(*public*){--}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
public
function Read(var Buffer; Count: DWord): DWord;
{* Reads Count bytes from a stream. Returns number of bytes read. }
function Seek(MoveTo: Integer; MoveMethod: TMoveMethod): DWord;
{* Allows to change current position or to obtain it. Property
Position uses this method both for get and set position. }
function Write(var Buffer; Count: DWord): DWord;
{* Writes Count bytes from Buffer, starting from current position
in a stream. Returns how much bytes are written. }
function WriteVal( Value: DWORD; Count: DWORD ): DWORD;
{* Writes maximum 4 bytes of Value to a stream. Allows writing constants
easier than via Write. }
function WriteStr( S: String ): DWORD;
{* Writes string to the stream, not including ending #0. Exactly
Length( S ) characters are written. }
function WriteStrZ( S: String ): DWORD;
{* Writes string, adding #0. Number of bytes written is returned. }
{$IFDEF _D3orHigher}
function WriteWStrZ( S: WideString ): DWORD;
{* Writes string, adding #0. Number of bytes written is returned. }
{$ENDIF}
function ReadStrZ: String;
{* Reads string, finished by #0. After reading, current position in
the stream is set to the byte, follows #0. }
{$IFDEF _D3orHigher}
function ReadWStrZ: WideString;
{* Reads string, finished by #0. After reading, current position in
the stream is set to the byte, follows #0. }
{$ENDIF}
function ReadStr: String;
{* Reads string, finished by #13, #10 or #13#10 symbols. Terminating symbols
#13 and/or #10 are not added to the end of returned string though
stream positioned follow it. }
function ReadStrLen( Len: Integer ): String;
{* Reads string of the given length Len. }
function WriteStrEx(S: String): DWord;
{* Writes string S to stream, also saving its size for future use by
ReadStrEx* functions. Returns number of actually written characters. }
function ReadStrExVar(var S: String): DWord;
{* Reads string from stream and assigns it to S.
Returns number of actually read characters.
Note:
String must be written by using WriteStrEx function.
Return value is count of characters READ, not the length of string. }
function ReadStrEx: String;
{* Reads string from stream and returns it. }
function WriteStrPas( S: String ): DWORD;
{* Writes a string in Pascal short string format - 1 byte length, then string
itself without trailing #0 char. S parameter length should not exceed 255
chars, rest chars are truncated while writing. Total amount of bytes
written is returned. }
function ReadStrPas: String;
{* Reads 1 byte from a stream, then treat it as a length of following string
which is read and returned. A purpose of this function is reading strings
written using WriteStrPas. }
property Size: DWord read GetSize write SetSize;
{* Returns stream size. For some custom streams, can be slow
operation, or even always return undefined value (-1 recommended). }
property Position: DWord read GetPosition write SetPosition;
{* Current position. }
property Memory: Pointer read fMemory;
{* Only for memory stream. }
property Handle: THandle read GetFileStreamHandle;
{* Only for file stream. It is possible to check that Handle <>
INVALID_HANDLE_VALUE to ensure that file stream is created OK. }
//---------- for asynchronous operations (using thread - not tested):
procedure SeekAsync(MoveTo: Integer; MoveMethod: TMoveMethod);
{* Changes current position asynchronously. To wait for finishing the
operation, use method Wait. }
procedure ReadAsync(var Buffer; Count: DWord);
{* Reads Count bytes from a stream asynchronously. To wait finishing the
operation, use method Wait. }
procedure WriteAsync(var Buffer; Count: DWord);
{* Writes Count bytes from Buffer, starting from current position
in a stream - asynchronously. To wait finishing the operation,
use method Wait. }
function Busy: Boolean;
{* Returns TRUE until finishing the last asynchronous operation
started by calling SeekAsync, ReadAsync, WriteAsync methods. }
procedure Wait;
{* Waits for finishing the last asynchronous operation. }
property Methods: PStreamMethods read fPMethods;
{* Pointer to TStreamMethods record. Useful to implement custom-defined
streams, which can access its fCustom field, or even to change
methods when necessary. }
property Data: TStreamData read fData;
{* Pointer to TStreamData record. Useful to implement custom-defined
streams, which can access Data fields directly when implemented. }
property Capacity: DWORD read GetCapacity write SetCapacity;
{* Amound of memory allocated for data (MemoryStream). }
procedure SaveToFile( const Filename: KOLString; Start, CountSave: DWORD );
{* }
end;
//[END OF TStream DEFINITION]
//[_NewStream DECLARATION]
function _NewStream( const StreamMethods: TStreamMethods ): PStream;
{* Use this method only to define your own stream type. See also declared
below (in KOL.pas) methods used to implement standard KOL streams. You can use it in
your code to create streams, which are partially based on standard
methods. }
// Methods below are declared here to simplify creating your
// own streams with some methods standard and some non-standard
// together:
function SeekFileStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;
function GetSizeFileStream( Strm: PStream ): DWORD;
function ReadFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
var ReadFileStreamProc: function( Strm: PStream; var Buffer; Count: DWORD ): DWORD
= ReadFileStream;
function WriteFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
function WriteFileStreamEOF( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
procedure CloseFileStream( Strm: PStream );
function SeekMemStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;
function GetSizeMemStream( Strm: PStream ): DWORD;
var CapacityMask: DWORD = $4000 - 1; // must be 2**n-1
procedure SetSizeMemStream( Strm: PStream; NewSize: DWORD );
function ReadMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
function WriteMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
procedure CloseMemStream( Strm: PStream );
procedure SetSizeFileStream( Strm: PStream; NewSize: DWORD );
procedure DummyCloseStream( Strm: PStream );
function DummyReadWrite( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
procedure DummySetSize( Strm: PStream; Value: DWORD );
procedure DummyStreamProc(Strm: PStream);
//[NewFileStream DECLARATION]
function NewFileStream( const FileName: KOLString; Options: DWORD ): PStream;
{* Creates file stream for read and write. Exact set of open attributes
should be passed through Options parameter (see FileCreate where those
flags are listed). }
function NewReadFileStream( const FileName: KOLString ): PStream;
{* Creates file stream for read only. }
function NewWriteFileStream( const FileName: KOLString ): PStream;
{* Creates file stream for write only. Truncating of file (if needed)
is provided automatically. }
function NewReadWriteFileStream( const FileName: KOLString ): PStream;
{* Creates stream for read and write file. To truncate file, if it is
necessary, change Size property. }
{$IFDEF _D3orHigher}
function NewReadFileStreamW( const FileName: WideString ): PStream;
{* Creates file stream for read only. }
function NewWriteFileStreamW( const FileName: WideString ): PStream;
{* Creates file stream for write only. Truncating of file (if needed)
is provided automatically. }
function NewReadWriteFileStreamW( const FileName: WideString ): PStream;
{* Creates stream for read and write file. To truncate file, if it is
necessary, change Size property. }
{$ENDIF}
function NewExFileStream( F: HFile ): PStream;
{* Creates read only stream to read from opened file or pipe from the current
position.
When stream is destroyed, file handle still not closed (your code should do
this) and file position is not changed (after the last read operation). }
//[NewMemoryStream DECLARATION]
function NewMemoryStream: PStream;
{* Creates memory stream (read and write). }
function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream;
{* Creates memory stream on base of existing memory. It is not possible
to write out of top bound given by Size (i.e. memory can not be resized,
or reallocated. When stream object is destroyed this memory is not freed. }
//[Stream2Stream DECLARATION]
function Stream2Stream( Dst, Src: PStream; Count: DWORD ): DWORD;
{* Copies Count (or less, if the rest of Src is not sufficiently long)
bytes from Src to Dst, but with optimizing in cases, when Src or/and
Dst are memory streams (intermediate buffer is not allocated). }
function Stream2StreamEx( Dst, Src: PStream; Count: DWORD ): DWORD;
{* Copies Count bytes from Src to Dst, but without any optimization.
Unlike Stream2Stream function, it can be applied to very large streams.
See also Stream2StreamExBufSz. }
function Stream2StreamExBufSz( Dst, Src: PStream; Count, BufSz: DWORD ): DWORD;
{* Copies Count bytes from Src to Dst using buffer of given size, but without
other optimizations.
Unlike Stream2Stream function, it can be applied to very large streams }
//[Resource2Stream DECLARATION]
function Resource2Stream( DestStrm : PStream; Inst : HInst;
ResName : PKOLChar; ResType : PKOLChar ): Integer;
{* Loads given resource to DestStrm. Useful for non-standard
resources to load it into memory (use memory stream for such
purpose). Use one of following resource types to pass as ResType:
|
RT_ACCELERATOR Accelerator table
RT_ANICURSOR Animated cursor
RT_ANIICON Animated icon
RT_BITMAP Bitmap resource
RT_CURSOR Hardware-dependent cursor resource
RT_DIALOG Dialog box
RT_FONT Font resource
RT_FONTDIR Font directory resource
RT_GROUP_CURSOR Hardware-independent cursor resource
RT_GROUP_ICON Hardware-independent icon resource
RT_ICON Hardware-dependent icon resource
RT_MENU Menu resource
RT_MESSAGETABLE Message-table entry
RT_RCDATA Application-defined resource (raw data)
RT_STRING String-table entry
RT_VERSION Version resource
|
|
For example:
!var MemStrm: PStream;
! JpgObj: PJpeg;
!......
! MemStrm := NewMemoryStream;
! JpgObj := NewJpeg;
!......
! Resource2Stream( MemStrm, hInstance, 'MYJPEG', RT_RCDATA );
! MemStrm.Position := 0;
! JpgObj.LoadFromStream( MemStrm );
! MemStrm.Free;
!......
}
{$ENDIF WIN_GDI}
{ -- string list objects -- }
//[TStrList]
type
{++}(*TStrList = class;*){--}
PStrList = {-}^{+}TStrList;
{ ---------------------------------------------------------------------
TStrList - string list
---------------------------------------------------------------------- }
//[TStrList DEFINITION]
TStrList = object(TObj)
{* Easy string list implementation (non-visual, just to store
string data). It is well improved and has very high performance
allowing to work fast with huge text files (more then megabyte
of text data).
|
Please note that #0 charaster if stored in string lines, will cut it
preventing reading the rest of a line. Be careful, if your data
contain such characters. }
protected
procedure Init; virtual;
protected
fList: PList;
fCount: Integer;
fCaseSensitiveSort: Boolean;
fTextBuf: PChar;
fTextSiz: DWORD;
function GetPChars(Idx: Integer): PChar;
//procedure AddTextBuf( Src: PChar; Len: DWORD );
protected
function Get(Idx: integer): string;
function GetTextStr: string;
procedure Put(Idx: integer; const Value: string);
procedure SetTextStr(const Value: string);
{++}(*public*){--}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
protected
// by Dod:
procedure SetValue(const AName, Value: string);
function GetValue(const AName: string): string;
public
// by Dod:
function IndexOfName(AName: string): Integer;
{* by Dod. Returns index of line starting like Name=... }
property Values[const AName: string]: string read GetValue write SetValue;
{* by Dod. Returns right side of a line starting like Name=... }
public
function Add(const S: string): integer;
{* Adds a string to list. }
procedure AddStrings(Strings: PStrList);
{* Merges string list with given one. Very fast - more preferrable to
use than any loop with calling Add method. }
procedure Assign(Strings: PStrList);
{* Fills string list with strings from other one. The same as AddStrings,
but Clear is called first. }
procedure Clear;
{* Makes string list empty. }
procedure Delete(Idx: integer);
{* Deletes string with given index (it *must* exist). }
procedure DeleteLast;
{* Deletes the last string (it *must* exist). }
function IndexOf(const S: string): integer;
{* Returns index of first string, equal to given one. }
function IndexOf_NoCase(const S: string): integer;
{* Returns index of first string, equal to given one (while comparing it
without case sensitivity). }
function IndexOfStrL_NoCase( Str: PChar; L: Integer ): integer;
{* Returns index of first string, equal to given one (while comparing it
without case sensitivity). }
function Find(const S: String; var Index: Integer): Boolean;
{* Returns Index of the first string, equal or greater to given pattern, but
works only for sorted TStrList object. Returns TRUE if exact string found,
otherwise nearest (greater then a pattern) string index is returned,
and the result is FALSE. }
procedure Insert(Idx: integer; const S: string);
{* Inserts string before one with given index. }
procedure Move(CurIndex, NewIndex: integer);
{* Moves string to another location. }
procedure SetText(const S: string; Append2List: boolean);
{* Allows to set strings of string list from given string (in which
strings are separated by $0D,$0A or $0D characters). Text must not
contain #0 characters. Works very fast. This method is used in
all others, working with text arrays (LoadFromFile, MergeFromFile,
Assign, AddStrings). }
procedure SetUnixText( const S: String; Append2List: Boolean );
{* Allows to assign UNIX-style text (with #10 as string separator). }
property Count: integer read fCount;
{* Number of strings in a string list. }
property Items[Idx: integer]: string read Get write Put; default;
{* Strings array items. If item does not exist, empty string is returned.
But for assign to property, string with given index *must* exist. }
property ItemPtrs[ Idx: Integer ]: PChar read GetPChars;
{* Fast access to item strings as PChars. }
function Last: String;
{* Last item (or '', if string list is empty). }
property Text: string read GetTextStr write SetTextStr;
{* Content of string list as a single string (where strings are separated
by characters $0D,$0A). }
procedure Swap( Idx1, Idx2 : Integer );
{* Swaps to strings with given indeces. }
procedure Sort( CaseSensitive: Boolean );
{* Call it to sort string list. }
procedure AnsiSort( CaseSensitive: Boolean );
{* Call it to sort ANSI string list. }
// by Alexander Pravdin:
protected
fNameDelim: Char;
function GetLineName( Idx: Integer ): String;
procedure SetLineName( Idx: Integer; const NV: String );
function GetLineValue(Idx: Integer): string;
procedure SetLineValue(Idx: Integer; const Value: string);
public
property LineName[ Idx: Integer ]: string read GetLineName write SetLineName;
property LineValue[ Idx: Integer ]: string read GetLineValue write SetLineValue;
property NameDelimiter: Char read fNameDelim write fNameDelim;
function Join( const sep: String ): String;
{* by Sergey Shishmintzev. }
{$IFDEF WIN_GDI}
function LoadFromFile(const FileName: KOLstring): Boolean;
{* Loads string list from a file. (If file does not exist, nothing
happens). Very fast even for huge text files. }
procedure LoadFromStream(Stream: PStream; Append2List: boolean);
{* Loads string list from a stream (from current position to the end of
a stream). Very fast even for huge text. }
procedure MergeFromFile(const FileName: KOLstring);
{* Merges string list with strings in a file. Fast. }
function SaveToFile(const FileName: KOLstring): Boolean;
{* Stores string list to a file. }
procedure SaveToStream(Stream: PStream);
{* Saves string list to a stream (from current position). }
function AppendToFile(const FileName: KOLstring): Boolean;
{* Appends strings of string list to the end of a file. }
{$ENDIF WIN_GDI}
end;
//[END OF TStrList DEFINITION]
//[DefaultNameDelimiter]
var DefaultNameDelimiter: Char = '=';
ThsSeparator: Char = ',';
//[NewStrList DECLARATION]
function NewStrList: PStrList;
{* Creates string list object. }
{$IFDEF WIN}
function GetFileList(const dir: string): PStrList;
{* By Alexander Shakhaylo. Returns list of file names of the given directory. }
{$ENDIF WIN}
{$IFNDEF _FPC}
function WStrLen( W: PWideChar ): Integer;
{* Returns Length of null-terminated Unicode string. }
{$IFDEF _D3orHigher} {$ifdef win32}
function UTF8_2WideString( const s: AnsiString ): WideString;
{$ENDIF}{$ENDIF}
{$ENDIF _FPC}
//[TStrListEx]
type
{++}(*TStrListEx = class;*){--}
PStrListEx = {-}^{+}TStrListEx;
//[TStrListEx DEFINITION]
TStrListEx = object( TStrList )
{* Extended string list object. Has additional capability to associate
numbers or objects with string list items. }
protected
FObjects: PList;
function GetObjects(Idx: Integer): DWORD;
function GetObjectCount: Integer;
procedure SetObjects(Idx: Integer; const Value: DWORD);
procedure Init; {-}virtual;{+}{++}(*override;*){--}
procedure ProvideObjCapacity( NewCap: Integer );
public
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* }
property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects;
{* Objects are just 32-bit values. You can treat and use it as pointers to
any other data in the memory. But it is your task to free allocated
memory in such case therefore.
|
If the last item of a string list is deleted vis DeleteLast method (but
not via Delete method), it's object still is preserved. As well, it is
possible to set Objects[idx] for idx >= Count.
To get know object's count, rather then strings count, use ObjectCount
property. }
property ObjectCount: Integer read GetObjectCount;
{* Returns number of objects available. This value can differ from Count
after some operations: objects are stored in the independant list and
only synchronization is provided while using methods Delete, Insert,
Add, AddObject, InsertObject while changing the list. }
procedure AddStrings(Strings: PStrListEx);
{* Merges string list with given one. Very fast - more preferrable to
use than any loop with calling Add method. }
procedure Assign(Strings: PStrListEx);
{* Fills string list with strings from other one. The same as AddStrings,
but Clear is called first. }
procedure Clear;
{* Makes string list empty. }
procedure Delete(Idx: integer);
{* Deletes string with given index (it *must* exist). }
procedure Move(CurIndex, NewIndex: integer);
{* Moves string to another location. }
procedure Swap( Idx1, Idx2 : Integer );
{* Swaps to strings with given indeces. }
procedure Sort( CaseSensitive: Boolean );
{* Call it to sort string list. }
procedure AnsiSort( CaseSensitive: Boolean );
{* Call it to sort ANSI string list. }
function LastObj: DWORD;
{* Object assotiated with the last string. }
function AddObject( const S: String; Obj: DWORD ): Integer;
{* Adds a string and associates given number with it. Index of the item added
is returned. }
procedure InsertObject( Before: Integer; const S: String; Obj: DWORD );
{* Inserts a string together with object associated. }
function IndexOfObj( Obj: Pointer ): Integer;
{* Returns an index of a string associated with the object passed as a
parameter. If there are no such strings, -1 is returned. }
end;
//[END OF TStrListEx DEFINITION]
//[NewStrListEx DECLARATION]
function NewStrListEx: PStrListEx;
{* Creates extended string list object. }
//[TWStrList]
{-}
{$IFNDEF _FPC}
procedure WStrCopy( Dest, Src: PWideChar );
{* Copies null-terminated Unicode string (terminated null also copied). }
procedure WStrLCopy( Dest, Src: PWideChar; MaxLen: Integer );
{* Copies null-terminated Unicode string (terminated null also copied). }
function WStrCmp( W1, W2: PWideChar ): Integer;
{* Compares two null-terminated Unicode strings. }
{$ENDIF _FPC}
{$IFDEF WIN_GDI}
{$IFNDEF _D2} //------------------ WideString is not supported in D2 -----------
type
PWStrList = ^TWstrList;
{* }
//[TWstrList DEFINITION]
TWStrList = object( TObj )
{* String list to store Unicode (null-terminated) strings. }
protected
function GetCount: Integer;
function GetItems(Idx: Integer): WideString;
procedure SetItems(Idx: Integer; const Value: WideString);
function GetPtrs(Idx: Integer): PWideChar;
function GetText: WideString;
protected
fList: PList;
fText: PWideChar;
fTextBufSz: Integer;
fTmp1, fTmp2: WideString;
procedure Init; virtual;
public
procedure SetText(const Value: WideString);
{* See also TStrList.SetText }
destructor Destroy; virtual;
{* }
procedure Clear;
{* See also TStrList.Clear }
property Items[ Idx: Integer ]: WideString read GetItems write SetItems;
{* See also TStrList.Items }
property ItemPtrs[ Idx: Integer ]: PWideChar read GetPtrs;
{* See also TStrList.ItemPtrs }
property Count: Integer read GetCount;
{* See also TStrList.Count }
function Add( const W: WideString ): Integer;
{* See also TStrList.Add }
procedure Insert( Idx: Integer; const W: WideString );
{* See also TStrList.Insert }
procedure Delete( Idx: Integer );
{* See also TStrList.Delete }
property Text: WideString read GetText write SetText;
{* See also TStrList.Text }
procedure AddWStrings( WL: PWStrList );
{* See also TStrList.AddStrings }
procedure Assign( WL: PWStrList );
{* See also TStrList.Assign }
function LoadFromFile( const Filename: KOLString ): Boolean;
{* See also TStrList.LoadFromFile }
procedure LoadFromStream( Strm: PStream );
{* See also TStrList.LoadFromStream }
function MergeFromFile( const Filename: KOLString ): Boolean;
{* See also TStrList.MergeFromFile }
procedure MergeFromStream( Strm: PStream );
{* See also TStrList.MergeFromStream }
function SaveToFile( const Filename: KOLString ): Boolean;
{* See also TStrList.SaveToFile }
procedure SaveToStream( Strm: PStream );
{* See also TStrList.SaveToStream }
function AppendToFile( const Filename: KOLString ): Boolean;
{* See also TStrList.AppendToFile }
procedure Swap( Idx1, Idx2: Integer );
{* See also TStrList.Swap }
procedure Sort( CaseSensitive: Boolean );
{* See also TStrList.Sort }
procedure Move( IdxOld, IdxNew: Integer );
{* See also TStrList.Move }
function IndexOf( const s: WideString ): Integer;
{* }
end;
//[END OF TWStrList DEFINITION]
//[TWStrListEx]
PWStrListEx = ^TWStrListEx;
//[TWStrListEx DEFINITION]
TWStrListEx = object( TWStrList )
{* Extended Unicode string list (with Objects). }
protected
function GetObjects(Idx: Integer): DWORD;
procedure SetObjects(Idx: Integer; const Value: DWORD);
procedure ProvideObjectsCapacity( NewCap: Integer );
protected
fObjects: PList;
procedure Init; virtual;
public
destructor Destroy; virtual;
{* }
property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects;
{* }
procedure AddWStrings( WL: PWStrListEx );
{* }
procedure Assign( WL: PWStrListEx );
{* }
procedure Clear;
{* }
procedure Delete( Idx: Integer );
{* }
procedure Move( IdxOld, IdxNew: Integer );
{* }
function AddObject( const S: WideString; Obj: DWORD ): Integer;
{* Adds a string and associates given number with it. Index of the item added
is returned. }
procedure InsertObject( Before: Integer; const S: WideString; Obj: DWORD );
{* Inserts a string together with object associated. }
function IndexOfObj( Obj: Pointer ): Integer;
{* Returns an index of a string associated with the object passed as a
parameter. If there are no such strings, -1 is returned. }
end;
//[END OF TWStrListEx DEFINITION]
//[NewWStrList DECLARATION]
function NewWStrList: PWStrList;
{* Creates new TWStrList object and returns a pointer to it. }
//[NewWStrListEx DECLARATION]
function NewWStrListEx: PWStrListEx;
{* Creates new TWStrListEx objects and returns a pointer to it. }
{$ENDIF not _D2}
{$ENDIF WIN_GDI}
{$IFDEF UNICODE_CTRLS}
{$IFNDEF _D2}
type TKOLStrList = TWStrList;
PKOLStrList = PWStrList;
{$ELSE}
type TKOLStrList = TStrList;
PKOLStrList = PStrList;
{$ENDIF}
{$ELSE}
type TKOLStrList = TStrList;
PKOLStrList = PStrList;
{$ENDIF}
{+}
////////////////////////////////////////////////////////////////////////////////
// GRAPHIC OBJECTS //
////////////////////////////////////////////////////////////////////////////////
//[GRAPHIC OBJECTS]
{
It is very important, that the most of code, implementing graphic objets
from this section, is included into executable ONLY if really accessed in your
project directly (e.g., if Font or Brush properies of a control are accessed
or changed).
}
type
TColor = Integer;
const
//[COLOR CONSTANTS]
clScrollBar = TColor(COLOR_SCROLLBAR or $80000000);
clBackground = TColor(COLOR_BACKGROUND or $80000000);
clActiveCaption = TColor(COLOR_ACTIVECAPTION or $80000000);
clInactiveCaption = TColor(COLOR_INACTIVECAPTION or $80000000);
clMenu = TColor(COLOR_MENU or $80000000);
clWindow = TColor(COLOR_WINDOW or $80000000);
clWindowFrame = TColor(COLOR_WINDOWFRAME or $80000000);
clMenuText = TColor(COLOR_MENUTEXT or $80000000);
clWindowText = TColor(COLOR_WINDOWTEXT or $80000000);
clCaptionText = TColor(COLOR_CAPTIONTEXT or $80000000);
clActiveBorder = TColor(COLOR_ACTIVEBORDER or $80000000);
clInactiveBorder = TColor(COLOR_INACTIVEBORDER or $80000000);
clAppWorkSpace = TColor(COLOR_APPWORKSPACE or $80000000);
clHighlight = TColor(COLOR_HIGHLIGHT or $80000000);
clHighlightText = TColor(COLOR_HIGHLIGHTTEXT or $80000000);
clBtnFace = TColor(COLOR_BTNFACE or $80000000);
clBtnShadow = TColor(COLOR_BTNSHADOW or $80000000);
clGrayText = TColor(COLOR_GRAYTEXT or $80000000);
clBtnText = TColor(COLOR_BTNTEXT or $80000000);
clInactiveCaptionText = TColor(COLOR_INACTIVECAPTIONTEXT or $80000000);
clBtnHighlight = TColor(COLOR_BTNHIGHLIGHT or $80000000);
cl3DDkShadow = TColor(COLOR_3DDKSHADOW or $80000000);
cl3DLight = TColor(COLOR_3DLIGHT or $80000000);
clInfoText = TColor(COLOR_INFOTEXT or $80000000);
clInfoBk = TColor(COLOR_INFOBK or $80000000);
clBlack = TColor($000000);
clMaroon = TColor($000080);
clGreen = TColor($008000);
clOlive = TColor($008080);
clNavy = TColor($800000);
clPurple = TColor($800080);
clTeal = TColor($808000);
clGray = TColor($808080);
clSilver = TColor($C0C0C0);
clRed = TColor($0000FF);
clLime = TColor($00FF00);
clYellow = TColor($00FFFF);
clBlue = TColor($FF0000);
clFuchsia = TColor($FF00FF);
clAqua = TColor($FFFF00);
clLtGray = TColor($C0C0C0);
clDkGray = TColor($808080);
clWhite = TColor($FFFFFF);
clNone = TColor($1FFFFFFF);
clDefault = TColor($20000000);
clMoneyGreen = TColor($C0DCC0);
clSkyBlue = TColor($F0CAA6);
clCream = TColor($F0FBFF);
clMedGray = TColor($A4A0A0);
clGRushHiLight = TColor( $F3706C );
clGRushLighten = TColor( $F1EEDF );
clGRushLight = TColor( $e1cebf );
clGRushNormal = TColor( $D1beaf );
clGRushMedium = TColor( $b6bFc6 );
clGRushDark = TColor( $9EACB4 );
//[END OF COLOR CONSTANTS]
const
//[TGraphicTool FIELD OFFSET CONSTANTS]
go_Color = 0;
go_FontHeight = 4;
go_FontWidth = 8;
go_FontEscapement = 12;
go_FontOrientation = 16;
go_FontWeight = 20;
go_FontItalic = 24;
go_FontUnderline = 25;
go_FontStrikeOut = 26;
go_FontCharSet = 27;
go_FontOutPrecision = 28;
go_FontClipPrecision = 29;
go_FontQuality = 30;
go_FontPitch = 31;
go_FontName = 32;
go_BrushBitmap = 4;
go_BrushStyle = 8;
go_BrushLineColor = 9;
go_PenBrushBitmap = 4;
go_PenBrushStyle = 8;
go_PenStyle = 9;
go_PenWidth = 10;
go_PenMode = 14;
go_PenGeometric = 15;
go_PenEndCap = 16;
go_PenJoin = 17;
//[END OF TGraphicTool FIELD OFFSET CONSTANTS]
//[TGraphicTool]
type
TGraphicToolType = ( gttBrush, gttFont, gttPen );
{* Graphic object types, mainly for internal use. }
{++}(*TGraphicTool = class;*){--}
PGraphicTool = {-}^{+}TGraphicTool;
{* }
TOnGraphicChange = procedure ( Sender: PGraphicTool ) of object;
{* An event mainly for internal use. }
TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
{* Available brush styles. }
TFontStyles = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
{* Available font styles. }
TFontStyle = set of TFontStyles;
{* Font style is representing as a set of XFontStyles. }
TFontPitch = (fpDefault, fpFixed, fpVariable);
{* Availabe font pitch values. }
TFontName = type string;
{* Font name is represented as a string. }
TFontCharset = 0..255;
{* Font charset is represented by number from 0 to 255. }
TFontQuality = (fqDefault, fqDraft, fqProof, fqNonAntialiased, fqAntialiased
, fqClearType);
{* Font quality. }
TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,
psInsideFrame);
{* Available pen styles. For more info see Delphi or Win32 help files. }
TPenMode = (pmBlack, pmNotMerge, pmMaskNotPen, pmNotCopy, pmMaskPenNot,
pmNot, pmXor, pmNotMask, pmMask, pmNotXor, pmNop, pmMergePenNot,
pmCopy, pmMergeNotPen, pmMerge, pmWhite);
{* Available pen modes. For more info see Delphi or Win32 help files. }
TPenEndCap = (pecRound, pecSquare, pecFlat);
{* Avalable (for geometric pen) end cap styles. }
TPenJoin = (pjRound, pjBevel, pjMiter);
{* Available (for geometric pen) join styles. }
//[TGdiFont]
TGDIFont = packed record
Height: Integer;
Width: Integer;
Escapement: Integer;
Orientation: Integer;
Weight: Integer;
Italic: Boolean;
Underline: Boolean;
StrikeOut: Boolean;
CharSet: TFontCharset;
OutPrecision: Byte;
ClipPrecision: Byte;
Quality: TFontQuality;
Pitch: TFontPitch;
Name: array[0..LF_FACESIZE - 1] of KOLChar;
end;
//[TGDIBrush]
TGDIBrush = packed record
Bitmap: HBitmap;
Style: TBrushStyle;
LineColor: TColor;
end;
//[TGDIPen]
TGDIPen = packed record
BrushBitmap: HBitmap;
BrushStyle: TBrushStyle;
Style: TPenStyle;
Width: Integer;
Mode: TPenMode;
Geometric: Boolean;
EndCap: TPenEndCap;
Join: TPenJoin;
end;
//[TGDIToolData]
TGDIToolData = packed record
Color: TColor;
case Integer of
1: (Font: TGDIFont);
2: (Pen: TGDIPen);
3: (Brush: TGDIBrush);
end;
//[TNewGraphicTool]
TNewGraphicTool = function: PGraphicTool;
{ ---------------------------------------------------------------------
TGraphicTool - object to implement GDI-tools (brush, pen, font)
---------------------------------------------------------------------- }
//[TGraphicTool DEFINITION]
TGraphicTool = object( TObj )
{* Incapsulates all GDI objects: Pen, Brush and Font. }
protected
fType: TGraphicToolType;
{$IFDEF GDI}
fHandle: THandle;
fParentGDITool: PGraphicTool;
{$ENDIF GDI}
fColorRGB: TColor;
fOnChange: TOnGraphicChange;
fData: TGDIToolData;
fNewProc: TNewGraphicTool;
{$IFDEF GDI}
fMakeHandleProc: function( Self_: PGraphicTool ): THandle;
{$ENDIF GDI}
procedure SetInt( const Index: Integer; Value: Integer );
function GetInt( const Index: Integer ): Integer;
procedure SetColor( Value: TColor );
{$IFDEF GDI}
function GetBrushBitmap: HBitmap; // for BCB only
procedure SetBrushBitmap(const Value: HBitmap);
function GetBrushStyle: TBrushStyle; // for BCB only
{$ENDIF GDI}
procedure SetBrushStyle(const Value: TBrushStyle);
function GetFontName: KOLString;
procedure SetFontName(const Value: KOLString);
function GetFontStyle: TFontStyle;
procedure SetFontStyle(const Value: TFontStyle);
function GetFontWeight: Integer; // for BCB only
procedure SetFontWeight(const Value: Integer);
{$IFDEF GDI}
function GetFontCharset: TFontCharset; // for BCB only
procedure SetFontCharset(const Value: TFontCharset);
function GetFontQuality: TFontQuality; // for BCB only
procedure SetFontQuality(const Value: TFontQuality);
function GetFontOrientation: Integer; // for BCB only
procedure SetFontOrientation(Value: Integer);
function GetFontPitch: TFontPitch; // for BCB only
procedure SetFontPitch(const Value: TFontPitch);
function GetPenMode: TPenMode; // for BCB only
procedure SetPenMode(const Value: TPenMode);
function GetPenStyle: TPenStyle; // for BCB only
procedure SetPenStyle(const Value: TPenStyle);
function GetGeometricPen: Boolean; // for BCB only
procedure SetGeometricPen(const Value: Boolean);
function GetPenEndCap: TPenEndCap; // for BCB only
procedure SetPenEndCap(const Value: TPenEndCap);
function GetPenJoin: TPenJoin; // for BCB only
procedure SetPenJoin(const Value: TPenJoin);
procedure SetLogFontStruct(const Value: TLogFont);
function GetLogFontStruct: TLogFont;
{$ENDIF GDI}
protected
procedure Changed;
{* }
{$IFDEF GDI}
function GetHandle: THandle;
{* }
{$ENDIF GDI}
protected
{$IFDEF _X_}
{$IFDEF GTK}
fPangoFontDesc: PPangoFontDescription;
function GetPangoFontDesc: PPangoFontDescription;
{$ENDIF GTK}
{$ENDIF _X_}
public
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* }
{$IFDEF _X_}
{$IFDEF GTK}
property FontHandle: PPangoFontDescription read GetPangoFontDesc;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
property Handle: THandle read GetHandle;
{* Every time, when accessed, real GDI object is created (if it is
not yet created). So, to prevent creating of the handle, use
HandleAllocated instead of comparing Handle with value 0. }
function HandleAllocated: Boolean;
{* Returns True, if handle is allocated (i.e., if real GDI
objet is created. }
{$ENDIF GDI}
property OnChange: TOnGraphicChange read fOnChange write fOnChange;
{* Called, when object is changed. }
{$IFDEF GDI}
function ReleaseHandle: Integer;
{* Returns Handle value (if allocated), releasing it from the
object (so, it is no more knows about this handle and its
HandleAllocated function returns False. }
{$ENDIF GDI}
property Color: TColor {index go_Color} read fData.Color write SetColor;
{* Color is the most common property for all Pen, Brush and
Font objects, so it is placed in its common for all of them. }
function Assign( Value: PGraphicTool ): PGraphicTool;
{* Assigns properties of the same (only) type graphic object,
excluding Handle. If assigning is really leading to change
object, procedure Changed is called. }
{$IFDEF GDI}
procedure AssignHandle( NewHandle: Integer );
{* Assigns value to Handle property. }
property BrushBitmap: HBitmap read {-BCB-}fData.Brush.Bitmap{+BCB+}
{BCB++}(*GetBrushBitmap*){--BCB}
write SetBrushBitmap;
{* Brush bitmap. For more info about using brush bitmap,
see Delphi or Win32 help files. }
{$ENDIF GDI}
property BrushStyle: TBrushStyle read {-BCB-}fData.Brush.Style{+BCB+}
{BCB++}(*GetBrushStyle*){--BCB}
write SetBrushStyle;
{$IFDEF GDI}
{* Brush style. }
property BrushLineColor: TColor index go_BrushLineColor
{$IFDEF F_P}
read GetInt
{$ELSE DELPHI}
read {-BCB-}fData.Brush.LineColor{+BCB+}
{BCB++}(*GetInt*){--BCB}
{$ENDIF F_P/DELPHI}
write SetInt;
{* Brush line color, used to represent lines in hatched brush. Default value is clBlack. }
{$ENDIF GDI}
property FontHeight: Integer index go_FontHeight
{$IFDEF F_P}
read GetInt
{$ELSE DELPHI}
read {-BCB-}fData.Font.Height{+BCB+}
{BCB++}(*GetInt*){--BCB}
{$ENDIF F_P/DELPHI}
write SetInt;
{* Font height. Value 0 (default) seys to use system default value,
negative values are to represent font height in "points", positive
- in pixels. In XCL usually positive values (if not 0) are used to
make appearance independent from different local settings. }
{$IFDEF GDI}
property FontWidth: Integer index go_FontWidth
{$IFDEF F_P}
read GetInt
{$ELSE DELPHI}
read {-BCB-}fData.Font.Width{+BCB+}
{BCB++}(*GetInt*){--BCB}
{$ENDIF F_P/DELPHI}
write SetInt;
{* Font width in logical units. If FontWidth = 0, then as it is said
in Win32.hlp, "the aspect ratio of the device is matched against the
digitization aspect ratio of the available fonts to find the closest match,
determined by the absolute value of the difference." }
property FontPitch: TFontPitch read {-BCB-}fData.Font.Pitch{+BCB+}
{BCB++}(*GetFontPitch*){--BCB}
write SetFontPitch;
{* Font pitch. Change it very rare. }
{$ENDIF GDI}
property FontStyle: TFontStyle read GetFontStyle write SetFontStyle;
{* Very useful property to control text appearance. }
{$IFDEF GDI}
property FontCharset: TFontCharset read {-BCB-}fData.Font.Charset{+BCB+}
{BCB++}(*GetFontCharset*){--BCB}
write SetFontCharset;
{* Do not change it if You do not know what You do. }
property FontQuality: TFontQuality read {-BCB-}fData.Font.Quality{+BCB+}
{BCB++}(*GetFontQuality*){--BCB}
write SetFontQuality;
{* Font quality. }
property FontOrientation: Integer read {-BCB-}fData.Font.Orientation{+BCB+}
{BCB++}(*GetFontOrientation*){--BCB}
write SetFontOrientation;
{* It is possible to rotate text in XCL just by changing this
property of a font (tenths of degree, i.e. value 900 represents
90 degree - text written from bottom to top). }
{$ENDIF GDI}
property FontWeight: Integer read {-BCB-}fData.Font.Weight{+BCB+}
{BCB++}(*GetFontWeight*){--BCB}
write SetFontWeight;
{* Additional font weight for bold fonts (must be 0..1000). When set to
value <> 0, fsBold is added to FontStyle. And otherwise, when set to 0,
fsBold is removed from FontStyle. Value 700 corresponds to Bold,
400 to Normal. }
property FontName: KOLString read GetFontName write SetFontName;
{* Font face name. }
{$IFDEF GDI}
function IsFontTrueType: Boolean;
{* Returns True, if font is True Type. Requires of creating of a Handle,
if it is not yet created. }
property PenWidth: Integer index go_PenWidth
{$IFDEF F_P}
read GetInt
{$ELSE DELPHI}
read {-BCB-}fData.Pen.Width{+BCB+}
{BCB++}(*GetInt*){--BCB}
{$ENDIF F_P/DELPHI}
write SetInt;
{* Value 0 means default pen width. }
property PenStyle: TPenStyle read {-BCB-}fData.Pen.Style{+BCB+}
{BCB++}(*GetPenStyle*){--BCB}
write SetPenStyle;
{* Pen style. }
property PenMode: TPenMode read {-BCB-}fData.Pen.Mode{+BCB+}
{BCB++}(*GetPenMode*){--BCB}
write SetPenMode;
{* Pen mode. }
property GeometricPen: Boolean read {-BCB-}fData.Pen.Geometric{+BCB+}
{BCB++}(*GetGeometricPen*){--BCB}
write SetGeometricPen;
{* True if Pen is geometric. Note, that under Win95/98 only pen styles
psSolid, psNull, psInsideFrame are supported by OS. }
property PenBrushStyle: TBrushStyle read {-BCB-}fData.Pen.BrushStyle{+BCB+}
{BCB++}(*GetBrushStyle*){--BCB}
write SetBrushStyle;
{* Brush style for hatched geometric pen. }
property PenBrushBitmap: HBitmap read {-BCB-}fData.Pen.BrushBitmap{+BCB+}
{BCB++}(*GetBrushBitmap*){--BCB}
write SetBrushBitmap;
{* Brush bitmap for geometric pen (if assigned Pen is functioning as
its style = BS_PATTERN, regadless of PenBrushStyle value). }
property PenEndCap: TPenEndCap read {-BCB-}fData.Pen.EndCap{+BCB+}
{BCB++}(*GetPenEndCap*){--BCB}
write SetPenEndCap;
{* Pen end cap mode - for GeometricPen only. }
property PenJoin: TPenJoin read {-BCB-}fData.Pen.Join{+BCB+}
{BCB++}(*GetPenJoin*){--BCB}
write SetPenJoin;
{* Pen join mode - for GeometricPen only. }
property LogFontStruct: TLogFont read GetLogFontStruct write SetLogFontStruct;
{* by Alex Pravdin: a property to change all font structure items at once. }
{$ENDIF GDI}
end;
//[END OF TGraphicTool DEFINITION]
//[Color2XXX FUNCTIONS]
function Color2RGB( Color: TColor ): TColor;
{* Function to get RGB color from system color. Parameter can be also RGB
color, in that case result is just equal to a parameter. }
{$IFDEF GTK}
function Color2GDKColor( Color: TColor ): TGdkColor;
{$ENDIF GTK}
function ColorsMix( Color1, Color2: TColor ): TColor;
{* Returns color, which RGB components are build as an (approximate)
arithmetic mean of correspondent RGB components of both source
colors (these both are first converted from system to RGB, and
result is always RGB color). Please note: this function is fast,
but can be not too exact. }
{$IFDEF WIN_GDI}
function Color2RGBQuad( Color: TColor ): TRGBQuad;
{* Converts color to RGB, used to represent RGB values in palette entries
(actually swaps R and B bytes). }
function Color2Color16( Color: TColor ): WORD;
{* Converts Color to RGB, packed to word (as it is used in format pf16bit). }
function Color2Color15( Color: TColor ): WORD;
{* Converts Color to RGB, packed to word (as it is used in format pf15bit). }
{$ifdef wince}
procedure CeFrameRect(DC: HDC; const Rect: TRect; Color: TColor);
{$endif wince}
//[DefFont VARIABLE]
var // New TFont instances are intialized with the values in this structure:
DefFont: TGDIFont = (
Height: 0;
Width: 0;
Escapement: 0;
Orientation: 0;
Weight: 0;
Italic: FALSE;
Underline: FALSE;
StrikeOut: FALSE;
CharSet: 1;
OutPrecision: 0;
ClipPrecision: 0;
Quality: fqDefault;
Pitch: fpDefault;
{$IFDEF UNICODE_CTRLS}
Name: ( 'M', 'S', ' ', 'S', 'a', 'n', 's', ' ', 'S', 'e', 'r', 'i', 'f',
#0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
#0, #0 );
{$ELSE}
Name: 'MS Sans Serif';
{$ENDIF}
);
DefFontColor: TColor = clWindowText;
{* Default font color. }
//[GlobalGraphics_UseFontOrient]
GlobalGraphics_UseFontOrient: Boolean;
{* Global flag. If stays False (default), Orientation property of Font
objects is ignored. This flag is set to True automatically in
RotateFonts add-on. }
{$ENDIF WIN_GDI}
{ -- Constructors for different GDI tools -- }
//[New FUNCTIONS FOR TGraphicTool]
function NewFont: PGraphicTool;
{* Creates and returns font graphic tool object. }
function NewBrush: PGraphicTool;
{* Creates and returns new brush object. }
function NewPen: PGraphicTool;
{* Creates and returns new pen object. }
{ -- TCanvas object -- }
//[TCanvas]
const
HandleValid = 1;
PenValid = 2;
BrushValid = 4;
FontValid = 8;
ChangingCanvas = 16;
{$IFDEF WIN_GDI}
type
TFillStyle = (fsSurface, fsBorder);
{* Available filling styles. For more info see Win32 or Delphi help files. }
TFillMode = (fmAlternate, fmWinding);
{* Available filling modes. For more info see Win32 or Delphi help files. }
TCopyMode = Integer;
{* Available copying modes are following:
| cmBlackness
| cmDstInvert
| cmMergeCopy
| cmMergePaint
| cmNotSrcCopy
| cmNotSrcErase
| cmPatCopy
| cmPatInvert
| cmPatPaint
| cmSrcAnd
| cmSrcCopy
| cmSrcErase
| cmSrcInvert
| cmSrcPaint
| cmWhiteness
Also it is possible to use any other available ROP2 modes. For more info,
see Win32 help files. }
const
cmBlackness = BLACKNESS;
cmDstInvert = DSTINVERT;
cmMergeCopy = MERGECOPY;
cmMergePaint = MERGEPAINT;
cmNotSrcCopy = NOTSRCCOPY;
cmNotSrcErase = NOTSRCERASE;
cmPatCopy = PATCOPY;
cmPatInvert = PATINVERT;
cmPatPaint = PATPAINT;
cmSrcAnd = SRCAND;
cmSrcCopy = SRCCOPY;
cmSrcErase = SRCERASE;
cmSrcInvert = SRCINVERT;
cmSrcPaint = SRCPAINT;
cmWhiteness = WHITENESS;
{$ENDIF WIN_GDI}
type
{$IFDEF _X_}
{$IFDEF GTK}
HDC = PGdkGC;
{$ENDIF GTK}
{$ENDIF _X_}
{++}(*TCanvas = class;*){--}
PCanvas = {-}^{+}TCanvas;
{* }
TOnGetHandle = function( Canvas: PCanvas ): HDC of object;
{* For internal use mainly. }
TOnTextArea = procedure( Sender: PCanvas; var Size : TSize; var P0 : TPoint );
{* Event to calculate actual area, occupying by a text. It is used
to optionally extend calculating of TextArea taking into considaration
font Orientation property. }
{ ---------------------------------------------------------------------
TCanvas - high-level drawing helper object
----------------------------------------------------------------------- }
//[TCanvas DEFINITION]
TCanvas = object( TObj )
{* Very similar to VCL's TCanvas object. But with some changes, specific
for KOL: there is no necessary to use canvases in all applications.
And graphic tools objects are not created with canvas, but only
if really accessed in program. (Actually, even if paint box used,
only programmer decides, if to implement painting using Canvas or
to call low level API drawing functions working directly with DC).
Therefore TCanvas has some powerful extensions: rotated text support,
geometric pen support - just by changing correspondent properties
of certain graphic tool objects (Font.FontOrientation, Pen.GeometricPen).
See also additional Font properties (Font.FontWeight, Font.FontQuality,
etc. }
protected
fOwnerControl: Pointer; //PControl;
{$IFDEF _X_}
{$IFDEF GTK}
fDrawable: PGdkDrawable;
fTmpColor: PGdkColor;
{$ENDIF GTK}
{$ENDIF _X_}
fHandle : HDC;
fPenPos : TPoint;
fState : Byte;
fBrush, fPen: PGraphicTool;
fFont : PGraphicTool; // order is important for ASM version
{$IFDEF GDI}
fCopyMode : TCopyMode;
fOnChange: TOnEvent;
{$ENDIF GDI}
fOnGetHandle: TOnGetHandle;
{$IFDEF _X_}
{$IFDEF GTK}
fSavedState: TGdkGCValues;
procedure SaveState;
procedure RestoreState;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
procedure SetHandle( Value : HDC );
{$ENDIF GDI}
procedure SetPenPos( const Value : TPoint );
{$IFDEF GDI}
procedure CreatePen;
procedure CreateBrush;
procedure CreateFont;
procedure Changing;
{$ENDIF GDI}
procedure ObjectChanged( Sender : PGraphicTool );
function GetBrush: PGraphicTool;
function GetFont: PGraphicTool;
function GetPen: PGraphicTool;
function GetHandle: HDC;
procedure AssignChangeEvents;
{$IFDEF GDI}
function GetPixels(X, Y: Integer): TColor;
procedure SetPixels(X, Y: Integer; const Value: TColor);
protected
fIsPaintDC : Boolean;
{* TRUE, if DC obtained during current WM_PAINT (or WM_ERASEBKGND?)
processing for a control. This affects a way how Handle is released. }
{++}(*public*){--}
destructor Destroy;{-}virtual;{+}{++}(*override;*){--}
{* }
{++}(*protected*){--}
{$ENDIF GDI}
property OnGetHandle: TOnGetHandle read fOnGetHandle write fOnGetHandle;
{* For internal use only. }
{$IFDEF GDI}
{$ENDIF GDI}
public
property Handle : HDC read GetHandle {$IFDEF GDI} write SetHandle {$ENDIF GDI};
{* GDI device context object handle. Never created by
Canvas itself (to use Canvas with memory bitmaps,
always create DC by yourself and assign it to the
Handle property of Canvas object, or use property
Canvas of a bitmap). }
property PenPos : TPoint read FPenPos write SetPenPos;
{* Position of a pen. }
property Pen : PGraphicTool read GetPen;
{* Pen of Canvas object. Do not change its Pen.OnChange event value. }
property Brush : PGraphicTool read GetBrush;
{* Brush of Canvas object. Do not change its Brush.OnChange event value. }
property Font : PGraphicTool read GetFont;
{* Font of Canvas object. Do not change its Font.OnChange event value. }
{$IFNDEF NOT_USE_KOLMATH} // if using KOLmath disabled, Arc becomes unavailable
procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Draws arc. For more info, see Delphi TCanvas help. }
{$ENDIF NOT_USE_KOLMATH}
{$IFDEF GDI}
procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Draws chord. For more info, see Delphi TCanvas help. }
procedure DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
{* Draws rectangle to represent focused visual object.
For more info, see Delphi TCanvas help. }
procedure Ellipse(X1, Y1, X2, Y2: Integer);
{* Draws an ellipse. For more info, see Delphi TCanvas help. }
{$ENDIF GDI}
procedure FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
{* Fills rectangle. For more info, see Delphi TCanvas help. }
{$IFDEF GDI}
procedure FillRgn( const Rgn : HRgn );
{* Fills region. For more info, see Delphi TCanvas help. }
procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
{* Fills a figure with givien color, floodfilling its surface.
For more info, see Delphi TCanvas help. }
procedure FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
{* Draws a rectangle using Brush settings (color, etc.).
For more info, see Delphi TCanvas help. }
{$ENDIF GDI}
procedure MoveTo( X, Y : Integer );
{* Moves current PenPos to a new position.
For more info, see Delphi TCanvas help. }
procedure LineTo( X, Y : Integer );
{* Draws a line from current PenPos up to new position.
For more info, see Delphi TCanvas help. }
{$IFDEF GDI}
procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Draws a pie. For more info, see Delphi TCanvas help. }
procedure Polygon(const Points: array of TPoint);
{* Draws a polygon. For more info, see Delphi TCanvas help. }
procedure Polyline(const Points: array of TPoint);
{* Draws a bound for polygon. For more info, see Delphi TCanvas help. }
procedure Rectangle(X1, Y1, X2, Y2: Integer);
{* Draws a rectangle using current Pen and/or Brush.
For more info, see Delphi TCanvas help. }
procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
{* Draws a rounded rectangle. For more info, see Delphi TCanvas help. }
{$ENDIF GDI}
procedure TextOut(X, Y: Integer; const Text: KOLString); {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Draws a text. For more info, see Delphi TCanvas help. }
procedure ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: KOLString;
const Spacing: array of Integer );
{* }
procedure TextRect(const Rect: TRect; X, Y: Integer; const Text: KOLString);
{* Draws a text, clipping output into given rectangle.
For more info, see Delphi TCanvas help. }
{$IFDEF GDI}
procedure DrawText(Text:KOLString; var Rect:TRect; Flags:DWord);
{* }
{$ENDIF GDI}
function TextExtent(const Text: KOLstring): TSize;
{* Calculates size of a Text, using current Font settings.
Does not need in Handle for Canvas object (if it is not
yet allocated, temporary device context is created and used. }
procedure TextArea( const Text : KOLString; var Sz : TSize; var P0 : TPoint );
{* Calculates size and starting point to output Text,
taking into considaration all Font attributes, including
Orientation (only if GlobalGraphics_UseFontOrient flag
is set to True, i.e. if rotated fonts are used).
Like for TextExtent, does not need in Handle (and if this
last is not yet allocated/assigned, temporary device context
is created and used). }
function TextWidth(const Text: KOLstring): Integer;
{* Calculates text width (using TextArea). }
function TextHeight(const Text: KOLstring): Integer;
{* Calculates text height (using TextArea). }
{$IFDEF GDI}
function ClipRect: TRect;
{* returns ClipBox. by Dmitry Zharov. }
{$IFNDEF _FPC}
{$IFNDEF _D2} //------- WideString not supported in D2
procedure WTextOut(X, Y: Integer; const WText: WideString); {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Draws a Unicode text. }
procedure WExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect;
const WText: WideString; const Spacing: array of Integer );
{* }
procedure WDrawText(WText: WideString; var Rect:TRect; Flags:DWord);
{* }
procedure WTextRect(const Rect: TRect; X, Y: Integer;
const WText: WideString);
{* Draws a Unicode text, clipping output into given rectangle. }
function WTextExtent( const WText: WideString ): TSize;
{* Calculates Unicode text width and height. }
function WTextWidth( const WText: WideString ): Integer;
{* Calculates Unicode text width. }
function WTextHeight( const WText: WideString ): Integer;
{* Calculates Unicode text height. }
{$ENDIF _D2}
{$ENDIF _FPC}
property ModeCopy : TCopyMode read fCopyMode write fCopyMode;
{* Current copy mode. Is used in CopyRect method. }
procedure CopyRect( const DstRect : TRect; SrcCanvas : PCanvas; const SrcRect : TRect );
{* Copyes a rectangle from source to destination, using StretchBlt. }
property OnChange: TOnEvent read fOnChange write fOnChange;
{* }
function Assign( SrcCanvas : PCanvas ) : Boolean;
{* }
{$ENDIF GDI}
{$IFDEF _X_}
protected // for _X_ case, RequiredState is protected yet (???)
procedure ForeBack(fg_color, bk_color: TColor); // install colors just before drawing
{$ENDIF _X_}
{$IFDEF GDI}
function RequiredState( ReqState : DWORD ): HDC; {$ifdef wince}cdecl{$else}stdcall{$endif};// public now
{* It is possible to call this method before using Handle property
to pass it into API calls - to provide valid combinations of
pen, brush and font, selected into device context. This method
can not provide valid Handle - You always must create it by
yourself and assign to TCanvas.Handle property manually.
To optimize assembler version, returns Handle value. }
public
{$ENDIF GDI}
procedure DeselectHandles;
{* Call this method to deselect all graphic tool objects from the canvas. }
{$IFDEF GDI}
property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels;
{* Obvious. }
{$ENDIF GDI}
end;
//[END OF TCanvas DEFINITION]
//[NewCanvas DECLARATION]
function NewCanvas( DC: HDC ): PCanvas;
{* Use to construct Canvas on base of memory DC. }
//[GlobalCanvas_OnTextArea]
var
GlobalCanvas_OnTextArea : TOnTextArea;
{* Global event to extend Canvas with possible add-ons, applied
when rotated fonts are used only (to take into consideration
Font.Orientation property in TextArea method). }
{$IFDEF WIN_GDI}
{ -- Image list object -- }
//[IMAGE LIST]
type
TImageListColors = (ilcColor,ilcColor4,ilcColor8,ilcColor16,
ilcColor24,ilcColor32,ilcColorDDB,ilcDefault);
{* ImageList color schemes available. }
TDrawingStyles = ( dsBlend25, dsBlend50, dsMask, dsTransparent );
{* ImageList drawing styles available. }
TDrawingStyle = Set of TDrawingStyles;
{* Style of drawing is a combination of all available drawing styles. }
TImageType = (itBitmap,itIcon,itCursor);
{* ImageList types available. }
{++}(*TImageList = class;*){--}
PImageList = {-}^{+}TImageList;
{* }
TImgLOVrlayIdx = 1..15;
{ ---------------------------------------------------------------------
TImageList - images container
----------------------------------------------------------------------- }
//[TImageList DEFINITION]
TImageList = object( TObj )
{* ImageList incapsulation. }
protected
FHandle: THandle;
FControl: Pointer; // PControl;
fPrev, fNext: PImageList;
FColors: TImageListColors;
FMasked: Boolean;
FImgWidth: Integer;
FImgHeight: Integer;
FDrawingStyle: TDrawingStyle;
FBlendColor: TColor;
fBkColor: TColor;
FAllocBy: Integer;
FShareImages: Boolean;
FOverlay: array[ TImgLOVrlayIdx ] of Integer;
function HandleNeeded : Boolean;
procedure SetColors(const Value: TImageListColors);
procedure SetMasked(const Value: Boolean);
procedure SetImgWidth(const Value: Integer);
procedure SetImgHeight(const Value: Integer);
function GetCount: Integer;
function GetBkColor: TColor;
procedure SetBkColor(const Value: TColor);
function GetBitmap: HBitmap;
function GetMask: HBitmap;
function GetDrawStyle : DWord;
procedure SetAllocBy(const Value: Integer);
function GetHandle: THandle;
function GetOverlay(Idx: TImgLOVrlayIdx): Integer;
procedure SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer);
protected
procedure SetHandle(const Value: THandle);
{*}
public
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{*}
property Handle : THandle read GetHandle write SetHandle;
{* Handle of ImageList object. }
property ShareImages : Boolean read FShareImages write FShareImages;
{* True if images are shared between processes (it is set to True,
if its Handle is assigned to given value, which is a handle of
already existing ImageList object). }
property Colors : TImageListColors read FColors write SetColors;
{* Colors used to represent images. }
property Masked : Boolean read FMasked write SetMasked;
{* True, if mask is used. It is set to True, if first added image
is icon, e.g. }
property ImgWidth : Integer read FImgWidth write SetImgWidth;
{* Width of every image in list. If change, ImageList is cleared. }
property ImgHeight : Integer read FImgHeight write SetImgHeight;
{* Height of every image in list. If change, ImageList is cleared. }
property Count : Integer read GetCount;
{* Number of images in list. }
property AllocBy : Integer read FAllocBy write SetAllocBy;
{* Allocation factor. Default is 1. Set it to size of ImageList if this
value is known - to optimize speed of allocation. }
property BkColor : TColor read GetBkColor write SetBkColor;
{* Background color. }
property BlendColor : TColor read FBlendColor write FBlendColor;
{* Blend color. }
property Bitmap : HBitmap read GetBitmap;
{* Bitmap, containing all ImageList images (tiled horizontally). }
property Mask : HBitmap read GetMask;
{* Monochrome bitmap, containing masks for all images in list (if not
Masked, always returns nil). }
function ImgRect( Idx : Integer ) : TRect;
{* Rectangle occupied of given image in ImageList. }
function Add( Bmp, Msk : HBitmap ) : Integer;
{* Adds bitmap and given mask to ImageList. }
function AddMasked( Bmp : HBitmap; Color : TColor ) : Integer;
{* Adds bitmap to ImageList, using given color to create mask. }
function AddIcon( Ico : HIcon ) : Integer;
{* Adds icon to ImageList (always masked). }
procedure Delete( Idx : Integer );
{* Deletes given image from ImageList. }
procedure Clear;
{* Makes ImageList empty. }
function Replace( Idx : Integer; Bmp, Msk : HBitmap ) : Boolean;
{* Replaces given (by index) image with bitmap and its mask with mask bitmap. }
function ReplaceIcon( Idx : Integer; Ico : HIcon ) : Boolean;
{* Replaces given (by index) image with an icon. }
function Merge( Idx : Integer; ImgList2 : PImageList; Idx2 : Integer; X, Y : Integer )
: PImageList;
{* Merges two ImageList objects, returns resulting ImageList. }
function ExtractIcon( Idx : Integer ) : HIcon;
{* Extracts icon by index. }
function ExtractIconEx( Idx : Integer ) : HIcon;
{* Extracts icon (is created using current drawing style). }
property DrawingStyle : TDrawingStyle read FDrawingStyle write FDrawingStyle;
{* Drawing style. }
procedure Draw( Idx : Integer; DC : HDC; X, Y : Integer );
{* Draws given (by index) image from ImageList onto passed Device Context. }
procedure StretchDraw( Idx : Integer; DC : HDC; const Rect : TRect );
{* Draws given image with stratching. }
function LoadBitmap( ResourceName : PKOLChar; TranspColor : TColor ) : Boolean;
{* Loads ImageList from resource. }
//function LoadIcon( ResourceName : PChar ) : Boolean;
//function LoadCursor( ResourceName : PChar ) : Boolean;
function LoadFromFile( FileName : PKOLChar; TranspColor : TColor; ImgType : TImageType ) : Boolean;
{* Loads ImageList from file. }
function LoadSystemIcons( SmallIcons : Boolean ) : Boolean;
{* Assigns ImageList to system icons list (big or small). }
property Overlay[ Idx: TImgLOVrlayIdx ]: Integer read GetOverlay write SetOverlay;
{* Overlay images for image list (images, used as overlay images to draw over
other images from the image list). These overalay images can be used in
listview and treeview as overlaying images (up to four masks at the same
time). }
{$IFDEF USE_CONSTRUCTORS}
constructor CreateImageList( POwner: Pointer );
{$ENDIF USE_CONSTRUCTORS}
end;
//[END OF TImageList DEFINITION]
//[IMAGE LIST API]
{$ifdef win32}
const
CLR_NONE = $FFFFFFFF;
CLR_DEFAULT = $FF000000;
type
HImageList = THandle;
const
ILC_MASK = $0001;
ILC_COLOR = $00FE;
ILC_COLORDDB = $00FE;
ILC_COLOR4 = $0004;
ILC_COLOR8 = $0008;
ILC_COLOR16 = $0010;
ILC_COLOR24 = $0018;
ILC_COLOR32 = $0020;
ILC_PALETTE = $0800;
const
ILD_NORMAL = $0000;
ILD_TRANSPARENT = $0001;
ILD_MASK = $0010;
ILD_IMAGE = $0020;
ILD_BLEND25 = $0002;
ILD_BLEND50 = $0004;
ILD_OVERLAYMASK = $0F00;
const
ILD_SELECTED = ILD_BLEND50;
ILD_FOCUS = ILD_BLEND25;
ILD_BLEND = ILD_BLEND50;
CLR_HILIGHT = CLR_DEFAULT;
function ImageList_Create(CX, CY: Integer; Flags: UINT;
Initial, Grow: Integer): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_Destroy(ImageList: HImageList): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_GetImageCount(ImageList: HImageList): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_SetImageCount(ImageList: HImageList; Count: Integer): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_Add(ImageList: HImageList; Image, Mask: HBitmap): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_ReplaceIcon(ImageList: HImageList; Index: Integer;
Icon: HIcon): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_SetBkColor(ImageList: HImageList; ClrBk: TColorRef): TColorRef; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_GetBkColor(ImageList: HImageList): TColorRef; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_SetOverlayImage(ImageList: HImageList; Image: Integer;
Overlay: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer;
function Index2OverlayMask(Index: Integer): Integer;
function ImageList_Draw(ImageList: HImageList; Index: Integer;
Dest: HDC; X, Y: Integer; Style: UINT): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_Replace(ImageList: HImageList; Index: Integer;
Image, Mask: HBitmap): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_AddMasked(ImageList: HImageList; Image: HBitmap;
Mask: TColorRef): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_DrawEx(ImageList: HImageList; Index: Integer;
Dest: HDC; X, Y, DX, DY: Integer; Bk, Fg: TColorRef; Style: Cardinal): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_Remove(ImageList: HImageList; Index: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_GetIcon(ImageList: HImageList; Index: Integer;
Flags: Cardinal): HIcon; {$ifdef wince}cdecl{$else}stdcall{$endif};
{$IFDEF UNICODE_CTRLS}
function ImageList_LoadImage(Instance: THandle; Bmp: PWideChar; CX, Grow: Integer;
Mask: TColorRef; pType, Flags: Cardinal): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
{$ELSE}
function ImageList_LoadImage(Instance: THandle; Bmp: PAnsiChar; CX, Grow: Integer;
Mask: TColorRef; pType, Flags: Cardinal): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
{$ENDIF}
function ImageList_BeginDrag(ImageList: HImageList; Track: Integer;
XHotSpot, YHotSpot: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_EndDrag: Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_DragEnter(LockWnd: HWnd; X, Y: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_DragLeave(LockWnd: HWnd): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_DragMove(X, Y: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_SetDragCursorImage(ImageList: HImageList; Drag: Integer;
XHotSpot, YHotSpot: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_DragShowNolock(Show: Bool): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_GetDragImage(Point, HotSpot: PPoint): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
{ macros }
procedure ImageList_RemoveAll(ImageList: HImageList); {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList;
Image: Integer): HIcon; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_LoadBitmap(Instance: THandle; Bmp: PKOLChar;
CX, Grow: Integer; MasK: TColorRef): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
//function ImageList_Read(Stream: IStream): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
//function ImageList_Write(ImageList: HImageList; Stream: IStream): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
//[TImageInfo]
type
PImageInfo = ^TImageInfo;
TImageInfo = {$ifndef wince}packed{$endif} record
hbmImage: HBitmap;
hbmMask: HBitmap;
Unused1: Integer;
Unused2: Integer;
rcImage: TRect;
end;
function ImageList_GetIconSize(ImageList: HImageList; var CX, CY: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_SetIconSize(ImageList: HImageList; CX, CY: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_GetImageInfo(ImageList: HImageList; Index: Integer;
var ImageInfo: TImageInfo): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
function ImageList_Merge(ImageList1: HImageList; Index1: Integer;
ImageList2: HImageList; Index2: Integer; DX, DY: Integer)://Bool - ERROR IN VCL
HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
{$endif win32}
//[LoadBmp]
function LoadBmp( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap;
//[BITMAPS]
type
tagBitmap = Windows.TBitmap;
TPixelFormat = ( pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit,
pf32bit, pfCustom );
{* Available pixel formats. }
TBitmapHandleType = ( bmDIB, bmDDB );
{* Available bitmap handle types. }
{++}(*TBitmap = class;*){--}
PBitmap = {-}^{+}TBitmap;
{ ----------------------------------------------------------------------
TBitmap - bitmap image
----------------------------------------------------------------------- }
//[TBitmap DEFINITION]
TBitmap = object( TObj )
{* Bitmap incapsulation object. }
protected
fHeight: Integer;
fWidth: Integer;
fHandle: HBitmap;
fCanvas: PCanvas;
fScanLineSize: Integer;
fBkColor: TColor;
fApplyBkColor2Canvas: procedure( Sender: PBitmap );
fDetachCanvas: procedure( Sender: PBitmap );
fCanvasAttached : Integer;
fHandleType: TBitmapHandleType;
fDIBHeader: PBitmapInfo;
fDIBBits: Pointer;
fDIBSize: Integer;
fNewPixelFormat: TPixelFormat;
fFillWithBkColor: procedure( BmpObj: PBitmap; DC: HDC; oldW, oldH: Integer );
fTransMaskBmp: PBitmap;
fTransColor: TColor;
fGetDIBPixels: function( Bmp: PBitmap; X, Y: Integer ): TColor;
fSetDIBPixels: procedure( Bmp: PBitmap; X, Y: Integer; Value: TColor );
fScanLine0: PByte;
fScanLineDelta: Integer;
fPixelMask: DWORD;
fPixelsPerByteMask: Integer;
fBytesPerPixel: Integer;
fDIBAutoFree: Boolean;
procedure SetHeight(const Value: Integer);
procedure SetWidth(const Value: Integer);
function GetEmpty: Boolean;
function GetHandle: HBitmap;
function GetHandleAllocated: Boolean;
procedure SetHandle(const Value: HBitmap);
procedure SetPixelFormat(Value: TPixelFormat);
procedure FormatChanged;
function GetCanvas: PCanvas;
procedure CanvasChanged( Sender: PObj );
function GetScanLine(Y: Integer): Pointer;
function GetScanLineSize: Integer;
procedure ClearData;
procedure ClearTransImage;
procedure SetBkColor(const Value: TColor);
function GetDIBPalEntries(Idx: Integer): TColor;
function GetDIBPalEntryCount: Integer;
procedure SetDIBPalEntries(Idx: Integer; const Value: TColor);
procedure SetHandleType(const Value: TBitmapHandleType);
function GetPixelFormat: TPixelFormat;
function GetPixels(X, Y: Integer): TColor;
procedure SetPixels(X, Y: Integer; const Value: TColor);
function GetDIBPixels(X, Y: Integer): TColor;
procedure SetDIBPixels(X, Y: Integer; const Value: TColor);
function GetBoundsRect: TRect;
protected
{++}(*public*){--}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
public
property Width: Integer read fWidth write SetWidth;
{* Width of bitmap. To make code smaller, avoid changing Width or Height
after bitmap is created (using NewBitmap) or after it is loaded from
file, stream of resource. }
property Height: Integer read fHeight write SetHeight;
{* Height of bitmap. To make code smaller, avoid changing Width or Height
after bitmap is created (using NewBitmap) or after it is loaded from
file, stream of resource. }
property BoundsRect: TRect read GetBoundsRect;
{* Returns rectangle (0,0,Width,Height). }
property Empty: Boolean read GetEmpty;
{* Returns True if Width or Height is 0. }
procedure Clear;
{* Makes bitmap empty, setting its Width and Height to 0. }
procedure LoadFromFile( const Filename: KOLString );
{* Loads bitmap from file (LoadFromStream used). }
function LoadFromFileEx( const Filename: KOLString ): Boolean;
{* Loads bitmap from a file. If necessary, bitmap is RLE-decoded. Code given
by Vyacheslav A. Gavrik. }
procedure SaveToFile( const Filename: KOLString );
{* Stores bitmap to file (SaveToStream used). }
procedure LoadFromStream( Strm: PStream );
{* Loads bitmap from stream. Follow loading, bitmap has DIB format (without
handle allocated). It is possible to draw DIB bitmap without creating
handle for it, which can economy GDI resources. }
function LoadFromStreamEx( Strm: PStream ): Boolean;
{* Loads bitmap from a stream. Difference is that RLE decoding supported.
Code given by Vyacheslav A. Gavrik. }
procedure SaveToStream( Strm: PStream );
{* Saves bitmap to stream. If bitmap is not DIB, it is converted to DIB
before saving. }
procedure LoadFromResourceID( Inst: DWORD; ResID: Integer );
{* Loads bitmap from resource using integer ID of resource. To load by name,
use LoadFromResurceName. To load resource of application itself, pass
hInstance as first parameter. This method also can be used to load system
predefined bitmaps, if 0 is passed as Inst parameter:
|
OBM_BTNCORNERS OBM_REDUCE
OBM_BTSIZE OBM_REDUCED
OBM_CHECK OBM_RESTORE
OBM_CHECKBOXES OBM_RESTORED
OBM_CLOSE OBM_RGARROW
OBM_COMBO OBM_RGARROWD
OBM_DNARROW OBM_RGARROWI
OBM_DNARROWD OBM_SIZE
OBM_DNARROWI OBM_UPARROW
OBM_LFARROW OBM_UPARROWD
OBM_LFARROWD OBM_UPARROWI
OBM_LFARROWI OBM_ZOOM
OBM_MNARROW OBM_ZOOMD
| }
procedure LoadFromResourceName( Inst: DWORD; ResName: PKOLChar );
{* Loads bitmap from resurce (using passed name of bitmap resource. }
function Assign( SrcBmp: PBitmap ): Boolean;
{* Assigns bitmap from another. Returns False if not success.
Note: remember, that Canvas is not assigned - only bitmap image
is copied. And for DIB, handle is not allocating due this process. }
property Handle: HBitmap read GetHandle write SetHandle;
{* Handle of bitmap. Created whenever property accessed. To check if handle
is allocated (without allocating it), use HandleAllocated property. }
property HandleAllocated: Boolean read GetHandleAllocated;
{* Returns True, if Handle already allocated. }
function ReleaseHandle: HBitmap;
{* Returns Handle and releases it, so bitmap no more know about handle.
This method does not destroy bitmap image, but converts it into DIB.
Returned Handle actually is a handle of copy of original bitmap. If
You need not in keping it up, use Dormant method instead. }
procedure Dormant;
{* Releases handle from bitmap and destroys it. But image is not destroyed
and its data are preserved in DIB format. Please note, that in KOL, DIB
bitmaps can be drawn onto given device context without allocating of
handle. So, it is very useful to call Dormant preparing it using
Canvas drawing operations - to economy GDI resources. }
property HandleType: TBitmapHandleType read fHandleType write SetHandleType;
{* bmDIB, if DIB part of image data is filled and stored internally in
TBitmap object. DIB image therefore can have Handle allocated, which
require resources. Use HandleAllocated funtion to determine if handle
is allocated and Dormant method to remove it, if You want to economy
GDI resources. (Actually Handle needed for DIB bitmap only in case
when Canvas is used to draw on bitmap surface). Please note also, that
before saving bitmap to file or stream, it is converted to DIB. }
property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
{* Current pixel format. If format of bitmap is unknown, or bitmap is DDB,
value is pfDevice. Setting PixelFormat to any other format converts
bitmap to DIB, back to pfDevice converts bitmap to DDB again. Avoid
such conversations for large bitmaps or for numerous bitmaps in your
application to keep good performance. }
function BitsPerPixel: Integer;
{* Returns bits per pixel if possible. }
procedure Draw( DC: HDC; X, Y: Integer );
{* Draws bitmap to given device context. If bitmap is DIB, it is always
drawing using SetDIBitsToDevice API call, which does not require bitmap
handle (so, it is very sensible to call Dormant method to free correspondent
GDI resources). }
procedure StretchDraw( DC: HDC; const Rect: TRect );
{* Draws bitmap onto DC, stretching it to fit given rectangle Rect. }
procedure DrawTransparent( DC: HDC; X, Y: Integer; TranspColor: TColor );
{* Draws bitmap onto DC transparently, using TranspColor as transparent.
See function DesktopPixelFormat also. }
procedure StretchDrawTransparent( DC: HDC; const Rect: TRect; TranspColor: TColor );
{* Draws bitmap onto given rectangle of destination DC (with stretching it
to fit Rect) - transparently, using TranspColor as transparent.
See function DesktopPixelFormat also. }
procedure DrawMasked( DC: HDC; X, Y: Integer; Mask: HBitmap );
{* Draws bitmap to destination DC transparently by mask. It is possible
to pass as a mask handle of another TBitmap, previously converted to
monochrome mask using Convert2Mask method. }
procedure StretchDrawMasked( DC: HDC; const Rect: TRect; Mask: HBitmap );
{* Like DrawMasked, but with stretching image onto given rectangle. }
procedure Convert2Mask( TranspColor: TColor );
{* Converts bitmap to monochrome (mask) bitmap with TranspColor replaced
to clBlack and all other ones to clWhite. Such mask bitmap can be used
to draw original bitmap transparently, with given TranspColor as
transparent. (To preserve original bitmap, create new instance of
TBitmap and assign original bitmap to it). See also DrawTransparent and
StretchDrawTransparent methods. }
procedure Invert;
{* Obvious. }
property Canvas: PCanvas read GetCanvas;
{* Canvas can be used to draw onto bitmap. Whenever it is accessed, handle
is allocated for bitmap, if it is not yet (to make it possible
to select bitmap to display compatible device context). }
procedure RemoveCanvas;
{* Call this method to destroy Canvas and free GDI resources. }
property BkColor: TColor read fBkColor write SetBkColor;
{* Used to fill background for Bitmap, when its width or height is increased.
Although this value always synchronized with Canvas.Brush.Color, use it
instead if You do not use Canvas for drawing on bitmap surface. }
property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels;
{* Allows to obtain or change certain pixels of a bitmap. This method is
both for DIB and DDB bitmaps, and leads to allocate handle anyway. For
DIB bitmaps, it is possible to use property DIBPixels[ ] instead,
which is much faster and does not require in Handle. }
property ScanLineSize: Integer read GetScanLineSize;
{* Returns size of scan line in bytes. Use it to measure size of a single
ScanLine. To calculate increment value from first byte of ScanLine to
first byte of next ScanLine, use difference
! Integer(ScanLine[1]-ScanLine[0])
(this is because bitmap can be oriented from bottom to top, so
step can be negative). }
property ScanLine[ Y: Integer ]: Pointer read GetScanLine;
{* Use ScanLine to access DIB bitmap pixels in memory to direct access it
fast. Take in attention, that for different pixel formats, different
bit counts are used to represent bitmap pixels. Also do not forget, that
for formats pf4bit and pf8bit, pixels actually are indices to palette
entries, and for formats pf16bit, pf24bit and pf32bit are actually
RGB values (for pf16bit B:5-G:6-R:5, for pf15bit B:5-G:5-R:5 (high order
bit not used), for pf24bit B:8-G:8-R:8, and for pf32bit high order byte
of TRGBQuad structure is not used). }
property DIBPixels[ X, Y: Integer ]: TColor read GetDIBPixels write SetDIBPixels;
{* Allows direct access to pixels of DIB bitmap, faster then Pixels[ ]
property. Access to read is slower for pf15bit, pf16bit formats (because
some conversation needed to translate packed RGB color to TColor). And
for write, operation performed most slower for pf4bit, pf8bit (searching
nearest color required) and fastest for pf24bit, pf32bit and pf1bit. }
property DIBPalEntryCount: Integer read GetDIBPalEntryCount;
{* Returns palette entries count for DIB image. Always returns 2 for pf1bit,
16 for pf4bit, 256 for pf8bit and 0 for other pixel formats. }
property DIBPalEntries[ Idx: Integer ]: TColor read GetDIBPalEntries write
SetDIBPalEntries;
{* Provides direct access to DIB palette. }
function DIBPalNearestEntry( Color: TColor ): Integer;
{* Returns index of entry in DIB palette with color nearest (or matching)
to given one. }
property DIBBits: Pointer read fDIBBits;
{* This property is mainly for internal use. }
property DIBSize: Integer read fDIBSize;
{* Size of DIBBits array. }
property DIBHeader: PBitmapInfo read fDIBHeader;
{* This property is mainly for internal use. }
procedure DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect );
{* This procedure copies given rectangle to the target device context,
but only for DIB bitmap (using SetDIBBitsToDevice API call). }
procedure RotateRight;
{* Rotates bitmap right (90 degree). Bitmap must be DIB. If You definitevely
know format of a bitmap, use instead one of methods RotateRightMono,
RotateRight4bit, RotateRight8bit, RotateRight16bit or RotateRightTrueColor
- this will economy code. But if for most of formats such methods are
called, this can be more economy just to call always universal method
RotateRight. }
procedure RotateLeft;
{* Rotates bitmap left (90 degree). Bitmap must be DIB. If You definitevely
know format of a bitmap, use instead one of methods RotateLeftMono,
RotateLeft4bit, RotateLeft8bit, RotateLeft16bit or RotateLeftTrueColor
- this will economy code. But if for most of formats such methods are
called, this can be more economy just to call always universal method
RotateLeft. }
procedure RotateRightMono;
{* Rotates bitmat right, but only if bitmap is monochrome (pf1bit). }
procedure RotateLeftMono;
{* Rotates bitmap left, but only if bitmap is monochrome (pf1bit). }
procedure RotateRight4bit;
{* Rotates bitmap right, but only if PixelFormat is pf4bit. }
procedure RotateLeft4bit;
{* Rotates bitmap left, but only if PixelFormat is pf4bit. }
procedure RotateRight8bit;
{* Rotates bitmap right, but only if PixelFormat is pf8bit. }
procedure RotateLeft8bit;
{* Rotates bitmap left, but only if PixelFormat is pf8bit. }
procedure RotateRight16bit;
{* Rotates bitmap right, but only if PixelFormat is pf16bit. }
procedure RotateLeft16bit;
{* Rotates bitmap left, but only if PixelFormat is pf16bit. }
procedure RotateRightTrueColor;
{* Rotates bitmap right, but only if PixelFormat is pf24bit or pf32bit. }
procedure RotateLeftTrueColor;
{* Rotates bitmap left, but only if PixelFormat is pf24bit or pf32bit. }
procedure FlipVertical;
{* Flips bitmap vertically }
procedure FlipHorizontal;
{* Flips bitmap horizontally }
procedure CopyRect( const DstRect : TRect; SrcBmp : PBitmap; const SrcRect : TRect );
{* It is possible to use Canvas.CopyRect for such purpose, but if You
do not want use TCanvas, it is possible to copy rectangle from one
bitmap to another using this function. }
function CopyToClipboard: Boolean;
{* Copies bitmap to clipboard. }
function PasteFromClipboard: Boolean;
{* Takes CF_DIB format bitmap from clipboard and assigns it to the
TBitmap object. }
end;
//[END OF TBitmap DEFINITION]
//
function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;
//[NewBitmap DECLARATION]
function NewBitmap( W, H: Integer ): PBitmap;
{* Creates bitmap object of given size. If it is possible, do not change its
size (Width and Heigth) later - this can economy code a bit. See TBitmap. }
function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;
{* Creates DIB bitmap object of given size and pixel format. If it is possible,
do not change its size (Width and Heigth) later - this can economy code a bit.
See TBitmap. }
//[CalcScanLineSize DECLARATION]
function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;
{* May be will be useful. }
//[DefaultPixelFormat VARIABLE]
var
//DefaultBitsPerPixel: Integer = 16;
DefaultPixelFormat: TPixelFormat = pf16bit;
//[Mapped bitmaps]
{ -- Function to load bitmap mapping some its colors. -- }
function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor )
: HBitmap;
{* This function can be used to load bitmap and replace some it colors to
desired ones. This function especially useful when loaded by the such way
bitmap is used as toolbar bitmap - to replace some original colors to
system default colors. To use this function properly, the bitmap shoud
be prepared as 16-color bitmap, which uses only system colors. To do so,
create a new 16-color bitmap with needed dimensions in Borland Image Editor
and paste a bitmap image, copyed in another graphic tool, and then save it.
If this is not done, bitmap will not be loaded correctly! }
function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PKOLChar;
const Map: array of TColor ): HBitmap;
{* by Alex Pravdin: like LoadMappedBitmap, but much powerful. It uses
CreateMappedBitmapEx, so it understands any bitmap color format, including
pf24bit. Also, LoadMappedBitmapEx provides auto-destroying loaded resource
when MasterObj is destroyed. }
function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;
Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Creates mapped bitmap replacing colors correspondently to the
ColorMap (each pare of colors defines color replaced and a color
used for replace it in the bitmap). See also CreateMappedBitmapEx. }
function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PKOLChar; Flags:
Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap;
{* By Alex Pravdin.
Creates mapped bitmap independently from bitmap color format (works
correctly with bitmaps having format deeper than 8bit per pixel). }
//[ICONS]
type
{++}(*TIcon = class;*){--}
PIcon = {-}^{+}TIcon;
{ ----------------------------------------------------------------------
TIcon - icon image
----------------------------------------------------------------------- }
//[TIcon DEFINITION]
TIcon = object( TObj )
{* Object type to incapsulate icon or cursor image. }
protected
{$IFDEF ICON_DIFF_WH}
FWidth: Integer;
FHeight: Integer;
{$ELSE}
FSize : Integer;
{$ENDIF}
FHandle: HIcon;
FShareIcon: Boolean;
procedure SetSize(const Value: Integer);
{$IFDEF ICON_DIFF_WH}
function GetIconSize: Integer;
{$ENDIF}
procedure SetHandle(const Value: HIcon);
function GetHotSpot: TPoint;
function GetEmpty: Boolean;
protected
{++}(*public*){--}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
public
{$IFDEF ICONLOAD_PRESERVEBMPS}
ImgBmp, MskBmp : PBitmap;
Only_Bmp: Boolean;
{$ENDIF ICONLOAD_PRESERVEBMPS}
property Size : Integer read
{$IFDEF ICON_DIFF_WH}
GetIconSize
{$ELSE}
FSize
{$ENDIF}
write SetSize;
{* Icon dimension (width and/or height, which are equal to each other always). }
{$IFDEF ICON_DIFF_WH}
property Width: Integer read FWidth;
property Height: Integer read FHeight;
{$ENDIF}
property Handle : HIcon read FHandle write SetHandle;
{* Windows icon object handle. }
procedure Clear;
{* Clears icon, freeing image and allocated GDI resource (Handle). }
property Empty: Boolean read GetEmpty;
{* Returns True if icon is Empty. }
property ShareIcon : Boolean read FShareIcon write FShareIcon;
{* True, if icon object is shared and can not be deleted when TIcon object
is destroyed (set this flag is to True, if an icon is obtained from another
TIcon object, for example). }
property HotSpot : TPoint read GetHotSpot;
{* Hot spot point - for cursors. }
procedure Draw( DC : HDC; X, Y : Integer );
{* Draws icon onto given device context. Icon always is drawn transparently
using its transparency mask (stored internally in icon object). }
procedure StretchDraw( DC : HDC; Dest : TRect );
{* Draws icon onto given device context with stretching it to fit destination
rectangle. See also Draw. }
procedure LoadFromStream( Strm : PStream );
{* Loads icon from stream. If stream contains several icons (of
different dimentions), icon with the most appropriate size is loading. }
procedure LoadFromFile( const FileName : KOLString );
{* Load icon from file. If file contains several icons (of
different dimensions), icon with the most appropriate size is loading. }
procedure LoadFromResourceID( Inst: Integer; ResID: Integer; DesiredSize: Integer );
{* Loads icon from resource. To load system default icon, pass 0 as Inst and
one of followin values as ResID:
|
IDI_APPLICATION Default application icon.
IDI_ASTERISK Asterisk (used in informative messages).
IDI_EXCLAMATION Exclamation point (used in warning messages).
IDI_HAND Hand-shaped icon (used in serious warning messages).
IDI_QUESTION Question mark (used in prompting messages).
IDI_WINLOGO Windows logo.
| It is also possible to load icon from resources of another module,
if pass instance handle of loaded module as Inst parameter. }
procedure LoadFromResourceName( Inst: Integer; ResName: PKOLChar; DesiredSize: Integer );
{* Loads icon from resource. To load own application resource, pass
hInstance as Inst parameter. It is possible to load resource from
another module, if pass its instance handle as Inst. }
procedure LoadFromExecutable( const FileName: KOLString; IconIdx: Integer );
{* Loads icon from executable (exe or dll file). Always default sized icon
is loaded. It is possible also to get know how much icons are contained
in executable using gloabl function GetFileIconCount. To obtain icon of
another size, try to load given executable and use LoadFromResourceID
method. }
{$ifdef win32}
procedure SaveToStream( Strm : PStream );
{* Saves single icon to stream. To save icons with several different
dimensions, use global procedure SaveIcons2Stream. }
procedure SaveToFile( const FileName : KOLString );
{* Saves single icon to file. To save icons with several different
dimensions, use global procedure SaveIcons2File. }
{$endif win32}
function Convert2Bitmap( TranColor: TColor ): HBitmap;
{* Converts icon to bitmap, returning Windows GDI bitmap resource as
a result. It is possible later to assign returned bitmap handle to
Handle property of TBitmap object to use features of TBitmap.
Pass TranColor to replace transparent area of icon with given color. }
end;
//[END OF TIcon DEFINITION]
//[Icon save functions]
{$ifdef win32}
procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream );
{* Saves several icons (of different dimentions) to stream. }
function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean;
{* Saves icons creating it from pairs of bitmaps and their masks.
BmpHandles array must contain pairs of bitmap handles, each pair
of color bitmap and mask bitmap of the same size. }
procedure SaveIcons2File( const Icons : array of PIcon; const FileName : KOLString );
{* Saves several icons (of different dimentions) to file. (Single file
with extension .ico can contain several different sized icon images
to use later one with the most appropriate size). }
{$endif win32}
//[NewIcon DECLARATION]
function NewIcon: PIcon;
{* Creates new icon object, setting its Size to 32 by default. Created icon
is Empty. }
//[GetFileIconCount DECLARATION]
function GetFileIconCount( const FileName: KOLString ): Integer;
{* Returns number of icon resources stored in given (executable) file. }
//[ICON STRUCTURES]
type
TIconHeader = packed record
idReserved: Word; (* Always set to 0 *)
idType: Word; (* Always set to 1 *)
idCount: Word; (* Number of icon images *)
(* immediately followed by idCount TIconDirEntries *)
end;
TIconDirEntry = packed record
bWidth: Byte; (* Width *)
bHeight: Byte; (* Height *)
bColorCount: Byte; (* Nr. of colors used *)
bReserved: Byte; (* not used, 0 *)
wPlanes: Word; (* not used, 0 *)
wBitCount: Word; (* not used, 0 *)
dwBytesInRes: Longint; (* total number of bytes in images *)
dwImageOffset: Longint;(* location of image from the beginning of file *)
end;
//[LoadImgIcon DECLARATION]
function LoadImgIcon( RsrcName: PKOLChar; Size: Integer ): HIcon;
{* Loads icon of specified size from the resource. }
////////////////////////////////////////////////////////////////////////////////
// UNIVERSAL CONTROL OBJECT //
////////////////////////////////////////////////////////////////////////////////
//[CM_XXX CONSTANTS]
const
CM_EXECPROC = $8FFF;
CM_BASE = $B000;
CM_ACTIVATE = CM_BASE + 0;
CM_DEACTIVATE = CM_BASE + 1;
CM_ENTER = CM_BASE + 2;
CM_RELEASE = CM_BASE + 3;
CM_QUIT = CM_BASE + 4;
CM_COMMAND = CM_BASE + 5;
CM_MEASUREITEM = CM_BASE + 6;
CM_DRAWITEM = CM_BASE + 7;
CM_TRAYICON = CM_BASE + 8;
CM_INVALIDATE = CM_BASE + 9;
CM_UPDATE = CM_BASE + 10;
CM_NCUPDATE = CM_BASE + 11;
CM_SIZEPOS = CM_BASE + 12;
CM_SIZE = CM_BASE + 13;
CM_SETFOCUS = CM_BASE + 14;
CM_CBN_SELCHANGE = 15;
CM_UIACTIVATE = CM_BASE + 16;
CM_UIDEACTIVATE = CM_BASE + 17;
CM_PROCESS = CM_BASE + 18;
CM_SHOW = CM_BASE + 19;
CM_AUTOSIZE = CM_BASE + 20;
CM_MDIClientShowEdge = CM_BASE + 21;
CM_INVALIDATECHILD = CM_BASE + 22;
CM_FOCUSGRAPHCTL = CM_BASE + 23;
WM_SYNCPAINT = $88;
//[CN_XXX CONSTANTS]
CN_BASE = $BC00;
CN_CHARTOITEM = CN_BASE + WM_CHARTOITEM;
CN_COMMAND = CN_BASE + WM_COMMAND;
CN_COMPAREITEM = CN_BASE + WM_COMPAREITEM;
CN_CTLCOLORMSGBOX = CN_BASE + WM_CTLCOLORMSGBOX;
CN_CTLCOLOREDIT = CN_BASE + WM_CTLCOLOREDIT;
CN_CTLCOLORLISTBOX = CN_BASE + WM_CTLCOLORLISTBOX;
CN_CTLCOLORBTN = CN_BASE + WM_CTLCOLORBTN;
CN_CTLCOLORDLG = CN_BASE + WM_CTLCOLORDLG;
CN_CTLCOLORSCROLLBAR = CN_BASE + WM_CTLCOLORSCROLLBAR;
CN_CTLCOLORSTATIC = CN_BASE + WM_CTLCOLORSTATIC;
CN_DELETEITEM = CN_BASE + WM_DELETEITEM;
CN_DRAWITEM = CN_BASE + WM_DRAWITEM;
CN_HSCROLL = CN_BASE + WM_HSCROLL;
CN_MEASUREITEM = CN_BASE + WM_MEASUREITEM;
CN_PARENTNOTIFY = CN_BASE + WM_PARENTNOTIFY;
CN_VKEYTOITEM = CN_BASE + WM_VKEYTOITEM;
CN_VSCROLL = CN_BASE + WM_VSCROLL;
CN_KEYDOWN = CN_BASE + WM_KEYDOWN;
CN_KEYUP = CN_BASE + WM_KEYUP;
CN_CHAR = CN_BASE + WM_CHAR;
CN_SYSKEYDOWN = CN_BASE + WM_SYSKEYDOWN;
CN_SYSCHAR = CN_BASE + WM_SYSCHAR;
CN_NOTIFY = CN_BASE + WM_NOTIFY;
{$ENDIF WIN_GDI}
//[ID_SELF DEFINED]
const
ID_SELF: array[ 0..5 ] of KOLChar = ( 'S','E','L','F','_',#0 );
{* Identifier for window property "Self", stored directly in window, when
it is created. This property is used to [fast] find TControl object,
correspondent to given window handle (using API call GetProp). }
{$IFDEF WIN_GDI}
//[ID_PREVPROC DEFINED]
ID_PREVPROC: array[ 0..9 ] of KOLChar = ( 'P','R','E','V','_','P','R','O','C',#0 );
{* }
{$ENDIF WIN_GDI}
//[MK_ALT DEFINED]
const
MK_LBUTTON = 1;
MK_RBUTTON = 2;
MK_SHIFT = 4;
MK_CONTROL = 8;
MK_MBUTTON = $10;
MK_ALT = $20;
MK_LOCK = $40; // CAPS LOCK or SHIFT LOCK
{$IFDEF WIN_GDI}
{$IFNDEF NOT_USE_RICHEDIT}
//[RICHEDIT STRUCTURES]
type
TCharFormat2 = {$ifndef wince}packed{$endif} record
cbSize: UINT;
dwMask: DWORD;
dwEffects: DWORD;
yHeight: Longint;
yOffset: Longint;
crTextColor: TColorRef;
bCharSet: Byte;
bPitchAndFamily: Byte;
szFaceName: array[0..LF_FACESIZE - 1] of KOLChar;
R2Bytes: Word;
wWeight: Word; { Font weight (LOGFONT value) }
sSpacing: Smallint; { Amount to space between letters }
crBackColor: TColorRef; { Background color }
lid: LCID; { Locale ID }
dwReserved: DWORD; { Reserved. Must be 0 }
sStyle: Smallint; { Style handle }
wKerning: Word; { Twip size above which to kern char pair }
bUnderlineType: Byte; { Underline type }
bAnimation: Byte; { Animated text like marching ants }
bRevAuthor: Byte; { Revision author index }
bReserved1: Byte;
end;
//TCharFormat2 = TCharFormat2A;
TParaFormat2 = {$ifndef wince}packed{$endif} record
cbSize: UINT;
dwMask: DWORD;
wNumbering: Word;
wReserved: Word;
dxStartIndent: Longint;
dxRightIndent: Longint;
dxOffset: Longint;
wAlignment: Word;
cTabCount: Smallint;
rgxTabs: array [0..MAX_TAB_STOPS - 1] of Longint;
dySpaceBefore: Longint; { Vertical spacing before para }
dySpaceAfter: Longint; { Vertical spacing after para }
dyLineSpacing: Longint; { Line spacing depending on Rule }
sStyle: Smallint; { Style handle }
bLineSpacingRule: Byte; { Rule for line spacing (see tom.doc) }
bCRC: Byte; { Reserved for CRC for rapid searching }
wShadingWeight: Word; { Shading in hundredths of a per cent }
wShadingStyle: Word; { Nibble 0: style, 1: cfpat, 2: cbpat }
wNumberingStart: Word; { Starting value for numbering }
wNumberingStyle: Word; { Alignment, roman/arabic, (), ), ., etc. }
wNumberingTab: Word; { Space bet 1st indent and 1st-line text }
wBorderSpace: Word; { Space between border and text (twips) }
wBorderWidth: Word; { Border pen width (twips) }
wBorders: Word; { Byte 0: bits specify which borders }
{ Nibble 2: border style, 3: color index }
end;
TGetTextLengthEx = {$ifndef wince}packed{$endif} record
flags: DWORD; { flags (see GTL_XXX defines) }
codepage: UINT; { code page for translation (CP_ACP for default,
1200 for Unicode }
end;
const
PFM_SPACEBEFORE = $00000040;
PFM_SPACEAFTER = $00000080;
PFM_LINESPACING = $00000100;
PFM_STYLE = $00000400;
PFM_BORDER = $00000800; { (*) }
PFM_SHADING = $00001000; { (*) }
PFM_NUMBERINGSTYLE = $00002000; { (*) }
PFM_NUMBERINGTAB = $00004000; { (*) }
PFM_NUMBERINGSTART = $00008000; { (*) }
PFM_RTLPARA = $00010000;
PFM_KEEP = $00020000; { (*) }
PFM_KEEPNEXT = $00040000; { (*) }
PFM_PAGEBREAKBEFORE = $00080000; { (*) }
PFM_NOLINENUMBER = $00100000; { (*) }
PFM_NOWIDOWCONTROL = $00200000; { (*) }
PFM_DONOTHYPHEN = $00400000; { (*) }
PFM_SIDEBYSIDE = $00800000; { (*) }
PFM_TABLE = $c0000000; { (*) }
EM_REDO = WM_USER + 84;
EM_AUTOURLDETECT = WM_USER + 91;
EM_GETAUTOURLDETECT = WM_USER + 92;
CFM_UNDERLINETYPE = $00800000; { (*) }
CFM_HIDDEN = $0100; { (*) }
CFM_BACKCOLOR = $04000000;
CFE_AUTOBACKCOLOR = CFM_BACKCOLOR;
GTL_USECRLF = 1; { compute answer using CRLFs for paragraphs }
GTL_PRECISE = 2; { compute a precise answer }
GTL_CLOSE = 4; { fast computation of a "close" answer }
GTL_NUMCHARS = 8; { return the number of characters }
GTL_NUMBYTES = 16; { return the number of _bytes_ }
EM_GETTEXTLENGTHEX = WM_USER + 95;
EM_SETLANGOPTIONS = WM_USER + 120;
EM_GETLANGOPTIONS = WM_USER + 121;
EM_SETEDITSTYLE = $400 + 204;
EM_GETEDITSTYLE = $400 + 205;
SES_EMULATESYSEDIT = 1;
SES_BEEPONMAXTEXT = 2;
SES_EXTENDBACKCOLOR = 4;
SES_MAPCPS = 8;
SES_EMULATE10 = 16;
SES_USECRLF = 32;
SES_USEAIMM = 64;
SES_NOIME = 128;
SES_ALLOWBEEPS = 256;
SES_UPPERCASE = 512;
SES_LOWERCASE = 1024;
SES_NOINPUTSEQUENCECHK = 2048;
SES_BIDI = 4096;
SES_SCROLLONKILLFOCUS = 8192;
SES_XLTCRCRLFTOCR = 16384;
EM_GETSCROLLPOS = WM_USER + 221;
EM_SETSCROLLPOS = WM_USER + 222;
EM_GETZOOM = WM_USER + 224;
EM_SETZOOM = WM_USER + 225;
{$ENDIF NOT_USE_RICHEDIT}
{$ENDIF WIN_GDI}
//[CONTROLS]
type
{++}(*TControl = class;*){--}
PControl = {-}^{+}TControl;
{* Type of pointer to TControl visual object. All
|
constructing functions
|
New[ControlName] are returning
pointer of this type. Do not forget about some difference
of using objects from using classes. Identifier Self for
methods of object is not of pointer type, and to pass
pointer to Self, it is necessary to pass @Self instead.
At the same time, to use pointer to object in 'WITH' operator,
it is necessary to apply suffix '^' to pointer to get know
to compiler, what do You want. }
{$IFDEF WIN}
//[TWindowFunc TYPE]
TWindowFunc = function( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
{$ENDIF WIN}
{* Event type to define custom extended message handlers (as pointers to
procedure entry points). Such handlers are usually defined like add-ons,
extending behaviour of certain controls and attached using AttachProc
method of TControl. If the handler detects, that it is necessary to stop
further message processing, it should return True. }
//[Mouse TYPES]
TMouseButton = ( mbNone, mbLeft, mbRight, mbMiddle );
{* Available mouse buttons. mbNone is useful to get know, that
there were no mouse buttons pressed. }
TMouseEventData = {$ifndef wince}packed{$endif} Record
{* Record to pass it to mouse handling routines, assigned to OnMouseXXXX
events. }
Button: TMouseButton;
StopHandling: Boolean; // Set it to True in OnMouseXXXX event handler to
// stop further processing
R1, R2: Byte; // Not used
Shift : DWORD; // HiWord( Shift ) = zDelta in WM_MOUSEWHEEL
X, Y : SmallInt;
end;
TOnMouse = procedure( Sender: PControl; var Mouse: TMouseEventData ) of object;
{* Common mouse handling event type. }
//[Key TYPES]
TOnKey = procedure( Sender: PControl; var Key: Longint; Shift: DWORD ) of object;
{* Key events. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT.
(See GetShiftState funtion). }
TOnChar = procedure( Sender: PControl; var Key: KOLChar; Shift: DWORD ) of object;
{* Char event. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT. }
TTabKey = ( tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn );
{* Available tabulating key groups. }
TTabKeys = Set of TTabKey;
{* Set of tabulating key groups, allowed to be used in with a control
(are installed by TControl.LookTabKey property). }
//[Event TYPES]
{$IFDEF WIN}
TOnMessage = function( var Msg: TMsg; var Rslt: Integer ): Boolean of object;
{* Event type for events, which allows to extend behaviour of windowed controls
descendants using add-ons. }
{$ENDIF WIN}
TOnEventAccept = procedure( Sender: PObj; var Accept: Boolean ) of object;
{* Event type for OnClose event. }
TCloseQueryReason = ( qClose, qShutdown, qLogoff );
{* Request reason type to call OnClose and OnQueryEndSession. }
TWindowState = ( wsNormal, wsMinimized, wsMaximized );
{* Avalable states of TControl's window object. }
TOnSplit = function( Sender: PControl; NewSize1, NewSize2: Integer ): Boolean of object;
{* Event type for OnSplit event handler, designed specially for splitter
control. Event handler must return True to accept new size of previous
(to splitter) control and new size of the rest of client area of parent. }
TOnTVBeginDrag = procedure( Sender: PControl; Item: THandle ) of object;
{* Event type for OnTVBeginDrag event (defined for tree view control). }
TOnTVBeginEdit = function( Sender: PControl; Item: THandle ): Boolean of object;
{* Event type for OnTVBeginEdit event (for tree view control). }
TOnTVEndEdit = function( Sender: PControl; Item: THandle; const NewTxt: KOL_String )
: Boolean of object;
{* Event type for TOnTVEndEdit event. }
TOnTVExpanding = function( Sender: PControl; Item: THandle; Expand: Boolean )
: Boolean of object;
{* Event type for TOnTVExpanding event. }
TOnTVExpanded = procedure( Sender: PControl; Item: THandle; Expand: Boolean )
of object;
{* Event type for OnTVExpanded event. }
TOnTVDelete = procedure( Sender: PControl; Item: THandle ) of object;
{* Event type for OnTVDelete event. }
//--------- by Sergey Shisminzev:
TOnTVSelChanging = function(Sender: PControl; oldItem, newItem: THandle): Boolean //~ss
of object;
{* When the handler returns False, selection is not changed. }
//-------------------------------
TOnDrag = function( Sender: PControl; ScrX, ScrY: Integer; var CursorShape: Integer;
var Stop: Boolean ): Boolean of object;
{* Event, called during dragging operation (it is initiated
with method Drag, where callback function of type TOnDrag is
passed as a parameter). Callback function receives Stop parameter True,
when operation is finishing. Otherwise, it can set it to True to force
finishing the operation (in such case, returning False means cancelling
drag operation, True - successful drag and in this last case callback is
no more called). During the operation, when input Stop value is False,
callback function can control Cursor shape, and return True, if the operation
can be finished successfully at the given ScrX, ScrY position.
ScrX, ScrY are screen coordinates of the mouse cursor. }
{$IFDEF WIN}
//[Create Window STRUCTURES]
TCreateParams = {$ifndef wince}packed{$endif} record
{* Record to pass it through CreateSubClass method. }
Caption: PKOLChar;
Style: cardinal;
ExStyle: cardinal;
X, Y: Integer;
Width, Height: Integer;
WndParent: HWnd;
Param: Pointer;
WindowClass: TWndClass;
WinClassName: array[0..63] of KOLChar;
end;
TCreateWndParams = {$ifndef wince}packed{$endif} Record
ExStyle: DWORD;
WinClassName: PKOLChar;
Caption: PKOLChar;
Style: DWORD;
X, Y, Width, Height: Integer;
WndParent: HWnd;
Menu: HMenu;
Inst: THandle;
Param: Pointer;
WinClsNamBuf: array[ 0..63 ] of KOLChar;
WindowClass: TWndClass;
end;
//[COMMAND ACTIONS TYPE FOR DIFFERENT CONTROLS]
PCommandActions = ^TCommandActions;
TCommandActions = {$ifndef wince}packed{$endif} Record
aClear: procedure( Sender: PControl );
aAddText: procedure( Sender: PControl; const S: String );
aClick, aEnter, aLeave: WORD; aChange: SmallInt; aSelChange: SmallInt;
aGetCount, aSetCount, aGetItemLength, aGetItemText, aSetItemText,
aGetItemData, aSetItemData: WORD;
aAddItem, aDeleteItem, aInsertItem: WORD;
aFindItem, aFindPartial: WORD;
aItem2Pos, aPos2Item: BYTE;
{aGetSelStart,} aGetSelCount, aGetSelected, aGetSelRange,
{aExGetSelRange,} aGetCurrent,
aSetSelected, aSetCurrent, aSetSelRange, aExSetSelRange,
aGetSelection, aReplaceSel: WORD;
aTextAlignLeft, aTextAlignRight, aTextAlignCenter: WORD;
aTextAlignMask: Byte;
aVertAlignCenter, aVertAlignTop, aVertAlignBottom: Byte;
aDir, aSetLimit: Word; aSetImgList: Word;
aAutoSzX, aAutoSzY: Word;
aSetBkColor: Word;
aItem2XY: Word;
end;
{$ENDIF WIN}
//[Align TYPES]
TTextAlign = ( taLeft, taRight, taCenter );
{* Text alignments available. }
TRichTextAlign = ( raLeft, raRight, raCenter,
// all other are only set but can not be displayed:
raJustify, // displayed like raLeft (though stored normally)
raInterLetter, raScaled, raGlyphs, raSnapGrid );
{* Text alignment styles, available for RichEdit control. }
TVerticalAlign = ( vaCenter, vaTop, vaBottom );
{* Vertical alignments available. }
TControlAlign = ( caNone, caLeft, caTop, caRight, caBottom, caClient );
{* Control alignments available. }
TAligning = (oaWaitAlign,oaFromSelf,oaAligning);
TAlignings = set of TAligning;
//[BitBtn TYPES]
TBitBtnOption = ( bboImageList,
bboNoBorder,
bboNoCaption,
bboFixed,
bboFocusRect );
{* Options available for NewBitBtn. }
TBitBtnOptions = set of TBitBtnOption;
{* Set of options, available for NewBitBtn. }
TGlyphLayout = ( glyphLeft, glyphTop, glyphRight, glyphBottom, glyphOver );
{* Layout of glyph (for NewBitBtn). Layout glyphOver means that text is
drawn over glyph. }
TOnBitBtnDraw = function( Sender: PControl; BtnState: Integer ): Boolean of object;
{* Event type for TControl.OnBitBtnDraw event (which is called just before
drawing the BitBtn). If handler returns True, there are no drawing occure.
BtnState, passed to a handler, determines current button state and can
be following: 0 - not pressed, 1 - disabled, 2 - pressed, 3 - focused.
Value 4 is reserved for highlight state (then mouse is over it), but
highlighting is provided only if property Flat is set to True (or one
of events OnMouseEnter / OnMouseLeave is assigned to something). }
//[ListView TYPES]
TListViewStyle = ( lvsIcon, lvsSmallIcon, lvsList, lvsDetail, lvsDetailNoHeader );
{* Styles of view for ListView control (see NewListVew). }
TListViewItemStates = ( lvisFocus, lvisSelect, lvisBlend, lvisHighlight );
TListViewItemState = Set of TListViewItemStates;
TListViewOption = (
lvoIconLeft, // in lvsIcon, lvsSmallIcon place icon left from text (rather then top)
lvoAutoArrange, // keep icons auto arranged in lvsIcon and lvsSmallIcon view
lvoButton, // icons look like buttons in lvsIcon view
lvoEditLabel, // allows edit labels inplace (first column #0 text)
lvoNoLabelWrap, // item text on a single line in lvsIcon view (by default, item text may wrap in lvsIcon view).
lvoNoScroll, // obvious
lvoNoSortHeader, // click on header button does not lead to sort items
lvoHideSel, // hide selection when not in focus
lvoMultiselect, // allow to select multiple items
lvoSortAscending,
lvoSortDescending,
// extended styles (not documented in my Win32.hlp :( , got from VCL source:
lvoGridLines,
lvoSubItemImages,
lvoCheckBoxes,
lvoTrackSelect,
lvoHeaderDragDrop,
lvoRowSelect,
lvoOneClickActivate,
lvoTwoClickActivate,
lvoFlatsb,
lvoRegional,
lvoInfoTip,
lvoUnderlineHot,
lvoMultiWorkares,
// virtual list view style:
lvoOwnerData,
// custom draw style:
lvoOwnerDrawFixed
);
TListViewOptions = Set of TListViewOption;
TOnEditLVItem = function( Sender: PControl; Idx, Col: Integer; NewText: PKOL_Char ): Boolean
of object;
{* Event type for OnEndEditLVItem. Return True in handler to accept new text value. }
TOnDeleteLVItem = procedure( Sender: PControl; Idx: Integer ) of object;
{* Event type for OnDeleteLVItem event. }
TOnLVData = procedure( Sender: PControl; Idx, SubItem: Integer;
var Txt: KOL_String; var ImgIdx: Integer; var State: DWORD;
var Store: Boolean ) of object;
{* Event type for OnLVData event. Used to provide virtual list view control
(i.e. having lvoOwnerData style) with actual data on request. Use parameter
Store as a flag if control should store obtained data by itself or not. }
{$IFDEF ENABLE_DEPRECATED}
{$DEFINE interface_1} {$I KOL_deprecated.inc} {$UNDEF interface_1}
{$ENDIF DISABLE_DEPRECATED}
TOnCompareLVItems = function( Sender: PControl; Idx1, Idx2: Integer ): Integer
of object;
{* Event type to compare two items of the list view (while sorting it). }
TOnLVColumnClick = procedure( Sender: PControl; Idx: Integer ) of object;
{* Event type for OnColumnClick event. }
TOnLVStateChange = procedure( Sender: PControl; IdxFrom, IdxTo: Integer; OldState, NewState: DWORD )
of object;
{* Event type for OnLVStateChange event, called in responce to select/unselect
a single item or items range in list view control). }
TDrawActions = ( odaEntire, odaFocus, odaSelect );
TDrawAction = Set of TDrawActions;
TDrawStates = ( odsSelected, odsGrayed, odsDisabled, odsChecked, odsFocused,
odsDefault, odsHotlist, odsInactive,
odsNoAccel, odsNoFocusRect,
ods400reserved, ods800reserved,
odsComboboxEdit,
// specific for common controls:
odsMarked, odsIndeterminate );
{* Possible draw states.
|
odsSelected - The menu item's status is selected.
|
odsGrayed - The item is to be grayed. This bit is used only in a menu.
|
odsDisabled - The item is to be drawn as disabled.
|
odsChecked - The menu item is to be checked. This bit is used only in
a menu.
|
odsFocused - The item has the keyboard focus.
|
odsDefault - The item is the default item.
|
odsHotList - Windows 98, Windows 2000: The item is being
hot-tracked, that is, the item will be highlighted when
the mouse is on the item.
|
odsInactive - Windows 98, Windows 2000: The item is inactive
and the window associated with the menu is inactive.
|
odsNoAccel - Windows 2000: The control is drawn without the
keyboard accelerator cues.
|
odsNoFocusRect - Windows 2000: The control is drawn without
focus indicator cues.
|
odsComboboxEdit - The drawing takes place in the selection field
(edit control) of an owner-drawn combo box.
|
odsMarked - for Common controls only. The item is marked. The meaning
of this is up to the implementation.
|
odsIndeterminate - for Common Controls only. The item is in an
indeterminate state. }
TDrawState = Set of TDrawStates;
{* Set of possible draw states. }
TOnDrawItem = function( Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer;
DrawAction: TDrawAction; ItemState: TDrawState ): Boolean of object;
{* Event type for OnDrawItem event (applied to list box, combo box, list view). }
TOnMeasureItem = function( Sender: PObj; Idx: Integer ): Integer of object;
{* Event type for OnMeasureItem event. The event handler must return height of list box
item as a result. }
TGetLVItemPart = ( lvipBounds, lvipIcon, lvipLabel, lvupIconAndLabel );
{* }
TWherePosLVItem = ( lvwpOnIcon, lvwpOnLabel, lvwpOnStateIcon, lvwpOnColumn,
lvwpOnItem );
{* }
TOnLVCustomDraw = function( Sender: PControl; DC: HDC; Stage: DWORD;
ItemIdx, SubItemIdx: Integer; const Rect: TRect;
ItemState: TDrawState; var TextColor, BackColor: TColor )
: DWORD of object;
{* Event type for OnLVCustomDraw event. }
//[Paint TYPES]
TOnPaint = procedure( Sender: PControl; DC: HDC ) of object;
TPaintProc = procedure( DC: HDC ) of object;
TGradientStyle = ( gsVertical, gsHorizontal, gsRectangle, gsElliptic, gsRombic,
gsTopToBottom, gsBottomToTop );
{* Gradient fill styles. See also TGradientLayout. }
TGradientLayout = ( glTopLeft, glTop, glTopRight,
glLeft, glCenter, glRight,
glBottomLeft, glBottom, glBottomRight );
{* Position of starting line / point for gradient filling. Depending on
TGradientStyle, means either position of first line of first rectangle
(ellipse) to be expanded in a loop to fit entire gradient panel area. }
//[Edit TYPES]
TEditOption = ( eoNoHScroll, eoNoVScroll, eoLowercase, eoMultiline,
eoNoHideSel, eoOemConvert, eoPassword, eoReadonly,
eoUpperCase, eoWantReturn, eoWantTab, eoNumber );
{* Available edit options.
|
Please note, that eoWantTab option just removes TAB key from a list
of keys available to tabulate from the edit control. To provide insertion
of tabulating key, do so in TControl.OnChar event handler. Sorry for
inconvenience, but this is because such behaviour is not must in all cases.
See also TControl.EditTabChar property. }
TEditOptions = Set of TEditOption;
{* Set of available edit options. }
TEditPositions = {$ifndef wince}packed{$endif} record
SelStart: Integer;
SelLength: Integer;
TopLine: Integer;
TopColumn: Integer;
ScrollPos: TPoint;
RestoreScroll: Boolean;
end;
TRichFmtArea = ( raSelection, raWord, raAll );
{* Characters formatting area for RichEdit. }
TRETextFormat = ( reRTF, reText, rePlainRTF, reRTFNoObjs, rePlainRTFNoObjs,
reTextized, reUnicode, reTextUnicode );
{* Available formats for transfer RichEdit text using property
TControl.RE_Text.
|
reRTF - normal rich text (no transformations)
reText - plain text only (without OLE objects)
reTextized - plain text with text representation of COM objects
rePlainRTF - reRTF without language-specific keywords
reRTFNoObjs - reRTF without OLE objects
rePlainRTFNoObjs - rePlainRTF without OLE objects
reUnicode - stream is 2-byte Unicode characters rather then 1-byte Ansi
| }
TRichUnderline = ( ruSingle, ruWord, ruDouble, ruDotted,
//all other - only for RichEditv3.0:
ruDash, ruDashDot, ruDashDotDot, ruWave, ruThick, ruHairLine );
{* Rich text exteded underline styles (available only for RichEdit v2.0,
and even for RichEdit v2.0 additional styles can not displayed - but
ruDotted under Windows2000 is working). }
TRichTextSizes = ( rtsNoUseCRLF, rtsNoPrecise, rtsClose, rtsBytes );
{* Options to calculate size of rich text. Available only for RichEdit2.0
or higher. }
TRichTextSize = set of TRichTextSizes;
{* Set of all available optioins to calculate rich text size using
property TControl.RE_TextSize[ options ]. }
TRichNumbering = ( rnNone, rnBullets, rnArabic, rnLLetter, rnULetter,
rnLRoman, rnURoman );
{* Advanced numbering styles for paragraph (RichEdit).
|
rnNone - no numbering
rnBullets - bullets only
rnArabic - 1, 2, 3, 4, ...
rnLLetter - a, b, c, d, ...
rnULetter - A, B, C, D, ...
rnLRoman - i, ii, iii, iv, ...
rnURoman - I, II, III, IV, ...
rnNoNumber - do not show any numbers (but numbering is taking place).
| }
TRichNumBrackets = ( rnbRight, rnbBoth, rnbPeriod, rnbPlain, rnbNoNumber );
{* Brackets around number:
|
rnbRight - 1) 2) 3) - this is default !
rnbBoth - (1) (2) (3)
rnbPeriod - 1. 2. 3.
rnbPlain - 1 2 3
| }
TBorderEdge = (beLeft, beTop, beRight, beBottom);
{* Borders of rectangle. }
{$IFNDEF NOT_USE_RICHEDIT}
TCharFormat = TCharFormat2;
TParaFormat = TParaFormat2;
{$ENDIF NOT_USE_RICHEDIT}
TOnTestMouseOver = function( Sender: PControl ): Boolean of object;
{* Event type for TControl.OnTestMouseOver event. The handler should
return True, if it dectects, that mouse is over control. }
TEdgeStyle = ( esRaised, esLowered, esNone, esTransparent );
{* Edge styles (for panel - see NewPanel). }
//[List TYPES]
TListOption = ( loNoHideScroll, loNoExtendSel, loMultiColumn, loMultiSelect,
loNoIntegralHeight, loNoSel, loSort, loTabstops,
loNoStrings, loNoData, loOwnerDrawFixed, loOwnerDrawVariable,
loHScroll );
{* Options for ListBox (see NewListbox).
To use loHScroll, you also have to send LB_SETHORIZONTALEXTENT with a
maximum width of a line in pixels (wParam)! }
TListOptions = Set of TListOption;
{* Set of available options for Listbox. }
TComboOption = ( coReadOnly, coNoHScroll, coAlwaysVScroll, coLowerCase,
coNoIntegralHeight, coOemConvert, coSort, coUpperCase,
coOwnerDrawFixed, coOwnerDrawVariable, coSimple );
{* Options for combobox. }
TComboOptions = Set of TComboOption;
{* Set of options available for combobox. }
//[Progress TYPES]
TProgressbarOption = ( pboVertical, pboSmooth );
{* Options for progress bar. }
TProgressbarOptions = set of TProgressbarOption;
{* Set of options available for progress bar. }
//[TreeView TYPES]
TTreeViewOption = ( tvoNoLines, tvoLinesRoot, tvoNoButtons, tvoEditLabels, tvoHideSel,
tvoDragDrop, tvoNoTooltips, tvoCheckBoxes, tvoTrackSelect,
tvoSingleExpand, tvoInfoTip, tvoFullRowSelect, tvoNoScroll,
tvoNonEvenHeight );
{* Tree view options. }
TTreeViewOptions = set of TTreeViewOption;
{* Set of tree view options. }
//[TabControl TYPES]
TTabControlOption = ( tcoButtons, tcoFixedWidth, tcoFocusTabs,
tcoIconLeft, tcoLabelLeft,
tcoMultiline, tcoMultiselect, tcoFitRows, tcoScrollOpposite,
tcoBottom, tcoVertical, tcoFlat, tcoHotTrack, tcoBorder,
tcoOwnerDrawFixed );
{* Options, available for TabControl. }
TTabControlOptions = set of TTabControlOption;
{* Set of options, available for TAbControl during its creation (by
NewTabControl function). }
//[Toolbar TYPES]
TToolbarOption = ( tboTextRight, tboTextBottom, tboFlat, tboTransparent,
tboWrapable, tboNoDivider, tbo3DBorder, tboCustomErase );
{* Toolbar options. When tboFlat is set and toolbar is placed onto panel,
set its property Transparent to TRUE to provide its correct view. }
TToolbarOptions = Set of TToolbarOption;
{* Set of toolbar options. }
TOnToolbarButtonClick = procedure( Sender: PControl; BtnID: Integer ) of object;
{* Special event type to handle separate toolbar buttons click events. }
{$ifndef wince}
TOnTBCustomDraw = function( Sender: PControl; var NMCD: TNMTBCustomDraw ): Integer of object;
{* Event type for OnTBCustomDraw event. }
{$endif wince}
TDateTimePickerOption = ( dtpoTime, dtpoDateLong, dtpoUpDown, dtpoRightAlign,
dtpoShowNone, dtpoParseInput );
{* }
TDateTimePickerOptions = set of TDateTimePickerOption;
{* }
TDTParseInputEvent = procedure(Sender: PControl; const UserString: string;
var DateAndTime: TDateTime; var AllowChange: Boolean) of object;
{* }
TDateTimeRange = {$ifndef wince}packed{$endif} record
FromDate, ToDate: TDateTime;
end;
{* }
TDateTimePickerColor = ( dtpcBackground, dtpcMonthBk, dtpcText, dtpcTitleBk,
dtpcTitleText, dtpcTrailingText );
//[TOnDropFiles TYPE]
TOnDropFiles = procedure( Sender: PControl; const FileList: KOL_String; const Pt: TPoint ) of object;
{* An event type for OnDropFiles event. When the event is occur, FileList
parameter contains a list of files dropped. File names in a list are
separated with #13 character. This allows You to assign it to TStrList
object using its property Text (for example):
! procedure TSomeObject.DropFiles( Sender: PControl; const FileList: String;
! const Pt: TPoint ); )
! var FList: PStrList;
! I: Integer;
! begin
! FList := NewStrList;
! FList.Text := FileList;
! for I := 0 to FList.Count-1 do
! begin
! // do something with FList.Items[ I ]
! end;
! FList.Free;
! end; }
//[Scroll TYPES]
TScrollerBar = ( sbHorizontal, sbVertical );
TScrollerBars = set of TScrollerBar;
TOnScroll = procedure( Sender: PControl; Bar: TScrollerBar; ScrollCmd: DWORD;
ThumbPos: DWORD ) of object;
//[TOnHelp EVENT TYPE]
TOnHelp = procedure( var Sender: PControl; var Context: Integer; var Popup: Boolean )
of object;
//[ScrollBar TYPES]
TOnSBBeforeScroll =
procedure(
Sender: PControl; OldPos, NewPos: Integer; Cmd: Word;
var AllowChange: Boolean) of object;
TOnSBScroll = procedure(Sender: PControl; Cmd: Word) of object;
{$IFDEF WIN_GDI}
TOnGraphCtlMouse = procedure( var Msg: TMsg ) of object;
{$ENDIF WIN_GDI}
TTriStateCheck = (tsUnchecked{=0}, tsChecked{=1}, tsIndeterminate{=2});
{$IFDEF _X_}
//---- in GTK+, each type of widget requieres its own getcaption/setcaption call
TGetCaption = function( Ctl: PControl ): KOLString;
TSetCaption = procedure( Ctl: PControl; const Value: KOLString );
{$IFDEF GTK}
//---- in GTK+, to allow setting absolute position for children,
// we should use one of special clients like gtk_fixed, gtk_layout
TGetClientArea = function( Ctl: PControl ): PGtkWidget;
TChildSetPos = procedure( Ctl, Chld: PControl; x, y: Integer );
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF USE_MHTOOLTIP}
{$DEFINE pre_interface}
{$I KOLMHToolTip.pas}
{$UNDEF pre_interface}
{$ENDIF}
{ ----------------------------------------------------------------------
TControl - object to implement any visual control
----------------------------------------------------------------------- }
//[TControl DEFINITION]
TControl = object( TObj )
{* Object to implement any visual control }
{$IFDEF GDI}
protected
fSBMinMax: TPoint;
fSBPageSize: Integer;
fSBPosition: Integer;
procedure SetSBMax(Value: Longint);
procedure SetSBMin(Value: Longint);
procedure SetSBPageSize(Value: Integer);
procedure SetSBPosition(Value: Integer);
procedure SetSBMinMax(const Value: TPoint);
function GetDate: TDateTime;
function GetTime: TDateTime;
procedure SetDate(const Value: TDateTime);
procedure SetTime(const Value: TDateTime);
{*! TControl is the basic visual object of KOL. And now, all visual
objects have the same type PControl, differing only in "constructor",
which during creating of object adjusts it so it can play role of
desired control. Idea of incapsulating of all visual objects having
the most common set of properties, is belonging to Vladimir Kladov,
(C) 2000.
|
Since all visual objects are represented
in KOL by this single object type, not all methods, properties and
events defined in TControl, are applicable to different visual objects.
See also notes about certain control kinds, located together with its
|
|constructing functions definitions. }
{$ENDIF GDI}
protected
{$IFDEF GDI}
function GetHelpPath: KOLString;
procedure SetHelpPath(const Value: KOLString);
procedure SetOnQueryEndSession(const Value: TOnEventAccept);
procedure SetOnMinMaxRestore(const Index: Integer; const Value: TOnEvent);
procedure SetOnMinimize( const Value: TOnEvent );
procedure SetOnMaximize( const Value: TOnEvent );
procedure SetOnRestore( const Value: TOnEvent );
procedure SetConstraint(const Index, Value: Integer);
{$IFDEF F_P}
function GetOnMinMaxRestore(const Index: Integer): TOnEvent;
function GetConstraint(const Index: Integer): Integer;
{$ENDIF F_P}
procedure SetOnScroll(const Value: TOnScroll);
function GetLVColalign(Idx: Integer): TTextAlign;
procedure SetLVColalign(Idx: Integer; const Value: TTextAlign);
{$ENDIF GDI}
procedure SetParent( Value: PControl );
function GetLeft: Integer;
procedure SetLeft( Value: Integer );
function GetTop: Integer;
procedure SetTop( Value: Integer );
function GetWidth: Integer;
procedure SetWidth( Value: Integer );
function GetHeight: Integer;
procedure SetHeight( Value: Integer );
function GetPosition: TPoint;
procedure Set_Position( Value: TPoint );
function GetMembers(Idx: Integer): PControl;
function GetFont: PGraphicTool;
procedure FontChanged( Sender: PGraphicTool );
{$IFDEF GDI}
function GetBrush: PGraphicTool;
procedure BrushChanged( Sender: PGraphicTool );
function GetClientHeight: Integer;
function GetClientWidth: Integer;
procedure SetClientHeight(const Value: Integer);
procedure SetClientWidth(const Value: Integer);
function GetHasBorder: Boolean;
procedure SetHasBorder(const Value: Boolean);
function GetHasCaption: Boolean;
procedure SetHasCaption(const Value: Boolean);
function GetCanResize: Boolean;
procedure SetCanResize( const Value: Boolean );
function GetStayOnTop: Boolean;
procedure SetStayOnTop(const Value: Boolean);
function GetChecked: Boolean;
procedure Set_Checked(const Value: Boolean);
function GetCheck3: TTriStateCheck;
procedure SetCheck3(value: TTriStateCheck);
function GetSelStart: Integer;
procedure SetSelStart(const Value: Integer);
function GetSelLength: Integer;
procedure SetSelLength(const Value: Integer);
function GetItems(Idx: Integer): KOLString;
procedure SetItems(Idx: Integer; const Value: KOLString);
function GetItemsCount: Integer;
function GetItemSelected(ItemIdx: Integer): Boolean;
procedure SetItemSelected(ItemIdx: Integer; const Value: Boolean);
procedure SetCtl3D(const Value: Boolean);
function GetCurIndex: Integer;
procedure SetCurIndex(const Value: Integer);
{$ENDIF GDI}
function GetTextAlign: TTextAlign;
procedure SetTextAlign(const Value: TTextAlign);
function GetVerticalAlign: TVerticalAlign;
procedure SetVerticalAlign(const Value: TVerticalAlign);
function GetCanvas: PCanvas;
{$IFDEF _X_}
{$IFDEF GTK}
protected
fInBkPaint: Boolean;
fSetTextAlign: procedure( Self_: PControl );
function ProvideCanvasHandle( Sender: PCanvas ): HDC;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
function Dc2Canvas( Sender: PCanvas ): HDC;
procedure SetShadowDeep(const Value: Integer);
procedure SetDoubleBuffered(const Value: Boolean);
procedure SetStatusText(Index: Integer; Value: PKOLChar);
function GetStatusText( Index: Integer ): PKOLChar;
function GetStatusPanelX(Idx: Integer): Integer;
procedure SetStatusPanelX(Idx: Integer; const Value: Integer);
procedure SetTransparent(const Value: Boolean);
function GetImgListIdx(const Index: Integer): PImageList;
procedure SetImgListIdx(const Index: Integer; const Value: PImageList);
function GetLVColText(Idx: Integer): KOLString;
procedure SetLVColText(Idx: Integer; const Value: KOLString);
{$IFDEF ENABLE_DEPRECATED}
{$DEFINE interface_2} {$I KOL_deprecated.inc} {$UNDEF interface_2}
{$ENDIF DISABLE_DEPRECATED}
protected
function LVGetItemText(Idx, Col: Integer): KOLString;
procedure LVSetItemText(Idx, Col: Integer; const Value: KOLString);
procedure SetLVOptions(const Value: TListViewOptions);
procedure SetLVStyle(const Value: TListViewStyle);
function GetLVColEx(Idx: Integer; const Index: Integer): Integer;
procedure SetLVColEx(Idx: Integer; const Index: Integer;
const Value: Integer);
{$ENDIF GDI}
function GetChildCount: Integer;
{$IFDEF GDI}
function LVGetItemPos(Idx: Integer): TPoint;
procedure LVSetItemPos(Idx: Integer; const Value: TPoint);
procedure LVSetColorByIdx(const Index: Integer; const Value: TColor);
{$IFDEF F_P}
function LVGetColorByIdx(const Index: Integer): TColor;
{$ENDIF F_P}
function GetIntVal(const Index: Integer): Integer;
procedure SetIntVal(const Index, Value: Integer);
function GetItemVal(Item: Integer; const Index: Integer): Integer;
procedure SetItemVal(Item: Integer; const Index, Value: Integer);
function TBGetButtonVisible(BtnID: Integer): Boolean;
procedure TBSetButtonVisible(BtnID: Integer; const Value: Boolean);
function TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;
procedure TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean);
function TBGetButtonText(BtnID: Integer): KOLString;
function TBGetButtonRect(BtnID: Integer): TRect;
function TBGetRows: Integer;
procedure TBSetRows(const Value: Integer);
procedure SetProgressColor(const Value: TColor);
function TBGetBtnImgIdx(BtnID: Integer): Integer;
procedure TBSetBtnImgIdx(BtnID: Integer; const Value: Integer);
procedure TBSetButtonText(BtnID: Integer; const Value: KOLString);
function TBGetBtnWidth(BtnID: Integer): Integer;
procedure TBSetBtnWidth(BtnID: Integer; const Value: Integer);
procedure TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer);
{$IFDEF F_P}
function TBGetBtMinMaxWidth(const Idx: Integer): Integer;
{$ENDIF F_P}
procedure TBFreeTBevents;
procedure Set_Align(const Value: TControlAlign);
function GetSelection: KOLString;
procedure SetSelection(const Value: KOLString);
procedure SetTabOrder(const Value: Integer);
function GetFocused: Boolean;
procedure SetFocused(const Value: Boolean);
{$IFNDEF NOT_USE_RICHEDIT}
function REGetFont: PGraphicTool;
procedure RESetFont(Value: PGraphicTool);
procedure RESetFontEx(const Index: Integer);
function REGetFontEffects(const Index: Integer): Boolean;
function REGetFontMask(const Index: Integer): Boolean;
procedure RESetFontEffect(const Index: Integer; const Value: Boolean);
function REGetFontAttr(const Index: Integer): Integer;
procedure RESetFontAttr(const Index, Value: Integer);
procedure RESetFontAttr1(const Index, Value: Integer);
function REGetFontSizeValid: Boolean;
function REGetCharformat: TCharFormat;
procedure RESetCharFormat(const Value: TCharFormat);
function REReadText(Format: TRETextFormat;
SelectionOnly: Boolean): KOLString;
procedure REWriteText(Format: TRETextFormat; SelectionOnly: Boolean;
const Value: KOLString);
function REGetFontName: KOLString;
procedure RESetFontName(const Value: KOLString);
function REGetParaFmt: TParaFormat;
procedure RESetParaFmt(const Value: TParaFormat);
function REGetNumbering: Boolean;
function REGetParaAttr( const Index: Integer ): Integer;
function REGetParaAttrValid( const Index: Integer ): Boolean;
function REGetTabCount: Integer;
function REGetTabs(Idx: Integer): Integer;
function REGetTextAlign: TRichTextAlign;
procedure RESetNumbering(const Value: Boolean);
procedure RESetParaAttr(const Index, Value: Integer);
procedure RESetTabCount(const Value: Integer);
procedure RESetTabs(Idx: Integer; const Value: Integer);
procedure RESetTextAlign(const Value: TRichTextAlign);
function REGetStartIndentValid: Boolean;
function REGetAutoURLDetect: Boolean;
procedure RESetAutoURLDetect(const Value: Boolean);
procedure RESetZoom( const Value: TSmallPoint );
function REGetZoom: TSmallPoint;
{$ENDIF NOT_USE_RICHEDIT}
function GetMaxTextSize: DWORD;
procedure SetMaxTextSize(const Value: DWORD);
function GetTextSize: Integer;
procedure SetOnResize(const Value: TOnEvent);
procedure DoSelChange;
{$IFNDEF NOT_USE_RICHEDIT}
function REGetUnderlineEx: TRichUnderline;
procedure RESetUnderlineEx(const Value: TRichUnderline);
function REGetTextSize(Units: TRichTextSize): Integer;
function REGetNumStyle: TRichNumbering;
procedure RESetNumStyle(const Value: TRichNumbering);
function REGetNumBrackets: TRichNumBrackets;
procedure RESetNumBrackets(const Value: TRichNumBrackets);
function REGetNumTab: Integer;
procedure RESetNumTab(const Value: Integer);
function REGetNumStart: Integer;
procedure RESetNumStart(const Value: Integer);
function REGetSpacing(const Index: Integer): Integer;
procedure RESetSpacing(const Index, Value: Integer);
function REGetSpacingRule: Integer;
procedure RESetSpacingRule(const Value: Integer);
function REGetLevel: Integer;
function REGetBorder(Side: TBorderEdge; const Index: Integer): Integer;
procedure RESetBorder(Side: TBorderEdge; const Index: Integer;
const Value: Integer);
function REGetParaEffect(const Index: Integer): Boolean;
procedure RESetParaEffect(const Index: Integer; const Value: Boolean);
function REGetOverwite: Boolean;
procedure RESetOverwrite(const Value: Boolean);
procedure RESetOvrDisable(const Value: Boolean);
function REGetTransparent: Boolean;
procedure RESetTransparent(const Value: Boolean);
procedure RESetOnURL(const Index: Integer; const Value: TOnEvent);
procedure SetOnRE_URLClick( const Value: TOnEvent );
procedure SetOnRE_OverURL( const Value: TOnEvent );
{$IFDEF F_P}
function REGetOnURL(const Index: Integer): TOnEvent;
{$ENDIF F_P}
function REGetLangOptions(const Index: Integer): Boolean;
procedure RESetLangOptions(const Index: Integer; const Value: Boolean);
{$ENDIF NOT_USE_RICHEDIT}
function LVGetItemImgIdx(Idx: Integer): Integer;
procedure LVSetItemImgIdx(Idx: Integer; const Value: Integer);
procedure SetFlat(const Value: Boolean);
procedure SetOnMouseEnter(const Value: TOnEvent);
procedure SetOnMouseLeave(const Value: TOnEvent);
procedure EdSetTransparent(const Value: Boolean);
procedure SetOnTestMouseOver(const Value: TOnTestMouseOver);
function GetPages(Idx: Integer): PControl;
function TCGetItemText(Idx: Integer): KOLString;
procedure TCSetItemText(Idx: Integer; const Value: KOLString);
function TCGetItemImgIDx(Idx: Integer): Integer;
procedure TCSetItemImgIdx(Idx: Integer; const Value: Integer);
function TCGetItemRect(Idx: Integer): TRect;
function TVGetItemIdx(const Index: Integer): THandle;
procedure TVSetItemIdx(const Index: Integer; const Value: THandle);
function TVGetItemNext(Item: THandle; const Index: Integer): THandle;
function TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect;
function TVGetItemVisible(Item: THandle): Boolean;
procedure TVSetITemVisible(Item: THandle; const Value: Boolean);
function TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean;
procedure TVSetItemStateFlg(Item: THandle; const Index: Integer;
const Value: Boolean);
function TVGetItemImage(Item: THandle; const Index: Integer): Integer;
procedure TVSetItemImage(Item: THandle; const Index: Integer;
const Value: Integer);
function TVGetItemText(Item: THandle): KOLString;
procedure TVSetItemText(Item: THandle; const Value: KOLString);
function TV_GetItemHasChildren(Item: THandle): Boolean;
procedure TV_SetItemHasChildren(Item: THandle; const Value: Boolean);
function TV_GetItemChildCount(Item: THandle): Integer;
function TVGetItemData(Item: THandle): Pointer;
procedure TVSetItemData(Item: THandle; const Value: Pointer);
function GetToBeVisible: Boolean;
procedure SetAlphaBlend(const Value: Integer);
procedure SetMaxProgress(const Index, Value: Integer);
procedure SetDroppedWidth(const Value: Integer);
function LVGetItemState(Idx: Integer): TListViewItemState;
procedure LVSetItemState(Idx: Integer; const Value: TListViewItemState);
function LVGetSttImgIdx(Idx: Integer): Integer;
procedure LVSetSttImgIdx(Idx: Integer; const Value: Integer);
function LVGetOvlImgIdx(Idx: Integer): Integer;
procedure LVSetOvlImgIdx(Idx: Integer; const Value: Integer);
function LVGetItemData(Idx: Integer): DWORD;
procedure LVSetItemData(Idx: Integer; const Value: DWORD);
function LVGetItemIndent(Idx: Integer): Integer;
procedure LVSetItemIndent(Idx: Integer; const Value: Integer);
procedure SetOnDeleteAllLVItems(const Value: TOnEvent);
procedure SetOnDeleteLVItem(const Value: TOnDeleteLVItem);
procedure SetOnEndEditLVItem(const Value: TOnEditLVItem);
procedure SetOnLVData(const Value: TOnLVData);
procedure SetOnColumnClick(const Value: TOnLVColumnClick);
procedure SetOnDrawItem(const Value: TOnDrawItem);
procedure SetOnMeasureItem(const Value: TOnMeasureItem);
procedure SetItemsCount(const Value: Integer);
function GetItemData(Idx: Integer): DWORD;
procedure SetItemData(Idx: Integer; const Value: DWORD);
function GetLVCurItem: Integer;
procedure SetLVCurItem(const Value: Integer);
function GetLVFocusItem: Integer;
procedure SetOnDropFiles(const Value: TOnDropFiles);
procedure SetOnHide(const Value: TOnEvent);
procedure SetOnShow(const Value: TOnEvent);
procedure SetClientMargin(const Index, Value: Integer);
{$IFDEF F_P}
function GetClientMargin(const Index: Integer): Integer;
{$ENDIF F_P}
{$ENDIF GDI}
protected
{$IFDEF _X_}
{$IFDEF GTK}
fExposeEvent: Integer;
{$ENDIF GTK}
{$ENDIF _X_}
procedure SetOnPaint(const Value: TOnPaint);
{$IFDEF GDI}
procedure SetOnEraseBkgnd(const Value: TOnPaint);
procedure SetTVRightClickSelect(const Value: Boolean);
procedure SetOnLVStateChange(const Value: TOnLVStateChange);
procedure SetOnMove(const Value: TOnEvent);
procedure SetOnMoving(const Value: TOnEventMoving);
procedure SetColor1(const Value: TColor);
procedure SetColor2(const Value: TColor);
procedure SetGradientLayout(const Value: TGradientLayout);
procedure SetGradientStyle(const Value: TGradientStyle);
procedure SetDroppedDown(const Value: Boolean);
function get_ClassName: KOLString;
procedure set_ClassName(const Value: KOLString);
procedure SetClsStyle( Value: DWord );
{$IFDEF GRAPHCTL_XPSTYLES}
procedure SetEdgeStyle( Value: TEdgeStyle );
{$ENDIF}
procedure SetStyle( Value: DWord );
procedure SetExStyle( Value: DWord );
procedure SetCursor( Value: HCursor );
procedure SetIcon( Value: HIcon );
procedure SetMenu( Value: HMenu );
{$ENDIF GDI}
protected
{$IFDEF _X_}
fGetCaption: TGetCaption;
fSetCaption: TSetCaption;
{$ENDIF _X_}
function GetCaption: KOLString;
procedure SetCaption( const Value: KOLString );
{$IFDEF GDI}
procedure SetWindowState( Value: TWindowState );
function GetWindowState: TWindowState;
{$ENDIF GDI}
procedure ApplyFont2Wnd;
{$IFDEF GDI}
procedure DoClick;
function TBAddInsButtons( Idx: Integer; const Buttons: array of PKOLChar;
const BtnImgIdxArray: array of Integer ): Integer;
procedure SetBitBtnDrawMnemonic(const Value: Boolean);
function GetBitBtnImgIdx: Integer;
procedure SetBitBtnImgIdx(const Value: Integer);
function GetBitBtnImageList: THandle;
procedure SetBitBtnImageList(const Value: THandle);
function GetModal: Boolean;
{$IFDEF USE_SETMODALRESULT}
procedure SetModalResult( const Value: Integer );
{$ENDIF}
{$ENDIF GDI}
protected
{$IFDEF GDI}
fHandle: HWnd;
{$ELSE}
{$IFDEF GTK} fHandle: PGtkWidget;
fCaptionHandle: PGtkWidget;
fEventboxHandle: PGtkWidget;
fGetClientArea: TGetClientArea;
fClient: PGtkWidget;
fChildPut: TChildSetPos;
fChildSetPos: TChildSetPos;
{$ENDIF}
{$IFDEF Q_T} fHandle: sometypehere ; {$ENDIF}
{$ENDIF}
{$IFDEF GDI}
fFocusHandle: HWnd;
fClsStyle: DWord;
fStyle: DWord;
fExStyle: DWord;
fCursor: HCursor;
fCursorShared: Boolean;
fIcon: HIcon;
fIconShared: Boolean;
{$ENDIF GDI}
fIgnoreWndCaption: Boolean;
{$IFDEF GDI}
{$IFDEF GRAPHCTL_XPSTYLES}
fEdgeStyle : TEdgeStyle;
{$ENDIF}
fWindowState: TWindowState;
//fShowAction: Integer;
fDefWndProc: Pointer;
fNCDestroyed: Boolean;
{$ENDIF GDI}
FParent: PControl;
fEnabled: Boolean; // Caution!!! fVisible must follow fEnabled! ___
fVisible: Boolean; //____________________________________________//
fTabstop: Boolean;
fTabOrder: Integer;
fTextAlign: TTextAlign;
fVerticalAlign: TVerticalAlign;
fWordWrap: Boolean;
fPreventResize: Boolean;
{$IFDEF GDI}
fAlphaBlend: Integer;
{$ENDIF GDI}
FDroppedWidth: Integer;
// Caution!!! order of following 5 fields is important!!!
fDynHandlers: PList;
fChildren: PList;
{* List of children. }
{$ifndef wince}
fTBttCmd: PList;
{$endif wince}
fTBttTxt: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
{$IFDEF GDI}
fTmpFont: PGraphicTool;
{$ENDIF GDI}
//________________________________________________________//
{$IFDEF GDI}
fMDIClient: PControl;
{* MDI client window control }
fMDIChildren: PList;
{* List of MDI children. It is filled for MDI client window. }
fWndFunc: Pointer;
{* Initially pointer to WndFunc. For MDI child window, points to DefMDIChildProc. }
fExMsgProc: function( Applet: PControl; var Msg: TMsg ): Boolean;
{* Additional message handler called directly from Applet.ProcessMessage.
Used to call TranslateMDISysAccel API function for MDI application. }
fMDIDestroying: Boolean;
{* }
fTmpBrush: HBrush;
{* Brush handle to return in response to some color set messages.
Intended for internal use instead of Brush.Color if possible
to avoid using it. }
fTmpBrushColorRGB: TColor;
{ }
fMembersCount: Integer;
{* Memebers count is first used in XCustomControl to separate
some internal child controls from common XControl.Children
and make it invisible among Children[]. }
fDrawCtrl1st: PControl;
{* Child control to draw it first, i.e. foreground of others. }
FCreating: Boolean;
{* True, when creating of object is in progress. }
fDestroying: Boolean;
{* True, when destroying of the window is started. }
fBeginDestroying: Boolean;
{* true, when destroying of the window is initiated by the system, i.e.
message WM_DESTROY fired }
fNestedMsgHandling: Integer;
{* level of nested message handling for a control. Only when it is 0 at
the end of message handling and fBeginDestroying set, the control is
destroyed. }
fMenu: HMenu;
{* Usually used to store handle of attached main menu, but sometimes
is used to store control ID (for standard GUI controls only). }
{$ENDIF GDI}
fMenuObj: PObj;
{* PMenu pointer to TMenu object. Freed automatically with entire
chain of menu objects attached to a control (or form). }
{$IFDEF _X_}
{$IFDEF GTK}
//fMenuBar: PGtkWidget;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
{$IFNDEF NEW_MENU_ACCELL}
fAccelTable: HAccel;
procedure DoDestroyAccelTable;
{$ENDIF}
{$ENDIF GDI}
protected
{$IFDEF GDI}
{* Handle of accelerator table created by menu(s). }
fImageList: PImageList;
{* Pointer to first private image list. Control can own several image,
lists, linked to a chain of image list objects. All these image lists
are released automatically, when control is destroyed. }
fCtlImageListSml: PImageList;
{* ImageList object (with small icons 16x16) to use with a control (e.g.,
with ListView control).
If not set, but control has a list of image list objects, last added
image list with small icons is used automatically. }
fCtlImageListNormal: PImageList;
{* ImageList object (with big icons 32x32) to use with a control.
If not set, last added image list with big icons is used. }
fCtlImgListState: PImageList;
{* ImageList object to use as a state image list (for ListView control). }
{$ENDIF GDI}
fIsApplet: Boolean;
{* True, if the object represent application taskbar button. }
fIsForm: Boolean;
{* True, if the object is form. }
fIsButton: Boolean;
{$IFDEF GDI}
fSizeGrip: Boolean;
{$ENDIF GDI}
fIsMDIChild: Boolean;
{* TRUE, if the object is MDI child form. }
fIsControl: Boolean;
{* True, if it is a control on form. }
fIsStaticControl: Byte;
{* True, if it is static control with a caption. (To prevent flickering
it in DoubleBuffered mode. }
{$IFDEF GDI}
fIsCommonControl: Boolean;
{* True, if it is common control. }
{$ENDIF GDI}
fChangedPosSz: Byte;
{* Flags of changing left (1), top (2), width (4) or height (8) }
{$IFDEF GDI}
fCannotDoubleBuf: Boolean;
{* True, if cannot set DoubleBuffered to True (RichEdit). }
fUpdRgn: HRgn;
fCollectUpdRgn: HRGN;
fEraseUpdRgn: Boolean;
fPaintDC: HDC;
{$ENDIF GDI}
fLookTabKeys: TTabKeys;
{$IFDEF GDI}
fNotUpdate: Boolean;
fColumn: Integer;
FSupressTab: Boolean;
fUpdateCount: Integer;
fPaintLater: Boolean;
fOnLeave: TOnEvent;
fEditing: Boolean;
fAutoPopupMenu: PObj;
fHelpContext: Integer;
{$IFDEF USE_GRAPHCTLS}
fDoInvalidate: procedure of object;
{$ENDIF}
{$IFDEF GTK}
fDeltaX, fDeltaY: Integer;
{$ENDIF GTK}
// Order of following fields is important:
//_______________________________________________________________________________________________
fPass2DefProc: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
fOnDynHandlers: TWindowFunc; //
fWndProcKeybd: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; //
fControlClick: procedure( Sender : PObj ); //
{$ENDIF GDI}
fAutoSize: procedure( Self_: PObj );
fControlClassName: PKOLChar; //
{$IFDEF GDI}
fWindowed: Boolean; //
{* True, if control is windowed (or is a form). It is set to FALSE only for
graphic controls. }
// //
fCtlClsNameChg: Boolean; //
{* True, if control class name changed and memory is allocated to store it. } //
fWndProcResizeFlicks: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; //
{$ENDIF GDI}
fGotoControl: function( Self_: PControl; Key: DWORD; CheckOnly: Boolean ): Boolean; //
{$IFDEF GDI}
fCtl3Dchild: Boolean; //
fCtl3D: Boolean; //
{$ENDIF GDI}
fTextColor: TColor; //
fColor: TColor; //
{* Color of text. Used instead of fFont.Color internally to //
avoid usage of Font object if user is not accessing and changing it. } //
fFont: PGraphicTool; //
fBrush: PGraphicTool; //
fCanvas: PCanvas;
{* Color of control background. } //
fMargin: Integer; //
fBoundsRect: TRect; //
fClientTop, fClientBottom, fClientLeft, fClientRight: Integer; //
{* Store adjustment factor of ClientRect for some 'idiosincrasies' windows, //
such as Groupbox or Tabcontrol. } //
//_____________________________________________________________________________________________//
// this is the end of fiels set, which order is important
{$IFDEF GDI}
fDoubleBuffered: Boolean;
fTransparent: Boolean;
{$IFDEF GRAPHCTL_XPSTYLES}
fClassicTransparent : boolean;
{$ENDIF}
fRETransparent: Boolean;
fParentRequirePaint: boolean;
fSelfRequirePaint: boolean;
fDblExcludeRgn: HDC;
fOnMessage: TOnMessage;
fOldOnMessage: TOnMessage;
{$ENDIF GDI}
fOnClick: TOnEvent;
fClickedEvent: Integer;
{$IFDEF _X_}
procedure SetOnClick( const Value: TOnEvent );
{$ENDIF _X_}
protected
{$IFDEF GDI}
fRightClick: Boolean;
fCurrentControl: PControl;
fCreateVisible, fCreateHidden: Boolean;
fRadio1st, fRadioLast : THandle;
fDropDownProc: procedure( Sender : PObj );
fDropped: Boolean;
fCurIdxAtDrop: Integer;
fPrevWndProc: Pointer;
fClickDisabled: Byte;
fCurItem, fCurIndex: Integer;
FOnScroll: TOnScroll;
FScrollLineDist: array[ 0..1 ] of Integer;
fDefaultBtn: Boolean;
fCancelBtn: Boolean;
fDefaultBtnCtl: PControl;
fCancelBtnCtl: PControl;
fAllBtnReturnClick: Boolean;
fIgnoreDefault: Boolean;
{$ENDIF GDI}
fOnMouseDown: TOnMouse; // CAUTION!!! Order of mouse event handlers is important. ____
fOnMouseUp: TOnMouse; //
fOnMouseMove: TOnMouse; //
fOnMouseDblClk: TOnMouse; //
fOnMouseWheel: TOnMouse; //_____________________________________________________//
f3ButtonPress: Boolean;
{$IFDEF GDI}
fOldDefWndProc: Pointer;
fOnChange: TOnEvent;
fOnEnter: TOnEvent;
FOnLVCustomDraw: TOnLVCustomDraw;
FOnSBBeforeScroll: TOnSBBeforeScroll;
FOnSBScroll: TOnSBScroll;
protected
procedure SetOnLVCustomDraw(const Value: TOnLVCustomDraw);
public
fCommandActions: TCommandActions;
{$ENDIF GDI}
protected
{$IFDEF GDI}
fOnChar: TOnChar;
{$IFDEF SUPPORT_ONDEADCHAR}
fOnDeadChar: TOnChar;
{$ENDIF SUPPORT_ONDEADCHAR}
fOnKeyUp: TOnKey;
fOnKeyDown: TOnKey;
{$ENDIF GDI}
fOnPaint: TOnPaint;
{$IFDEF GDI}
fOnPaint2: TOnPaint;
fPaintMsg: TMsg;
fOnPrepaint: TOnPaint;
fOnPostPaint: TOnPaint;
fPaintProc: TPaintProc;
{$ENDIF GDI}
FMaxWidth: Integer;
FMinWidth: Integer;
FMaxHeight: Integer;
FMinHeight: Integer;
{$IFDEF GDI}
fShadowDeep: Integer;
fStatusCtl: PControl;
fStatusWnd: HWnd;
fColor1: TColor;
fColor2: TColor;
fLVColCount: Integer;
fLVOptions: TListViewOptions;
fLVStyle: TListViewStyle;
fOnEndEditLVITem: TOnEditLVItem;
fLVTextBkColor: TColor;
fLVItemHeight: Integer;
fOnDropDown: TOnEvent;
fOnCloseUp: TOnEvent;
fModalResult: Integer;
fModal: Integer;
fModalForm: PControl;
{$ENDIF GDI}
fAlign: TControlAlign;
fAligning:TAlignings;
fNotUseAlign: Boolean;
{$IFDEF GDI}
fDragCallback: TOnDrag;
fDragging, fInDoDrag: Boolean;
fDragStartPos: TPoint;
fMouseStartPos: TPoint;
fSplitStartPos: TPoint;
fSplitStartPos2: TPoint;
fSplitStartSize: Integer;
fSplitMinSize1, fSplitMinSize2: Integer;
fOnSplit: TOnSplit;
fSecondControl: PControl;
fOnSelChange: TOnEvent;
{$IFNDEF NOT_USE_RICHEDIT}
fRECharFormatRec: TCharFormat2;
fREError: Integer;
fREStream: PStream;
fREStrLoadLen: DWORD;
fREParaFmtRec: TParaFormat2;
{$ENDIF NOT_USE_RICHEDIT}
FOnResize: TOnEvent;
fOnProgress: TOnEvent;
fCharFmtDeltaSz: Integer;
fParaFmtDeltaSz: Integer;
fREOvr: Boolean;
fReOvrDisable: Boolean;
fOnREInsModeChg: TOnEvent;
fREScrolling: Boolean;
fUpdCount: Integer;
fOnREOverURL: TOnEvent;
fOnREURLClick: TOnEvent;
fRECharArea: TRichFmtArea;
fBitBtnOptions : TBitBtnOptions;
fGlyphLayout : TGlyphLayout;
fGlyphBitmap : HBitmap;
fGlyphCount : Integer;
fGlyphWidth, fGlyphHeight: Integer;
fOnBitBtnDraw: TOnBitBtnDraw;
fFlat: Boolean;
fSizeRedraw: Boolean; {YS}
fOnMouseLeave: TOnEvent;
fOnMouseEnter: TOnEvent;
fOnTestMouseOver: TOnTestMouseOver;
fMouseInControl: Boolean;
fRepeatInterval: Integer;
fChecked: Boolean;
fPushed: Boolean;
fPrevFocusWnd: HWnd;
fOnTVBeginDrag: TOnTVBeginDrag;
fOnTVBeginEdit: TOnTVBeginEdit;
fOnTVEndEdit: TOnTVEndEdit;
fOnTVExpanded: TOnTVExpanded;
fOnTVExpanding: TOnTVExpanding;
fOnTVDelete: TOnTVDelete;
fOnDeleteLVItem: TOnDeleteLVItem;
fOnDeleteAllLVItems: TOnEvent;
fOnLVData: TOnLVData;
fOnCompareLVItems: TOnCompareLVItems;
fOnColumnClick: TOnLVColumnClick;
fOnDrawItem: TOnDrawItem;
fOnMeasureItem: TOnMeasureItem;
fREUrl: KOLString;
FMinimizeWnd: PControl;
FFixWidth: Integer;
FFixHeight: Integer;
FOnDropFiles: TOnDropFiles;
FOnHide: TOnEvent;
FOnShow: TOnEvent;
fOnEraseBkgnd: TOnPaint;
{$ENDIF GDI}
//----- order of following 3 events important: //
fCaption: KOLString;
fCustomData: Pointer;
{$IFDEF GDI}
fStatusTxt: PKOLChar;
//---------------------------------------------//
fCustomObj: PObj;
fOnTVSelChanging: TOnTVSelChanging;
fOnClose: TOnEventAccept;
fOnQueryEndSession: TOnEventAccept;
fCloseQueryReason: TCloseQueryReason;
fShowAction: DWORD;
//----- order of following 3 events important: //
fOnMinimize: TOnEvent; //
fOnMaximize: TOnEvent; //
fOnRestore: TOnEvent; //
//---------------------------------------------//
//fCreateParamsExt: procedure( Self_: PControl; var Params: TCreateParams );
fCreateWndExt: procedure( Sender: PControl );
fTBevents: PList; // events for TBAssignEvents
fTBBtnImgWidth: Integer; // custom toolbar bitmap width
FTBBtMinWidth: Integer;
FTBBtMaxWidth: Integer;
fGradientStyle: TGradientStyle;
fGradientLayout: TGradientLayout;
fVisibleWoParent: Boolean;
fTVRightClickSelect: Boolean;
FOnMove: TOnEvent;
FOnMoving: TOnEventMoving;
FOnLVStateChange: TOnLVStateChange;
fNotAvailable: Boolean;
FPressedMnemonic: DWORD;
FBitBtnDrawMnemonic: Boolean;
FBitBtnGetCaption: function( Self_: PControl; const S: String ): String;
FBitBtnExtDraw: procedure( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect;
const CapText, CapTxtOrig: KOLString; Color: TColor );
FTextShiftX, FTextShiftY: Integer;
fNotifyChild: procedure( Self_, Child: PControl );
fScrollChildren: procedure( Self_: PControl );
fOnHelp: TOnHelp;
FOnDTPUserString: TDTParseInputEvent;
{$ifndef wince}
fOnTBCustomDraw: TOnTBCustomDraw;
{$endif wince}
{$IFDEF USE_MHTOOLTIP}
{$DEFINE var}
{$I KOLMHToolTip.pas}
{$UNDEF var}
{$DEFINE function}
{$I KOLMHToolTip.pas}
{$UNDEF function}
{$ENDIF}
{$ENDIF GDI}
procedure Init; {-}virtual;{+}{++}(*override;*){--}
{* } //CLASSES //BCB_CLASSES
{$IFDEF GDI}
procedure InitParented( AParent: PControl ); virtual;
{* Initialization of visual object. }
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure InitParented( AParent: PControl; widget: PGtkWidget;
need_eventbox: Boolean ); virtual;
{* Initialization of visual object. }
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
procedure DestroyChildren;
{* Destroys children. Is called in destructor, and can be
called in descending classes as earlier as needed to
prevent problems of too late destroying of visuals.
|
Note: since v 2.40, used only for case when a symbol NOT_USE_AUTOFREE4CONTROLS
is defined, otherwise all children are destroyed using common mechanism of
Add2AutoFree. }
function GetParentWnd( NeedHandle: Boolean ): HWnd;
{* Returns handle of parent window. }
function GetParentWindow: HWnd;
{* }
procedure SetEnabled( Value: Boolean );
{* Changes Enabled property value. Overriden here to change enabling
status of a window. }
function GetEnabled: Boolean;
{* Returns True, if Enabled. Overriden here to obtain real window
state. }
procedure SetVisible( Value: Boolean );
{* Sets Visible property value. Overriden here to change visibility
of correspondent window. }
procedure Set_Visible( Value: Boolean );
{* }
function GetVisible: Boolean;
{* Returns True, if correspondent window is Visible. Overriden
to get visibility of real window, not just value stored in object. }
function Get_Visible: Boolean;
{* Returns True, if correspondent window is Visible, for forms and applet,
or if fVisible flag is set, for controls. }
{$ENDIF GDI}
procedure SetCtlColor( Value: TColor );
{* Sets TControl's Color property value. }
procedure SetBoundsRect( const Value: TRect );
{* Sets BoudsRect property value. }
function GetBoundsRect: TRect;
{* Returns bounding rectangle. }
{$IFDEF GDI}
function GetIcon: HIcon;
{* Returns Icon property. By default, if it is not set,
returns Icon property of an Applet. }
procedure CreateSubclass( var Params: TCreateParams; ControlClassName: PKOLChar );
{* Can be used in descending classes to subclass window with given
standard Windows ControlClassName - must be called after
creating Params but before CreateWindow. Usually it is called
in overriden method CreateParams after calling of the inherited one. }
function UpdateWndStyles: PControl;
{* Updates fStyle, fExStyle, fClsStyle from window handle }
procedure SetOnChar(const Value: TOnChar);
{* }
{$IFDEF SUPPORT_ONDEADCHAR}
procedure SetOnDeadChar(const Value: TOnChar);
{* }
{$ENDIF SUPPORT_ONDEADCHAR}
procedure SetOnKeyDown(const Value: TOnKey);
{* }
procedure SetOnKeyUp(const Value: TOnKey);
{* }
{$ENDIF GDI}
procedure SetOnMouseDown(const Value: TOnMouse);
{* }
procedure SetOnMouseMove(const Value: TOnMouse);
{* }
procedure SetOnMouseUp(const Value: TOnMouse);
{* }
procedure SetOnMouseWheel(const Value: TOnMouse);
{* }
procedure SetOnMouseDblClk(const Value: TOnMouse);
{* }
{$IFDEF GDI}
procedure SetHelpContext( Value: Integer );
{* }
procedure SetOnTVDelete( const Value: TOnTVDelete );
{* }
procedure SetDefaultBtn(const Index: Integer; const Value: Boolean);
{$IFDEF F_P}
function GetDefaultBtn(const Index: Integer): Boolean;
{$ENDIF F_P}
function DefaultBtnProc( var Msg: TMsg; var Rslt: Integer ): Boolean;
{* }
procedure SetDateTime( Value: TDateTime );
function GetDateTime: TDateTime;
procedure SetDateTimeRange( Value: TDateTimeRange );
function GetDateTimeRange: TDateTimeRange;
procedure SetDateTimePickerColor( Index: TDateTimePickerColor; Value: TColor );
function GetDateTimePickerColor( Index: TDateTimePickerColor ): TColor;
procedure SetDateTimeFormat( const Value: KOLString );
function Get_SystemTime: TSystemTime;
procedure Set_SystemTime(const Value: TSystemTime);
{$ifndef wince}
procedure SetOnTBCustomDraw( const Value: TOnTBCustomDraw );
{$endif wince}
{$ENDIF GDI}
procedure DoAutoSize;
function InternalProcessMessage(AMsg: PMsg): Boolean;
public
{$IFDEF GDI}
constructor CreateParented( AParent: PControl );
{* Creates new instance of TControl object, calling InitParented }
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
constructor CreateParented( AParent: PControl; widget: PGtkWidget;
need_eventbox: Boolean );
{* Creates new instance of TControl object, calling InitParented }
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* Destroyes object. First of all, destructors for all children
are called. }
function GetWindowHandle: HWnd;
{* Returns window handle. If window is not yet created,
method CreateWindow is called. }
procedure CreateChildWindows;
{* Enumerates all children recursively and calls CreateWindow for all
of these. }
{$ENDIF GDI}
property Parent: PControl read fParent write SetParent;
{* Parent of TParent object. Also must be of TParent type or derived from TParent. }
//property Tag: Integer read FTag write FTag; //--------- moved to TObj --------
{* User-defined pointer, which can contain any data or reference to
anywhere in memory (when used as a pointer).
}
function ChildIndex( Child: PControl ): Integer;
{* Returns index of given child. }
procedure MoveChild( Child: PControl; NewIdx: Integer );
{* Moves given Child into new position. }
{$IFDEF GDI}
property Enabled: Boolean read GetEnabled write SetEnabled;
{* Enabled usually used to decide if control can get keyboard focus
or been clicked by mouse. }
procedure EnableChildren( Enable, Recursive: Boolean );
{* Enables (Enable = TRUE) or disables (Enable = FALSE) all the children
of the control. If Recursive = TRUE then all the children of all the
children are enabled or disabled recursively. }
property Visible: Boolean read Get_Visible write SetVisible;
{* Obvious. }
property ToBeVisible: Boolean read GetToBeVisible;
{* Returns True, if a control is supposed to be visible when its
form is showing. Thus is, True is returned if either control
is Visible or hidden, but marked with flag fCreateHidden. }
property CreateVisible: Boolean read fCreateVisible write fCreateVisible;
{* False by default. If You want your form to be created visible and
flick due creation, set it to True. This does not affect size of
executable anyway. }
property Align: TControlAlign read FAlign write Set_Align;
{* Align style of a control. If this property is not used in your
application, there are no additional code added. Aligning of
controls is made in KOL like in VCL. To align controls when
initially create ones, use "transparent" function SetAlign
("transparent" means that it returns @Self as a result).
|
Note, that it is better not to align combobox caClient, caLeft or
caRight (better way is to place a panel with Border = 0 and
EdgeStyle = esNone, align it as desired and to place a combobox on it
aligning caTop or caBottom). Otherwise, big problems could be under
Win9x/Me, and some delay could occur under any other systems.
|
Do not attempt to align some kinds of controls (like combobox)
caLeft or caRight, this can cause infinite recursion. }
{$ENDIF GDI}
property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
{* Bounding rectangle of the visual. Coordinates are relative
to top left corner of parent's ClientRect, or to top left corner
of screen (for TForm). }
property Left: Integer read GetLeft write SetLeft;
{* Left horizontal position. }
property Top: Integer read GetTop write SetTop;
{* Top vertical position. }
property Width: Integer read GetWidth write SetWidth;
{* Width of TVisual object. }
property Height: Integer read GetHeight write SetHeight;
{* Height of TVisual object. }
property Position: TPoint read GetPosition write Set_Position;
{* Represents top left position of the object. See also BoundsRect. }
{$IFDEF GDI}
property MinWidth: Integer index 0
{$IFDEF F_P} read GetConstraint
{$ELSE DELPHI} read FMinWidth
{$ENDIF F_P/DELPHI} write SetConstraint;
{* Minimal width constraint. }
property MinHeight: Integer index 1
{$IFDEF F_P} read GetConstraint
{$ELSE DELPHI} read FMinHeight
{$ENDIF F_P/DELPHI} write SetConstraint;
{* Minimal height constraint. }
property MaxWidth: Integer index 2
{$IFDEF F_P} read GetConstraint
{$ELSE DELPHI} read FMaxWidth
{$ENDIF F_P/DELPHI} write SetConstraint;
{* Maximal width constraint. }
property MaxHeight: Integer index 3
{$IFDEF F_P} read GetConstraint
{$ELSE DELPHI} read FMaxHeight
{$ENDIF F_P/DELPHI} write SetConstraint;
{* Maximal height constraint. }
{$ENDIF GDI}
function ClientRect: TRect;
{* Client rectangle of TControl. Contrary to VCL, for some
classes (e.g. for graphic controls) can be relative
not to itself, but to top left corner of the parent's ClientRect
rectangle. }
{$IFDEF GDI}
property ClientWidth: Integer read GetClientWidth write SetClientWidth;
{* Obvious. Accessing this property, program forces window latent creation. }
property ClientHeight: Integer read GetClientHeight write SetClientHeight;
{* Obvious. Accessing this property, program forces window latent creation. }
function ControlRect: TRect;
{* Absolute bounding rectangle relatively to nearest
Windowed parent client rectangle (at least to a form, but usually to
a Parent).
Useful while drawing on device context, provided by such
Windowed parent. For form itself is the same as BoundsRect. }
function ControlAtPos( X, Y: Integer; IgnoreDisabled: Boolean ): PControl;
{* Searches control at the given position (relatively to top left
corner of the ClientRect). }
{$ENDIF GDI}
procedure Invalidate;
{* Invalidates rectangle, occupied by the visual (but only if Showing =
True). }
{$IFDEF GDI}
protected
{$IFDEF USE_GRAPHCTLS}
procedure InvalidateWindowed;
procedure InvalidateNonWindowed;
{$ENDIF}
public
procedure InvalidateEx;
{* Invalidates the window and all its children. }
procedure InvalidateNC( Recursive: Boolean );
{* Invalidates the window and all its children including non-client area. }
procedure Update;
{* Updates control's window and calls Update for all child controls. }
procedure BeginUpdate;
{* |<#treeview>
|<#listview>
|<#richedit>
|<#memo>
|<#listbox>
Call this method to stop visual updates of the control until correspondent
EndUpdate called (pairs BeginUpdate - EndUpdate can be nested). }
procedure EndUpdate;
{* See BeginUpdate. }
property Windowed: Boolean read fWindowed write fWindowed;
{* Constantly returns True, if object is windowed (i.e. owns
correspondent window handle). Otherwise, returns False.
|
By now, all the controls are windowed (there are no controls in KOL, which are
emulating window, acually belonging to Parent - like TGraphicControl
in VCL).
|
Writing of this property provided only for internal purposes,
do not change it directly unless you understand well what you do. }
function HandleAllocated: Boolean;
{* Returns True, if window handle is allocated. Has no sense for
non-Windowed objects (but now, the KOL has no non-Windowed controls). }
property MDIClient: PControl read fMDIClient;
{* For MDI forms only: returns MDI client window control, containng all MDI
children. Use this window to send specific messages to rule MDI children. }
{$ENDIF GDI}
property ChildCount: Integer read GetChildCount;//GetChildCountWOMembers;
{* Returns number of commonly accessed child objects (without
MembersCount). }
property Children[ Idx: Integer ]: PControl read GetMembers;
{* Child items of TVisual object. Property is reintroduced here
to separate access to always visible Children[] from restricted
a bit Members[]. }
{$IFDEF GDI}
property MembersCount: Integer read FMembersCount;
{* Returns number of "internal" child objects, which are
not accessible through common Children[] property. }
property Members[ Idx: Integer ]: PControl read GetMembers;
{* Members and children array of the object (first from 0 to
MembersCount-1 are Members[], and Children[] are followed by
them. Usually You do not need to use this list. Use instead
Children[0..ChildCount] property, Members[] is intended for
internal needs of XCL (and in KOL by now Members and Children
actually are the same properties). }
procedure PaintBackground( DC: HDC; Rect: PRect );
{* Is called to paint background in given rectangle. This
method is filling clipped area of the Rect rectangle with
Color, but only if global event Global_OnPaintBkgnd is
not assigned. If assigned, this one is called instead here.
|
This method made public, so it can be called directly to
fill some device context's rectangle. But remember, that
independantly of Rect, top left corner of background piece
will be located so, if drawing is occure into ControlRect
rectangle. }
property WindowedParent: PControl read fParent;
{* Returns nearest windowed parent, the same as Parent. }
{$ENDIF GDI}
function ParentForm: PControl;
{* |<#form>
Returns parent form for a control (of @Self for form itself. }
{$IFDEF GDI}
property ActiveControl: PControl read fCurrentControl write fCurrentControl;
{* }
function Client2Screen( const P: TPoint ): TPoint;
{* Converts the client coordinates of a specified point to screen coordinates. }
function Screen2Client( const P: TPoint ): TPoint;
{* Converts screen coordinates of a specified point to client coordinates. }
function CreateWindow: Boolean; virtual;
{* |<#form>
Creates correspondent window object. Returns True if success (if
window is already created, False is returned). If applied to a form,
all child controls also allocates handles that time.
|
Call this method to ensure, that a hanle is allocated for a form,
an application button or a control. (It is not necessary to do so in
the most cases, even if You plan to work with control's handle directly.
But immediately after creating the object, if You want to pass its
handle to API function, this can be helpful). }
{$ENDIF GDI}
{$IFDEF _X_}
procedure VisualizyWindow; // for _X_, makes actually visible a window and
// all its subwindows recursively, if they are having Visible = TRUE
{$ENDIF _X_}
{$IFDEF GDI}
procedure Close;
{* |<#appbutton>
|<#form>
Closes window. If a window is the main form, this closes application,
terminating it. Also it is possible to call Close method for Applet
window to stop application. }
{$IFDEF USE_MHTOOLTIP}
{$DEFINE public}
{$I KOLMHToolTip.pas}
{$UNDEF public}
{$ENDIF}
property Handle: HWnd read fHandle; //GetHandle;
{* Returns descriptor of system window object. If window is not yet
created, 0 is returned. To allocate handle, call CreateWindow method. }
property ParentWindow: HWnd read GetParentWindow;
{* Returns handle of parent window (not TControl object, but system
window object handle). }
property ClsStyle: DWord read fClsStyle write SetClsStyle;
{* Window class style. Available styles are:
|
|&L=| %1 |
|&E= |
|&N=
- Aligns the window's client area on the byte boundary
(in the x direction) to enhance performance during
drawing operations.
- Aligns a window on a byte boundary (in the x
direction).
- Allocates one device context to be shared by all
windows in the class.
- Sends double-click messages to the window
procedure when the user double-clicks the mouse while the
cursor is within a window belonging to the class.
- Allows an application to create a window of
the class regardless of the value of the hInstance parameter.
You can create a global class by creating
the window class in a dynamic-link library (DLL) and listing the
name of the DLL in the registry under specific keys.
- Redraws the entire window if a movement or
size adjustment changes the width of the client area.
- Disables the Close command on the System menu.
- Allocates a unique device context for each window
in the class.
- Sets the clipping region of the child window to
that of the parent window so that the child can draw on the parent.
- Saves, as a bitmap, the portion of the screen
image obscured by a window. Windows uses the saved bitmap to re-create
the screen image when the window is removed.
- Redraws the entire window if a movement or size
adjustment changes the height of the client area.
|
For more info, see Win32.hlp (keyword 'WndClass');
}
{$IFDEF GRAPHCTL_XPSTYLES}
property edgeStyle : TEdgeStyle read fEdgeStyle write SetEdgeStyle;
{$ENDIF}
property Style: DWord read fStyle write SetStyle;
{* Window styles. Available styles are:
|
Creates a window that has a thin-line border.
Creates a window that has a title bar (includes the
WS_BORDER style).
Creates a child window. This style cannot be used with
the WS_POPUP style.
Same as the WS_CHILD style.
Excludes the area occupied by child windows
when drawing occurs within the parent window. This style is used
when creating the parent window.
Clips child windows relative to each other;
that is, when a particular child window receives a WM_PAINT message,
the WS_CLIPSIBLINGS style clips all other overlapping child windows
out of the region of the child window to be updated. If
WS_CLIPSIBLINGS is not specified and child windows overlap, it is
possible, when drawing within the client area of a child window,
to draw within the client area of a neighboring child window.
Creates a window that is initially disabled. A
disabled window cannot receive input from the user.
Creates a window that has a border of a style
typically used with dialog boxes. A window with this style cannot
have a title bar.
Specifies the first control of a group of controls.
The group consists of this first control and all controls defined
after it, up to the next control with the WS_GROUP style.
The first control in each group usually has the WS_TABSTOP
style so that the user can move from group to group. The user
can subsequently change the keyboard focus from one control in
the group to the next control in the group by using the direction
keys.
Creates a window that has a horizontal scroll bar.
Creates a window that is initially minimized. Same as
the WS_MINIMIZE style.
Creates a window that is initially maximized.
Creates a window that has a Maximize button.
Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU
style must also be specified.
Creates a window that is initially minimized.
Same as the WS_ICONIC style.
Creates a window that has a Minimize button.
Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU
style must also be specified.
Creates an overlapped window. An overlapped
window has a title bar and a border. Same as the WS_TILED style.
Creates an overlapped window with the
WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME, WS_MINIMIZEBOX,
and WS_MAXIMIZEBOX styles. Same as the WS_TILEDWINDOW style.
Creates a pop-up window. This style cannot be used with
the WS_CHILD style.
Creates a pop-up window with WS_BORDER,
WS_POPUP, and WS_SYSMENU styles. The WS_CAPTION and WS_POPUPWINDOW
styles must be combined to make the window menu visible.
Creates a window that has a sizing border. Same as the
WS_THICKFRAME style.
Creates a window that has a window-menu on its title
bar. The WS_CAPTION style must also be specified.
Specifies a control that can receive the keyboard focus
when the user presses the TAB key. Pressing the TAB key changes
the keyboard focus to the next control with the WS_TABSTOP style.
Creates a window that has a sizing border.
Same as the WS_SIZEBOX style.
Creates an overlapped window. An overlapped window has
a title bar and a border. Same as the WS_OVERLAPPED style.
Creates an overlapped window with the
WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME,
WS_MINIMIZEBOX, and WS_MAXIMIZEBOX styles. Same as the
WS_OVERLAPPEDWINDOW style.
Creates a window that is initially visible.
Creates a window that has a vertical scroll bar.
|
See also Win32.hlp (topic CreateWindow).
}
property ExStyle: DWord read fExStyle write SetExStyle;
{* Extra window styles. Available flags are following:
|
Specifies that a window created with this style
accepts drag-drop files.
Forces a top-level window onto the taskbar
when the window is minimized.
Specifies that a window has a border with a
sunken edge.
Includes a question mark in the title bar of
the window. When the user clicks the question mark, the cursor
changes to a question mark with a pointer. If the user then clicks
a child window, the child receives a WM_HELP message. The child
window should pass the message to the parent window procedure,
which should call the WinHelp function using the HELP_WM_HELP
command. The Help application displays a pop-up window that
typically contains help for the child window.WS_EX_CONTEXTHELP
cannot be used with the WS_MAXIMIZEBOX or WS_MINIMIZEBOX styles.
Allows the user to navigate among the child
windows of the window by using the TAB key.
Creates a window that has a double border;
the window can, optionally, be created with a title bar by
specifying the WS_CAPTION style in the dwStyle parameter.
Window has generic "left-aligned" properties. This
is the default.
If the shell language is Hebrew, Arabic, or
another language that supports reading order alignment, the
vertical scroll bar (if present) is to the left of the client
area. For other languages, the style is ignored and not treated
as an error.
The window text is displayed using Left to
Right reading-order properties. This is the default.
Creates an MDI child window.
Specifies that a child window created
with this style does not send the WM_PARENTNOTIFY message to its
parent window when it is created or destroyed.
Combines the WS_EX_CLIENTEDGE and
WS_EX_WINDOWEDGE styles.
Combines the WS_EX_WINDOWEDGE,
WS_EX_TOOLWINDOW, and WS_EX_TOPMOST styles.
Window has generic "right-aligned" properties.
This depends on the window class. This style has an effect only
if the shell language is Hebrew, Arabic, or another language that
supports reading order alignment; otherwise, the style is
ignored and not treated as an error.
Vertical scroll bar (if present) is to the
right of the client area. This is the default.
If the shell language is Hebrew, Arabic, or
another language that supports reading order alignment, the
window text is displayed using Right to Left reading-order
properties. For other languages, the style is ignored and not
treated as an error.
Creates a window with a three-dimensional
border style intended to be used for items that do not accept
user input.
Creates a tool window; that is, a window
intended to be used as a floating toolbar. A tool window has
a title bar that is shorter than a normal title bar, and the
window title is drawn using a smaller font. A tool window does
not appear in the taskbar or in the dialog that appears when
the user presses ALT+TAB.
Specifies that a window created with this style
should be placed above all non-topmost windows and should stay
above them, even when the window is deactivated. To add or remove
this style, use the SetWindowPos function.
Specifies that a window created with this
style is to be transparent. That is, any windows that are
beneath the window are not obscured by the window. A window
created with this style receives WM_PAINT messages only after
all sibling windows beneath it have been updated.
Specifies that a window has a border with
a raised edge.
|
See also Win32.hlp (topic CreateWindowEx).
}
property Cursor: HCursor read fCursor write SetCursor;
{* Current cursor. For most of controls, sets initially to IDC_ARROW. See
also ScreenCursor. }
procedure CursorLoad( Inst: Integer; ResName: PKOLChar );
{* Loads Cursor from the resource. See also comments for Icon property. }
property Icon: HIcon read {$IFDEF SMALLEST_CODE} fIcon {$ELSE} GetIcon {$ENDIF}
write SetIcon;
{* |<#appbutton>
|<#form>
Icon. By default, icon of the Applet is used. To load icon from the
resource, use IconLoad or IconLoadCursor method - this is more correct, because
in such case a special flag is set to prevent attempts to destroy
shared icon object in the destructor of the control. }
procedure IconLoad( Inst: Integer; ResName: PKOLChar );
{* |<#appbutton>
|<#form>
See Icon property. }
procedure IconLoadCursor( Inst: Integer; ResName: PKOLChar );
{* |<#appbutton>
|<#form>
Loads Icon from the cursor resource. See also Icon property. }
property Menu: HMenu read fMenu write SetMenu;
{* Menu (or ID of control - for standard GUI controls). }
property HelpContext: Integer read fHelpContext write SetHelpContext;
{* Help context. }
function AssignHelpContext( Context: Integer ): PControl;
{* Assigns HelpContext and returns @ Self (can be used in initialization
of a control in a chain of "transparent" calls). }
procedure CallHelp( Context: Integer; CtxCtl: PControl {; CtlID: Integer} );
{* Method of a form or Applet. Call it to show help with the given context
ID. If the Context = 0, help contents is displayed. By default,
WinHelp is used. To allow using HtmlHelp, call AssignHtmlHelp global
function. When WinHelp used, HelpPath variable can be assigned directly.
If HelpPath variable is not assigned, application name
(and path) is used, with extension replaced to '.hlp'. }
property HelpPath: KOLString read GetHelpPath write SetHelpPath;
{* Property of a form or an Applet. Change it to provide custom path to
WinHelp format help file. If HtmlHelp used, call global procedure
AssignHtmlHelp instead. }
property OnHelp: TOnHelp read fOnHelp write fOnHelp;
{* An event of a form, it is called when F1 pressed or help topic requested
by any other way. To prevent showing help, nullify Sender. Set Popup to
TRUE to provide showing help in a pop-up window. It is also possible to
change Context dynamically. }
{$ENDIF GDI}
property Caption: KOLString read GetCaption write SetCaption;
{* |<#appbutton>
|<#form>
|<#button>
|<#bitbtn>
|<#label>
|<#wwlabel>
|<#3dlabel>
Caption of a window. For standard Windows buttons, labels and so on
not a caption of a window, but text of the window. }
property Text: KOLString read GetCaption write SetCaption;
{* |<#edit>
|<#memo>
The same as Caption. To make more convenient with Edit controls. For
Rich Edit control, use property RE_Text. }
{$IFDEF GDI}
property SelStart: Integer read GetSelStart write SetSelStart;
{* |<#edit>
|<#memo>
|<#richedit>
Start of selection (editbox - character position). }
property SelLength: Integer read GetSelLength write SetSelLength;
{* |<#edit>
|<#memo>
|<#richedit>
|<#listbox>
|<#listview>
Length of selection (editbox - number of characters selected, multiselect
listbox or listview - number of items selected).
|
Note, that for combobox and single-select listbox it always returns 0
(though for single-select listview, returns 1, if there is an item
selected).
|
It is possible to set SelLength only for memo and richedit controls. }
property Selection: KOLString read GetSelection write SetSelection;
{* |<#edit>
|<#memo>
|<#richedit>
Selected text (editbox, richedit) as string. Can be useful to replace
selection. For rich edit, use RE_Text[ reText, TRUE ], if you want to
read correctly characters from another locale then ANSI only. }
procedure SelectAll;
{* |<#edit>
|<#memo>
|<#richedit>
Makes all the text in editbox or RichEdit, or all items in listbox
selected. }
procedure ReplaceSelection( const Value: KOLString; aCanUndo: Boolean );
{* |<#edit>
|<#memo>
|<#richedit>
Replaces selection (in edit, RichEdit). Unlike assigning new value
to Selection property, it is possible to specify, if operation can
be undone. }
procedure DeleteLines( FromLine, ToLine: Integer );
{* |<#edit>
|<#memo>
|<#richedit>
Deletes lines from FromLine to ToLine (inclusively, i.e. 0 to 0 deletes
one line with index 0). Current selection is restored as possible. }
property CurIndex: Integer read GetCurIndex write SetCurIndex;
{* |<#listbox>
|<#combo>
|<#toolbar>
Index of current item (for listbox, combobox) or button index pressed
or dropped down (for toolbar button, and only in appropriate event
handler call).
|
You cannot use it to set or remove a selection in a multiple-selection
list box, so you should set option loNoExtendSel to true.
|
In OnClick event handler, CurIndex has not yet changed for listbox or combobox.
Use OnSelChange to respond to selection changes. }
property Count: Integer read GetItemsCount write SetItemsCount;
{* |<#listbox>
|<#combo>
|<#listview>
|<#treeview>
|<#edit>
|<#memo>
|<#richedit>
|<#toolbar>
Number of items (listbox, combobox, listview) or lines (multiline
editbox, richedit control) or buttons (toolbar). It is possible to
assign a value to this property only for listbox control with loNoData
style and for list view control with lvoOwnerData style (virtual list
box and list view). }
property Items[ Idx: Integer ]: KOLString read GetItems write SetItems;
{* |<#edit>
|<#listbox>
|<#combo>
|<#memo>
|<#richedit>
Obvious. Used with editboxes, listbox, combobox. With list view, use
property LVItems instead. }
function Item2Pos( ItemIdx: Integer ): DWORD;
{* |<#edit>
|<#memo>
Only for edit controls: converts line index to character position. }
function Pos2Item( Pos: Integer ): DWORD;
{* |<#edit>
|<#memo>
Only for edit controls: converts character position to line index. }
function SavePosition: TEditPositions;
{* |<#edit>
|<#memo>
Only for edit controls: saves current editor selection and scroll
positions. To restore position, use RestorePosition with a structure,
containing saved position as a parameter. }
procedure RestorePosition( const p: TEditPositions );
{* |<#edit>
|<#memo>
Call RestorePosition with a structure, containing saved position
as a parameter (this structure filled in in SavePosition method).
If you set RestoreScroll to FALSE, only selection is restored,
without scroll position. }
procedure UpdatePosition( var p: TEditPositions; FromPos,
CountInsertDelChars, CountInsertDelLines: Integer );
{* |<#edit>
|<#memo>
If you called SavePosition and then make some changes in the edit control,
calling RestorePosition will fail if chages are affecting selection size.
The problem can be solved updating saved position info using this method.
Pass a count of inserted characters and lines as a positive number and a
count of deleted characters as a negative number here. CountInsertDelLines
is optional paramters: if you do not specify it, only selection is fixed.
}
function EditTabChar: PControl;
{* |<#edit>
|<#memo>
Call this method (once) to provide insertion of tab character (code #9)
when tab key is pressed on keyboard. }
function IndexOf( const S: KOLString ): Integer;
{* |<#listbox>
|<#combobox>
|<#tabcontrol>
Works for the most of control types, though some of those
have its own methods to search given item. If a control is not
list box or combobox, item is finding by enumerating all
the Items one by one. See also SearchFor method. }
function SearchFor( const S: KOLString; StartAfter: Integer; Partial: Boolean ): Integer;
{* |<#listbox>
|<#combobox>
|<#tabcontrol>
Works for the most of control types, though some of those
have its own methods to search given item. If a control is not
list box or combobox, item is finding by enumerating all
the Items one by one. See also IndexOf method. }
property ItemSelected[ ItemIdx: Integer ]: Boolean read GetItemSelected write SetItemSelected;
{* |<#edit>
|<#memo>
|<#listbox>
|<#combo>
|<#listview>
Returns True, if a line (in editbox) or an item (in listbox, combobox,
listview) is selected.
Can be set only for listboxes. For listboxes, which are not multiselect, and
for combo lists, it is possible only to set to True, to change selection. }
property ItemData[ Idx: Integer ]: DWORD read GetItemData write SetItemData;
{* |<#listbox>
|<#combo>
Access to user-defined data, associated with the item of a list box and
combo box. }
property OnDropDown: TOnEvent read fOnDropDown write fOnDropDown;
{* |<#combo>
|<#toolbar>
Is called when combobox is dropped down (or drop-down button of
toolbar is pressed - see also OnTBDropDown). }
property OnCloseUp: TOnEvent read fOnCloseUp write fOnCloseUp;
{* |<#combo>
Is called when combobox is closed up. When drop down list is closed
because user pressed "Escape" key, previous selection is restored.
To test if it is so, call GetKeyState( VK_ESCAPE ) and check, if
negative value is returned (i.e. Escape key is pressed when event
handler is calling). }
property DroppedWidth: Integer read FDroppedWidth write SetDroppedWidth;
{* |<#combo>
Allows to change width of dropped down items list for combobox (only!)
control. }
property DroppedDown: Boolean read fDropped write SetDroppedDown;
{* |<#combo>
Dropped down state for combo box. Set it to TRUE or FALSE to change
dropped down state. }
procedure AddDirList( const Filemask: KOLString; Attrs: DWORD );
{* |<#listbox>
|<#combo>
Can be used only with listbox and combobox - to add directory list items,
filtered by given Filemask (can contain wildcards) and Attrs. Following
flags can be combined in Attrs:
|
|&L=| %1 |
Include archived files.
Includes subdirectories. Subdirectory names are
enclosed in square brackets ([ ]).
Includes drives. Drives are listed in the form [-x-],
where x is the drive letter.
Includes only files with the specified attributes.
By default, read-write files are listed even if DDL_READWRITE is
not specified. Also, this flag needed to list directories only,
etc.
Includes hidden files.
Includes read-only files.
Includes read-write files with no additional
attributes.
Includes system files.
|
If the listbox is sorted, directory items will be sorted (alpabetically). }
property OnBitBtnDraw: TOnBitBtnDraw read fOnBitBtnDraw write fOnBitBtnDraw;
{* |<#bitbtn>
Special event for BitBtn. Using it, it is possible to provide
additional effects, such as highlighting button text (by changing
its Font and other properties). If the handler returns True, it is
supposed that it made all drawing and there are no further drawing
occure. }
property BitBtnDrawMnemonic: Boolean read FBitBtnDrawMnemonic write SetBitBtnDrawMnemonic;
{* |<#bitbtn>
Set this property to TRUE to provide correct drawing of bit btn control
caption with '&' characters (to remove such characters, and underline
follow ones). }
property TextShiftX: Integer read fTextShiftX write fTextShiftX;
{* |<#bitbtn>
Horizontal shift for bitbtn text when the bitbtn is pressed. }
property TextShiftY: Integer read fTextShiftY write fTextShiftY;
{* |<#bitbtn>
Vertical shift for bitbtn text when the bitbtn is pressed. }
property BitBtnImgIdx: Integer read GetBitBtnImgIdx write SetBitBtnImgIdx;
{* |<#bitbtn>
BitBtn image index for the first image in list view, used as bitbtn
image. It is used only in case when BitBtn is created with bboImageList
option. }
property BitBtnImgList: THandle read GetBitBtnImageList write SetBitBtnImageList;
{* |<#bitbtn>
BitBtn Image list. Assign image list handle to change it. }
function SetButtonIcon( aIcon: HIcon ): PControl;
{* |<#button>
Sets up button icon image and changes its styles. Returns button itself. }
function SetButtonBitmap( aBmp: HBitmap ): PControl;
{* |<#button>
Sets up button icon image and changes its styles. Returns button itself. }
property OnMeasureItem: TOnMeasureItem read fOnMeasureItem write SetOnMeasureItem;
{* |<#combo>
|<#listbox>
|<#listview>
This event is called for owner-drawn controls, such as list box, combo box,
list view with appropriate owner-drawn style. For fixed item height controls
(list box with loOwnerDrawFixed style, combobox with coOwnerDrawFixed and
list view with lvoOwnerDrawFixed option) this event is called once. For
list box with loOwnerDrawVariable style and for combobox with coOwnerDrawVariable
style this event is called for every item. }
property DefaultBtn: Boolean index 13
{$IFDEF F_P} read GetDefaultBtn
{$ELSE DELPHI} read fDefaultBtn
{$ENDIF F_P/DELPHI} write SetDefaultBtn;
{* |<#button>
|<#bitbtn>
Set this property to true to make control clicked when ENTER key is pressed.
This property uses OnMessage event of the parent form, storing it into
fOldOnMessage field and calling in chain. So, assign default button
after setting OnMessage event for the form. }
property CancelBtn: Boolean index 27
{$IFDEF F_P} read GetDefaultBtn
{$ELSE DELPHI} read fCancelBtn
{$ENDIF F_P/DELPHI} write SetDefaultBtn;
{* |<#button>
|<#bitbtn>
Set this property to true to make control clicked when escape key is pressed.
This property uses OnMessage event of the parent form, storing it into
fOldOnMessage field and calling in chain. So, assign cancel button
after setting OnMessage event for the form. }
function AllBtnReturnClick: PControl;
{* Call this method for a form or any its control to provide clicking
a focused button when ENTER pressed. By default, a button can be clicked
only by SPACE key from the keyboard, or by mouse. }
property IgnoreDefault: Boolean read fIgnoreDefault write fIgnoreDefault;
{* Change this property to TRUE to ignore default button reaction on
press ENTER key when a focus is grabbed of the control. Default
value is different for different controls. By default, DefaultBtn
ignored in memo, richedit (even if read-only). }
{$ENDIF GDI}
property Color: TColor read fColor write SetCtlColor;
{* Property Color is one of the most common for all visual
elements (like form, control etc.) Please note, that standard GUI button
can not change its color and the most characteristics of the Font. Also,
standard button can not become Transparent. Use bitbtn for such purposes.
Also, changing Color property for some kinds of control has no effect (rich edit,
list view, tree view, etc.). To solve this, use native (for such controls)
color property, or call Perform method with appropriate message to set the
background color. }
property Font: PGraphicTool read GetFont;
{* If the Font property is not accessed, correspondent TGraphicTool object
is not created and its methods are not included into executable. Leaving
properties Font and Brush untouched can economy executable size a lot. }
{$IFDEF GDI}
property Brush: PGraphicTool read GetBrush;
{* If not accessed, correspondent TGraphicTool object is not created
and its methods are not referenced. See also note on Font property. }
property Ctl3D: Boolean read fCtl3D write SetCtl3D;
{* Inheritable from parent controls to child ones. }
procedure Show;
{* |<#appbutton>
|<#form>
Makes control visible and activates it. }
function ShowModal: Integer;
{* |<#form>
Can be used only with a forms to show it modal. See also global function
ShowMsgModal.
|
To use a form as a modal, it is possible to make it either auto-created
or dynamically created. For a first case, You (may be prefer to hide a
form after showing it as a modal:
!
! procedure TForm1.Button1Click( Sender: PObj );
! begin
! Form2.Form.ShowModal;
! Form2.Form.Hide;
! end;
!
Another way is to create modal form just before showing it (this economies
system resources):
!
! procedure TForm1.Button1Click( Sender: PObj );
! begin
! NewForm2( Form2, Applet );
! Form2.Form.ShowModal;
! Form2.Form.Free; // Never call Form2.Free or Form2.Form.Close
! end; // but always Form2.Form.Free; (!)
!
In samples above, You certainly can place any wished code before and after
calling ShowModal method.
|
Do not forget that if You have more than a single form in your project,
separate Applet object should be used.
|
See also ShowModalEx.
}
function ShowModalParented( const AParent: PControl ): Integer;
{* by Alexander Pravdin. The same as ShowModal, but with a certain
form as a parent. }
function ShowModalEx: Integer;
{* The same as ShowModal, but all the windows of current thread are
disabled while showing form modal. This is useful if KOL form from
a DLL is used modally in non-KOL application. }
property ModalResult: Integer read fModalResult write
{$IFDEF USE_SETMODALRESULT}
SetModalResult;
{$ELSE}
fModalResult;
{$ENDIF}
{* |<#form>
Modal result. Set it to value<>0 to stop modal dialog. By agreement,
value 1 corresponds 'OK', 2 - 'Cancel'. But it is totally by decision
of yours how to interpret this value. }
property Modal: Boolean read GetModal;
{* |<#form>
TRUE, if the form is shown modal. }
property ModalForm: PControl read fModalForm write fModalForm;
{* |<#form>
|<#appbutton>
Form currently shown modal from this form or from Applet. }
procedure Hide;
{* |<#appbutton>
|<#form>
Makes control hidden. }
property OnShow: TOnEvent read FOnShow write SetOnShow;
{* Is called when a control or form is to be shown. This event is not fired
for a form, if its WindowState initially is set to wsMaximized or
wsMinimized. This behaviour is by design (the window does not receive
WM_SHOW message in such case). }
property OnHide: TOnEvent read FOnHide write SetOnHide;
{* Is called when a control or form becomes hidden. }
property WindowState: TWindowState read GetWindowState write SetWindowState;
{* |<#form>
Window state. }
{$ENDIF GDI}
property Canvas: PCanvas read GetCanvas;
{* |<#paintbox>
Placeholder for Canvas: PCanvas. But in KOL, it is possible to
create applets without canvases at all. To do so, avoid using
Canvas and use DC directly (which is passed in OnPaint event). }
{$IFDEF GDI}
function CallDefWndProc( var Msg: TMsg ): Integer;
{* Function to be called in WndProc method to redirect message handling
to default window procedure. }
function DoSetFocus: Boolean;
{* Sets focus for Enabled window. Returns True, if success. }
procedure MinimizeNormalAnimated;
{* |<#form>
Apply this method to a main form (not to another form or Applet,
even when separate Applet control is not used and main form matches it!).
This provides normal animated visual minimization for the application.
It therefore has no effect, if animation during minimize/resore is
turned off by user.
|
Applying this method also provides for the main form (only for it)
correct restoring the form maximized if it was maximized while
minimizing the application. See also RestoreNormalMaximized method. }
procedure RestoreNormalMaximized;
{* |<#form>
Apply to any form for which it is important to restore it maximized
when the application was minimizing while such form was maximized.
If the method MinimizeNormalAnimated was called for the main form,
then the correct behaviour is already provided for the main form, so
in such case it is no more necessary to call also this method, but
calling it therefore is not an error. }
property OnMessage: TOnMessage read fOnMessage write fOnMessage;
{* |<#appbutton>
|<#form>
Is called for every message processed by TControl object. And for
Applet window, this event is called also for all messages, handled by
all its child windows (forms). }
{$ENDIF GDI}
function IsMainWindow: Boolean;
{* |<#appbutton>
|<#form>
Returns True, if a window is the main in application (created first
after the Applet, or matches the Applet). }
property IsApplet: Boolean read FIsApplet;
{* Returns true, if the control is created using NewApplet (or CreateApplet).
}
property IsForm: Boolean read fIsForm;
{* Returns True, if the object is form window. }
property IsMDIChild: Boolean read fIsMDIChild;
{* Returns TRUE, if the object is MDI child form. In such case, IsForm also
returns TRUE. }
property IsControl: Boolean read fIsControl;
{* Returns True, is the control is control (not form or applet). }
property IsButton: Boolean read fIsButton;
{* Returns True, if the control is button-like or containing buttons (button,
bitbtn, checkbox, radiobox, toolbar). }
{$IFDEF GDI}
function ProcessMessage: Boolean;
{* |<#appbutton>
Processes one message. See also ProcessMessages. }
procedure ProcessMessages;
{* |<#appbutton>
Processes pending messages during long cycle of calculation,
allowing to window to be repainted if needed and to respond to other
messages. But if there are no such messages, your application can be
stopped until such one appear in messages queue. To prevent such
situation, use method ProcessPendingMessages instead. }
procedure ProcessMessagesEx;
{* Version of ProcessMessages, which works always correctly, even if
the application is minimized or background. }
procedure ProcessPendingMessages;
{* |<#appbutton>
Similar to ProcessMessages, but without waiting of
message in messages queue. I.e., if there are no pending
messages, this method immediately returns control to your
code. This method is better to call during long cycle of
calculation (then ProcessMessages). }
procedure ProcessPaintMessages;
{* }
procedure WaitAndProcessMessages;
{* }
function WndProc( var Msg: TMsg ): Integer; virtual; //{$IFNDEF DEBUG_MCK} virtual; {$ENDIF}
{* Responds to all Windows messages, posted (sended) to the
window, before all other proceeding. You can override it in
derived controls, but in KOL there are several other ways
to control message flow of existing controls without deriving
another costom controls for only such purposes. See OnMessage,
AttachProc. }
property HasBorder: Boolean read GetHasBorder write SetHasBorder;
{* |<#form>
Obvious. Form-aware. }
property HasCaption: Boolean read GetHasCaption write SetHasCaption;
{* |<#form>
Obvious. Form-aware. }
property CanResize: Boolean read GetCanResize write SetCanResize;
{* |<#form>
Obvious. Form-aware. }
property StayOnTop: Boolean read GetStayOnTop write SetStayOnTop;
{* |<#form>
Obvious. Form-aware, but can be applied to controls. }
property Border: Integer read fMargin write fMargin;
{* |<#form>
Distance between edges and child controls and between child
controls by default (if methods PlaceRight, PlaceDown, PlaceUnder,
ResizeParent, ResizeParentRight, ResizeParentBottom are called).
|
Originally was named Margin, now I recommend to use the name 'Border' to
avoid confusion with MarginTop, MarginBottom, MarginLeft and
MarginRight properties.
|
Initial value is always 2. Border property is used in realigning
child controls (when its Align property is not caNone), and value
of this property determines size of borders between edges of children
and its parent and between aligned controls too.
|
See also properties MarginLeft, MarginRight, MarginTop, MarginBottom. }
function SetBorder( Value: Integer ): PControl;
{* Assigns new Border value, and returns @ Self. }
property Margin: Integer read fMargin write fMargin;
{* |<#form>
Old name for property Border. }
property MarginTop: Integer index 1
{$IFDEF F_P} read GetClientMargin
{$ELSE DELPHI} read fClientTop
{$ENDIF F_P/DELPHI} write SetClientMargin;
{* Additional distance between true window client top and logical top of
client rectangle. This value is added to Top of rectangle, returning
by property ClientRect. Together with other margins and property Border,
this property allows to change view of form for case, that Align property
is used to align controls on parent (it is possible to provide some
distance from child controls to its parent, and between child controls.
|
Originally this property was introduced to compensate incorrect
ClientRect property, calculated for some types of controls.
|
See also properties Border, MarginBottom, MarginLeft, MarginRight. }
property MarginBottom: Integer index 2
{$IFDEF F_P} read GetClientMargin
{$ELSE DELPHI} read fClientBottom
{$ENDIF F_P/DELPHI} write SetClientMargin;
{* The same as MarginTop, but a distance between true window Bottom of
client rectangle and logical bottom one. Take in attention, that this value
should be POSITIVE to make logical bottom edge located above true edge.
|
See also properties Border, MarginTop, MarginLeft, MarginRight. }
property MarginLeft: Integer index 3
{$IFDEF F_P} read GetClientMargin
{$ELSE DELPHI} read fClientLeft
{$ENDIF F_P/DELPHI} write SetClientMargin;
{* The same as MarginTop, but a distance between true window Left of
client rectangle and logical left edge.
|
See also properties Border, MarginTop, MarginRight, MarginBottom. }
property MarginRight: Integer index 4
{$IFDEF F_P} read GetClientMargin
{$ELSE DELPHI} read fClientRight
{$ENDIF F_P/DELPHI} write SetClientMargin;
{* The same as MarginLeft, but a distance between true window Right of
client rectangle and logical bottom one. Take in attention, that this value
should be POSITIVE to make logical right edge located left of true edge.
|
See also properties Border, MarginTop, MarginLeft, MarginBottom. }
property Tabstop: Boolean read fTabstop write fTabstop;
{* True, if control can be focused using tabulating between controls.
Set it to False to make control unavailable for keyboard, but only
for mouse. }
property TabOrder: Integer read fTabOrder write SetTabOrder;
{* Order of tabulating of controls. Initially, TabOrder is equal to
creation order of controls. If TabOrder changed, TabOrder of
all controls with not less value of one is shifted up. To place
control before another, assign TabOrder of one to another.
For example:
! Button1.TabOrder := EditBox1.TabOrder;
In code above, Button1 is placed just before EditBox1 in tabulating
order (value of TabOrder of EditBox1 is incremented, as well as
for all follow controls). }
property Focused: Boolean read GetFocused write SetFocused;
{* True, if the control is current on form (but check also, what form
itself is focused). For form it is True, if the form is active (i.e.
it is foreground and capture keyboard). Set this value to True to make
control current and focused (if applicable). }
function BringToFront: PControl;
{* Changes z-order of the control, bringing it to the topmost level. }
function SendToBack: PControl;
{* Changes z-order of the control, sending it to the back of siblings. }
{$ENDIF GDI}
property TextAlign: TTextAlign read GetTextAlign write SetTextAlign;
{* |<#label>
|<#panel>
|<#button>
|<#bitbtn>
|<#edit>
|<#memo>
Text horizontal alignment. Applicable to labels, buttons,
multi-line edit boxes, panels. }
property VerticalAlign: TVerticalAlign read GetVerticalAlign write SetVerticalAlign;
{* |<#button>
|<#label>
|<#panel>
Text vertical alignment. Applicable to buttons, labels and panels. }
{$IFDEF GDI}
property WordWrap: Boolean read fWordWrap write fWordWrap;
{* TRUE, if this is a label, created using NewWordWrapLabel. }
property ShadowDeep: Integer read FShadowDeep write SetShadowDeep;
{* |<#3dlabel>
Deep of a shadow (for label effect only, created calling NewLabelEffect). }
property CannotDoubleBuf: Boolean read fCannotDoubleBuf write fCannotDoubleBuf;
{* }
property DoubleBuffered: Boolean read fDoubleBuffered write SetDoubleBuffered;
{* Set it to true for some controls, which are flickering in repainting
(like label effect). Slow, and requires additional code. This property
is inherited by all child controls.
|
Note: RichEdit control can not become DoubleBuffered. }
function DblBufTopParent: PControl;
{* Returns the topmost DoubleBuffered Parent control. }
property Transparent: Boolean read fTransparent write SetTransparent;
{* Set it to true to get special effects. Transparency also uses
DoubleBuffered and inherited by child controls.
|
Please note, that some controls can not be shown properly, when
Transparent is set to True for it. If You want to make edit control
transparent (e.g., over gradient filled panel), handle its OnChanged
property and call there Invalidate to provide repainting of edit
control content. Note also, that for RichEdit control property
Transparent has no effect (as well as DoubleBuffered). But special
property RE_Transparent is designed especially for RichEdit control
(it works fine, but with great number of flicks while resizing
of a control). Another note is about Edit control. To allow editing
of transparent edit box, it is necessary to invalidate it for
every pressed character. Or, use Ed_Transparent property instead. }
property Ed_Transparent: Boolean read fTransparent write EdSetTransparent;
{* |<#edit>
|<#memo>
Use this property for editbox to make it really Transparent. Remember,
that though Transparent property is inherited by child controls from
its parent, this is not so for Ed_Transparent. So, it is necessary to
set Ed_Transparent to True for every edit control explicitly. }
property AlphaBlend: Integer read fAlphaBlend write SetAlphaBlend;
{* |<#form>
If assigned to 0..254, makes window (form or control) semi-transparent
(Win2K only).
|
Depending on value assigned, it is possible to adjust transparency
level ( 0 - totally transparent, 255 - totally opaque). }
function MouseTransparent: PControl;
{* Call this method to set up mouse transparent control (which always
returns HTTRANSPARENT in responce to WM_NCHITTEST). This function
returns a pointer to a control itself. }
property LookTabKeys: TTabKeys read fLookTabKeys write fLookTabKeys;
{* Set of keys which can be used as tabulation keys in a control. }
procedure GotoControl( Key: DWORD );
{* |<#form>
Emulates tabulation key press w/o sending message to current control.
Can be applied to a form or to any its control. If VK_TAB is used,
state of shift kay is checked in: if it is pressed, tabulate is in
backward direction. }
property SubClassName: KOLString read get_ClassName write set_ClassName;
{* Name of window class - unique for every window class
in every run session of a program. }
protected
procedure SetOnClose( const AOnClose: TOnEventAccept );
procedure SetFormOnClick( const AOnClick: TOnEvent );
public
property OnClose: TOnEventAccept read fOnClose write SetOnClose;
{* |<#form>
|<#applet>
Called before closing the window. It is possible to set Accept
parameter to False to prevent closing the window. This event events
is not called when windows session is finishing (to handle this
event, handle WM_QUERYENDSESSION message, or assign OnQueryEndSession
event to another or the same event handler). }
property OnQueryEndSession: TOnEventAccept read fOnQueryEndSession write SetOnQueryEndSession;
{* |<#form>
|<#applet>
Called when WM_QUERYENDSESSION message come in. It is possible to set Accept
parameter to False to prevent closing the window (in such case session ending
is halted). It is possible to check CloseQueryReason property to find out,
why event occur.
|
To provide normal application close while handling OnQueryEndSession,
call in your code PostQuitMessage( 0 ) or call method Close for the main form,
this is enough to provide all OnClose and OnDestroy handlers to be called. }
property CloseQueryReason: TCloseQueryReason read fCloseQueryReason;
{* Reason why OnClose or OnQueryEndSession called. }
property OnMinimize: TOnEvent index 0
{$IFDEF F_P} read GetOnMinMaxRestore
{$ELSE DELPHI} read fOnMinimize
{$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;
{* |<#form>
Called when window is minimized. }
property OnMaximize: TOnEvent index 8
{$IFDEF F_P} read GetOnMinMaxRestore
{$ELSE DELPHI} read fOnMaximize
{$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;
{* |<#form>
Called when window is maximized. }
property OnRestore: TOnEvent index 16
{$IFDEF F_P} read GetOnMinMaxRestore
{$ELSE DELPHI} read fOnRestore
{$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;
{* |<#form>
Called when window is restored from minimized or maximized state. }
property UpdateRgn: HRgn read fUpdRgn;
{* A handle of update region. Valid only in OnPaint method. You
can use it to improve painting (for speed), if necessary. When
UpdateRgn is obtained in response to WM_PAINT message, value
of the property EraseBackground is used to pass it to the API
function GetUpdateRgn. If UpdateRgn = 0, this means that entire
window should be repainted. Otherwise, You (e.g.) can check
if the rectangle is in clipping region using API function
RectInRegion. }
property EraseBackground: Boolean read fEraseUpdRgn write fEraseUpdRgn;
{* This value is used to pass it to the API function GetUpdateRgn,
when UpadateRgn property is obtained first in responce to WM_PAINT
message. If EraseBackground is set to True, system is responsible
for erasing background of update region before painting. If not
(default), the entire region invalidated should be painted by your
event handler. }
{$ENDIF GDI}
property OnPaint: TOnPaint read fOnPaint write SetOnPaint;
{* Event to set to override standard control painting. Can be applied
to any control (though originally was designed only for paintbox
control). When an event handler is called, it is possible to use
UpdateRgn to examine what parts of window require painting to
improve performance of the painting operation. }
{$IFDEF GDI}
property OnPrePaint: TOnPaint read fOnPrePaint write fOnPrePaint;
{* Only for graphic controls. If you assign it, call Invalidate also. }
property OnPostPaint: TOnPaint read fOnPostPaint write fOnPostPaint;
{* Only for graphic controls. If you assign it, call Invalidate also. }
property OnEraseBkgnd: TOnPaint read fOnEraseBkgnd write SetOnEraseBkgnd;
{* This event allows to override erasing window background in response
to WM_ERASEBKGND message. This allows to add some decorations to
standard controls without overriding its painting in total.
Note: When erase background, remember, that property ClientRect can
return not true client rectangle of the window - use GetClientRect
API function instead. For example:
!
!var BkBmp: HBitmap;
!
!procedure TForm1.KOLForm1FormCreate(Sender: PObj);
!begin
! Toolbar1.OnEraseBkgnd := DecorateToolbar;
! BkBmp := LoadBitmap( hInstance, 'BK1' );
!end;
!
!procedure TForm1.DecorateToolbar(Sender: PControl; DC: HDC);
!var CR: TRect;
!begin
! GetClientRect( Sender.Handle, CR );
! Sender.Canvas.Brush.BrushBitmap := BkBmp;
! Sender.Canvas.FillRect( CR );
!end;
!
}
{$ENDIF GDI}
property OnClick: TOnEvent read fOnClick write
{$IFDEF GDI} fOnClick
{$ELSE _X_} SetOnClick {$ENDIF _X_};
{* |<#button>
|<#checkbox>
|<#radiobox>
|<#toolbar>
Called on click at control. For buttons, checkboxes and radioboxes
is called regadless if control clicked by mouse or keyboard. For toolbar,
the same event is used for all toolbar buttons and toolbar itself.
To determine which toolbar button is clicked, check CurIndex property.
And note, that all the buttons including separator buttons are enumerated
starting from 0. Though images are stored (and prepared) only for
non-separator buttons. And to determine, if toolbar button was clicked
with right mouse button, check RightClick property.
|
This event does not work on a Form, still it is fired in responce to
WM_COMMAND window message mainly rather direct to mouse down. But, if
you want to have OnClick event to be fired on a Form, use (following)
property OnFormClick to assign it. }
{$IFDEF GDI}
property OnFormClick: TOnEvent read fOnClick write SetFormOnClick;
{* |<#form>
Assign you OnClick event handler using this property, if you want it to
be fired in result of mouse click on a form surface. Use to assign the
event only for forms (to avoid doublicated firing the handler).
|
Note: for a form, in case of WM_xDOUBLECLK event, this event is fired
for both clicks. So if you install both OnFormClick and OnMouseDblClk,
handlers will be called in the following sequence for each double click:
OnFormClick; OnMouseDblClk; OnFormClick. }
property RightClick: Boolean read fRightClick;
{* |<#toolbar>
|<#listview>
Use this property to determine which mouse button was clicked
(applicable to toolbar in the OnClick event handler). }
property OnEnter: TOnEvent read fOnEnter write fOnEnter;
{* Called when control receives focus. }
property OnLeave: TOnEvent read fOnLeave write fOnLeave;
{* Called when control looses focus. }
property OnChange: TOnEvent read fOnChange write fOnChange;
{* |<#edit>
|<#memo>
|<#listbox>
|<#combo>
|<#tabcontrol>
Called when edit control is changed, or selection in listbox or
current index in combobox is changed (but if OnSelChanged assigned,
the last is called for change selection). To respond to check/uncheck
checkbox or radiobox events, use OnClick instead. }
property OnSelChange: TOnEvent read fOnSelChange write fOnSelChange;
{* |<#richedit>
|<#listbox>
|<#combo>
|<#treeview>
Called for rich edit control, listbox, combobox or treeview when current selection
(range, or current item) is changed. If not assigned, but OnChange is
assigned, OnChange is called instead. }
property OnResize: TOnEvent read FOnResize write SetOnResize;
{* Called whenever control receives message WM_SIZE (thus is, if
control is resized. }
property OnMove: TOnEvent read FOnMove write SetOnMove;
{* Called whenever control receives message WM_MOVE (i.e. when control is
moved over its parent). }
property OnMoving: TOnEventMoving read FOnMoving write SetOnMoving;
{* Called whenever control receives message WM_MOVE (i.e. when control is
moved over its parent). }
property MinSizePrev: Integer read fSplitMinSize1 write fSplitMinSize1;
{* |<#splitter>
Minimal allowed (while dragging splitter) size of previous control
for splitter (see NewSplitter). }
property SplitMinSize1: Integer read fSplitMinSize1 write fSplitMinSize1;
{* The same as MinSizePrev. }
property MinSizeNext: Integer read fSplitMinSize2 write fSplitMinSize2;
{* |<#splitter>
Minimal allowed (while dragging splitter) size of the rest of parent
of splitter or of SecondControl (see NewSplitter). }
property SplitMinSize2: Integer read fSplitMinSize2 write fSplitMinSize2;
{* The same as MinSizeNext. }
property SecondControl: PControl read fSecondControl write fSecondControl;
{* |<#splitter>
Second control to check (while dragging splitter) if its size not less
than SplitMinSize2 (see NewSplitter). By default, second control is
not necessary, and needed only in rare case when SecondControl can not
be determined automatically to restrict splitter right (bottom) position. }
property OnSplit: TOnSplit read fOnSplit write fOnSplit;
{* |<#splitter>
Called when splitter control is dragging - to allow for
your event handler to decide if to accept new size of
left (top) control, and new size of the rest area of parent. }
property Dragging: Boolean read FDragging;
{* |<#splitter>
True, if splitter control is dragging now by user with left
mouse button. Also, this property can be used to detect if the control
is dragging with mouse (after calling DragStartEx method). }
procedure DragStart;
{* Call this method for a form or control to drag it with left mouse button,
when mouse left button is already down. Dragging is stopped when left mouse
button is released. See also DragStartEx, DragStopEx. }
procedure DragStartEx;
{* Call this method to start dragging the form by mouse. To stop
dragging, call DragStopEx method. (Tip: to detect mouse up event,
use OnMouseUp event of the dragging control). This method can be used
to move any control with the mouse, not only entire form. State of
mouse button is not significant. Determine dragging state of the control
checking its Dragging property. }
procedure DragStopEx;
{* Call this method to stop dragging the form (started by DragStopEx). }
procedure DragItem( OnDrag: TOnDrag );
{* Starts dragging something with mouse. During the process,
callback function OnDrag is called, which allows to control
drop target, change cursor shape, etc. }
property OnKeyDown: TOnKey read fOnKeyDown write SetOnKeyDown;
{* Obvious. }
property OnKeyUp: TOnKey read fOnKeyUp write SetOnKeyUp;
{* Obvious. }
property OnChar: TOnChar read fOnChar write SetOnChar;
{* Deprecated event, use OnKeyChar. }
property OnKeyChar: TOnChar read fOnChar write SetOnChar;
{* Obviuos. }
{$IFDEF SUPPORT_ONDEADCHAR}
property OnKeyDeadChar: TOnChar read fOnDeadChar write SetOnDeadChar;
{* Obviuos. }
{$ENDIF SUPPORT_ONDEADCHAR}
{$ENDIF GDI}
property OnMouseUp: TOnMouse read fOnMouseUp write SetOnMouseUp;
{* Obvious. }
property OnMouseDown: TOnMouse read fOnMouseDown write SetOnMouseDown;
{* Obvious. }
property OnMouseMove: TOnMouse read fOnMouseMove write SetOnMouseMove;
{* Obvious. }
property OnMouseDblClk: TOnMouse read fOnMouseDblClk write SetOnMouseDblClk;
{* Obvious. }
property ThreeButtonPress: Boolean read f3ButtonPress;
{* TRUE, if 3 button press detected. Check this flag in OnMouseDblClk event
handler. If 3rd button click is done for a short period of time after the
double click, the control receives OnMouseDblClk the second time and this
flag is set. (Applicable to the GDK and other Linux systems). }
property OnMouseWheel: TOnMouse read fOnMouseWheel write SetOnMouseWheel;
{* Mouse wheel (up or down) event. In Windows, only focused controls and
controls having scrollbars (or a scrollbar iteself) receive such
message. To get direction and amount of wheel, use typecast:
SmallInt( HiWord( Mouse.Shift ) ). Value 120 corresponds to one wheel
step (-120 - for step back). }
{$IFDEF GDI}
property OnMouseEnter: TOnEvent read fOnMouseEnter write SetOnMouseEnter;
{* Is called when mouse is entered into control. See also OnMouseLeave. }
property OnMouseLeave: TOnEvent read fOnMouseLeave write SetOnMouseLeave;
{* Is called when mouse is leaved control. If this event is assigned,
then mouse is captured on mouse enter event to handle all other
mouse events until mouse cursor leaves the control. }
property OnTestMouseOver: TOnTestMouseOver read fOnTestMouseOver write SetOnTestMouseOver;
{* |<#bitbtn>
Special event, which allows to extend OnMouseEnter / OnMouseLeave
(and also Flat property for BitBtn control). If a handler is assigned
to this event, actual testing whether mouse is in control or not,
is occuring in the handler. So, it is possible to simulate more
careful hot tracking for controls with non-rectangular shape (such
as glyphed BitBtn control). }
property MouseInControl: Boolean read fMouseInControl;
{* |<#bitbtn>
This property can return True only if OnMouseEnter / OnMouseLeave
event handlers are set for a control (or, for BitBtn, property Flat
is set to True. Otherwise, False is returned always. }
property Flat: Boolean read fFlat write SetFlat;
{* |<#bitbtn>
Set it to True for BitBtn, to provide either flat border for a button
or availability of "highlighting" (correspondent to glyph index 4).
|
Note: this can work incorrectly a bit under win95 without comctl32.dll
updated. Therefore, application will launch. To enforce correct working
even under Win95, use your own timer, which event handler checks for
mouse over bitbtn control, e.g.:
! procedure TForm1.Timer1Timer(Sender: PObj);
! var P: TPoint;
! begin
! if not BitBtn1.MouseInControl then Exit;
! GetCursorPos( P );
! P := BitBtn1.Screen2Client( P );
! if not PtInRect( BitBtn1.ClientRect, P ) then
! begin
! BitBtn1.Flat := FALSE;
! BitBtn1.Flat := TRUE;
! end;
! end;
}
property RepeatInterval: Integer read fRepeatInterval write fRepeatInterval;
{* |<#bitbtn>
If this property is set to non-zero, it is interpreted (for BitBtn
only) as an interval in milliseconds between repeat button down events,
which are generated after first mouse or button click and until
button is released. Though, if the button is pressed with keyboard (with
space key), RepeatInterval value is ignored and frequency of repeatitive
clicking is determined by user keyboard settings only. }
function LikeSpeedButton: PControl;
{* |<#button>
|<#bitbtn>
Transparent method (returns control itself). Makes button not focusable. }
function Add( const S: KOLString ): Integer;
{* |<#listbox>
|<#combo>
Only for listbox and combobox. }
function Insert( Idx: Integer; const S: KOLString ): Integer;
{* |<#listbox>
|<#combo>
Only for listbox and combobox. }
procedure Delete( Idx: Integer );
{* |<#listbox>
|<#combo>
Only for listbox and combobox. }
procedure Clear;
{* Clears object content. Has different sense for different controls.
E.g., for label, editbox, button and other simple controls it
assigns empty string to Caption property. For listbox, combobox,
listview it deletes all items. For toolbar, it deletes all buttons.
Et so on. }
property Progress: Integer index ((PBM_SETPOS or $8000) shl 16) or PBM_GETPOS
read GetIntVal write SetIntVal;
{* |<#progressbar>
Only for ProgressBar. }
property MaxProgress: Integer index ((PBM_SETRANGE32 or $8000) shl 16) or PBM_GETRANGE
read GetIntVal write SetMaxProgress;
{* |<#progressbar>
Only for ProgressBar. 100 is the default value. }
property ProgressColor: TColor read fTextColor write SetProgressColor;
{* |<#progressbar>
Only for ProgressBar. }
property ProgressBkColor: TColor read fColor write SetCtlColor; //SetProgressBkColor;
{* |<#progressbar>
Obsolete. Now the same as Color. }
property StatusText[ Idx: Integer ]: PKOLChar read GetStatusText write SetStatusText;
{* |<#form>
Only for forms to set/retrieve status text to/from given status panel.
Panels are enumerated from 0 to 254, 255 is to indicate simple
status bar. Size grip in right bottom corner of status window is
displayed only if form still CanResize.
|
When a status text is set first time, status bar window is created
(always aligned to bottom), and form is resizing to preset client height.
While status bar is showing, client height value is returned without
height of status bar. To remove status bar, call RemoveStatus method for
a form.
|
By default, text is left-aligned within the specified part of a status
window. You can embed tab characters (#9) in the text to center or
right-align it. Text to the right of a single tab character is centered,
and text to the right of a second tab character is right-aligned.
|
If You use separate status bar onto several panels, these automatically
align its widths to the same value (width divided to number of panels).
To adjust status panel widths for every panel, use property StatusPanelRightX.
}
property SimpleStatusText: PKOLChar index 255 read GetStatusText write SetStatusText;
{* |<#form>
Only for forms to set/retrive status text to/from simple status bar.
Size grip in right bottom corner of status window is displayed only
if form CanResize.
|
When status text set first time, (simple) status bar window is created
(always aligned to bottom), and form is resizing to preset client height.
While status bar is showing, client height value is returned without
height of status bar. To remove status bar, call RemoveStatus method for
a form.
|
By default, text is left-aligned within the specified part of a status
window. You can embed tab characters (#9) in the text to center or
right-align it. Text to the right of a single tab character is centered,
and text to the right of a second tab character is right-aligned.
}
property StatusCtl: PControl read fStatusCtl;
{* Pointer to Status bar control. To "create" child controls on
the status bar, first create it as a child of form, for instance, and
then change its property Parent, e.g.:
! var Progress1: PControl;
! ...
! Progress1 := NewProgressBar( Form1 );
! Progress1.Parent := Form1.StatusCtl;
(If you use MCK, code should be another a bit, and in this case it is
possible to create and adjust the control at design-time, and at run-time
change its parent control. E.g. (Progress1 is created at run-time here too):
! Progress1 := NewProgressBar( Form );
! Progress1.Parent := Form.StatusCtl;
).
Do not forget to provide StatusCtl to be existing first (e.g. assign
one-space string to SimpleStatusText property of the form, for MCK do
so using Object Inspector).
}
property SizeGrip: Boolean read fSizeGrip write fSizeGrip;
{* Size grip for status bar. Has effect only before creating window. }
procedure RemoveStatus;
{* |<#form>
Call it to remove status bar from a form (created in result of assigning
value(s) to StatusText[], SimpleStatusText properties). When status bar is
removed, form is resized to preset client height. }
function StatusPanelCount: Integer;
{* |<#form>
Returns number of status panels defined in status bar. }
property StatusPanelRightX[ Idx: Integer ]: Integer read GetStatusPanelX write SetStatusPanelX;
{* |<#form>
Use this property to adjust status panel right edges (if the status bar is
divided onto several subpanels). If the right edge for the last panel is
set to -1 (by default) it is expanded to the right edge of a form window.
Otherwise, status bar can be shorter then form width. }
property StatusWindow: HWND read fStatusWnd;
{* |<#form>
Provided for case if You want to use API direct message sending to
status bar. }
property Color1: TColor read fColor1 write SetColor1;
{* |<#gradient>
Top line color for GradientPanel. }
property Color2: TColor read fColor2 write SetColor2;
{* |<#gradient>
|<#3Dlabel>
Bottom line color for GradientPanel, or shadow color for LabelEffect.
(If clNone, shadow color for LabelEffect is calculated as a mix bitween
TextColor and clBlack). }
property GradientStyle: TGradientStyle read FGradientStyle write SetGradientStyle;
{* |<#gradient>
Styles other then gsVertical and gsHorizontal has effect only for
gradient panel, created by NewGradientPanelEx. }
property GradientLayout: TGradientLayout read FGradientLayout write SetGradientLayout;
{* |<#gradient>
Has only effect for gradient panel, created by NewGradientPanelEx.
Ignored for styles gsVertical and gsHorizontal. }
//======== Image lists (for ListView, TreeView, ToolBar and TabControl):
property ImageListSmall: PImageList index 16 read GetImgListIdx write SetImgListIdx;
{* |<#listview>
Image list with small icons used with List View control. If not set,
last added (i.e. created with a control as an owner) image list with
small icons is used. }
property ImageListNormal: PImageList index 32 read GetImgListIdx write SetImgListIdx;
{* |<#listview>
|<#treeview>
|<#tabcontrol>
|<#bitbtn>
Image list with normal size icons used with List View control (or with
icons for BitBtn, TreeView or TabControl). If not set,
last added (i.e. created with a control as an owner) image list is used.
}
property ImageListState: PImageList index 0 read GetImgListIdx write SetImgListIdx;
{* |<#listview>
|<#treeview>
Image list used as a state images list for ListView or TreeView control. }
//========
function SetUnicode( Unicode: Boolean ): PControl;
{* |<#listview>
|<#treeview>
|<#tabcontrol>
Sets control as Unicode or not. The control itself is returned as for
other "transparent" functions. A conditional define UNICODE_CTRLS must
be added to a project to provide handling unicode messages. }
//======== TabControl-specific properties and methods:
property Pages[ Idx: Integer ]: PControl read GetPages;
{* |<#tabcontrol>
Returns controls, which can be used as parent for controls, placed on
different pages of a tab control. Use it like in follows example:
| Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' );
To find number of pages available, check out Count property of the tab
control. Pages are enumerated from 0 to Count - 1, as usual. }
property TC_Pages[ Idx: Integer ]: PControl read GetPages;
{* |<#tabcontrol>
The same as above. }
function TC_Insert( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer ): PControl;
{* |<#tabcontrol>
Inserts new tab before given, returns correspondent page control
(which can be used as a parent for controls to place on the page). }
procedure TC_Delete( Idx: Integer );
{* |<#tabcontrol>
Removes tab from tab control, destroying all its child controls. }
{$IFNDEF OLD_ALIGN}
procedure TC_InsertControl( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer; Page: PControl);
{* |<#tabcontrol>
Inserts new tab before given, but not construt this Page
(this control must be created before inserting, and may be not a Panel). }
function TC_Remove( Idx: Integer ):PControl;
{* |<#tabcontrol>
Only removes tab from tab control, and return this Page as Result. }
{$ENDIF}
property TC_Items[ Idx: Integer ]: KOLString read TCGetItemText write TCSetItemText;
{* |<#tabcontrol>
Text, displayed on tab control tabs. }
property TC_Images[ Idx: Integer ]: Integer read TCGetItemImgIDx write TCSetItemImgIdx;
{* |<#tabcontrol>
Image index for a tab in tab control. }
property TC_ItemRect[ Idx: Integer ]: TRect read TCGetItemRect;
{* |<#tabcontrol>
Item rectangle for a tab in tab control. }
procedure TC_SetPadding( cx, cy: Integer );
{* |<#tabcontrol>
Sets space padding around tab text in a tab of tab control. }
function TC_TabAtPos( x, y: Integer ): Integer;
{* |<#tabcontrol>
Returns index of tab, found at the given position (relative to
a client rectangle of tab control). If no tabs found at the
position, -1 is returned. }
function TC_DisplayRect: TRect;
{* |<#tabcontrol>
Returns rectangle, occupied by a page rather then tab. }
function TC_IndexOf(const S: KOLString): Integer;
{* |<#tabcontrol>
By Mr Brdo. Index of page by its Caption. }
function TC_SearchFor(const S: KOLString; StartAfter: Integer; Partial: Boolean): Integer;
{* |<#tabcontrol>
By Mr Brdo. Index of page by its Caption. }
//======== ListView style and options:
property LVStyle: TListViewStyle read fLVStyle write SetLVStyle;
{* |<#listview>
ListView style of view. Can be changed at run time. }
property LVOptions: TListViewOptions read fLVOptions write SetLVOptions;
{* |<#listview>
ListView options. Can be changed at run time. }
property LVTextColor: TColor index LVM_GETTEXTCOLOR
{$IFDEF F_P} read LVGetColorByIdx
{$ELSE DELPHI} read fTextColor
{$ENDIF F_P/DELPHI} write LVSetColorByIdx;
{* |<#listview>
ListView text color. Use it instead of Font.Color. }
property LVTextBkColor: TColor index LVM_GETTEXTBKCOLOR
{$IFDEF F_P} read LVGetColorByIdx
{$ELSE DELPHI} read fLVTextBkColor
{$ENDIF F_P/DELPHI} write LVSetColorByIdx;
{* |<#listview>
ListView background color for text. }
property LVBkColor: TColor read fColor write SetCtlColor; //LVSetBkColor;
{* |<#listview>
ListView background color. Use it instead of Color. }
//======== List View columns handling:
property LVColCount: Integer read fLVColCount;
{* |<#listview>
ListView (additional) column count. Value 0 means that there are
no columns (single item text / icon is used). If You want
to provide several columns, first call LVColAdd to "insert" column 0,
i.e. to provide header text for first column (with index 0).
If there are no column, nothing will be shown in lvsDetail /
lvsDetailNoHeader view style. }
procedure LVColAdd( const aText: KOLString; aalign: TTextAlign; aWidth: Integer );
{* |<#listview>
Adds new column. Pass 'width' <= 0 to provide default column width.
'text' is a column header text. }
procedure LVColInsert( ColIdx: Integer; const aText: KOLString; aAlign: TTextAlign; aWidth: Integer );
{* |<#listview>
Inserts new column at the Idx position (1-based column index). }
procedure LVColDelete( ColIdx: Integer );
{* |<#listview>
Deletes column from List View }
property LVColWidth[ Item: Integer ]: Integer index LVM_GETCOLUMNWIDTH
read GetItemVal write SetItemVal;
{* |<#listview>
Retrieves or changes column width. For lvsList view style, the same width
is returned for all columns (ColIdx is ignored). It is possible to use
special values to assign to a property:
|
LVSCW_AUTOSIZE - Automatically sizes the column
|
LVSCW_AUTOSIZE_USEHEADER - Automatically sizes the column to fit
the header text
|
To set coumn width in lvsList view mode, column index must be -1
(and Width to set must be in range 0..32767 always). }
property LVColText[ Idx: Integer ]: KOLString read GetLVColText write SetLVColText;
{* |<#listview>
Allows to get/change column header text at run time. }
property LVColAlign[ Idx: Integer ]: TTextAlign read GetLVColalign write SetLVColalign;
{* |<#listview>
Column text aligning. }
property LVColImage[ Idx: Integer ]: Integer index LVCF_IMAGE or (24 shl 16) read GetLVColEx write SetLVColEx;
{* |<#listview>
Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to
set an image for list view column itself from the ImageListSmall.
}
property LVColOrder[ Idx: Integer ]: Integer index LVCF_ORDER or (28 shl 16) read GetLVColEx write SetLVColEx;
{* |<#listview>
Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to
set visual order of the list view column from the ImageListSmall.
This value does not affect the index, by which the column is still
accessible in the column array.
}
//======== List View items handling:
property LVCount: Integer read GetItemsCount write SetItemsCount;
{* |<#listview>
Returns item count for ListView control. It is possible to use Count
property instead when obtaining of item count is needed only. But this this
property allows also to set actual count of list view items when a list
view is virtual. }
property LVCurItem: Integer read GetLVCurItem write SetLVCurItem;
{* |<#listview>
Returns first selected item index in a list view. See also LVNextSelected,
LVNextItem and LVFocusItem functions. }
property LVFocusItem: Integer read GetLVFocusItem;
{* |<#listview>
Returns focused item index in a list view. See also LVCurItem. }
function LVNextItem( IdxPrev: Integer; Attrs: DWORD ): Integer;
{* |<#listview>
Returns an index of the next after IdxPrev item with given attributes in
the list view. Attributes can be:
LVNI_ALL - Searches for a subsequent item by index, the default value.
|
Searchs by physical relationship to the index of the item where the
search is to begin.
LVNI_ABOVE - Searches for an item that is above the specified item.
LVNI_BELOW - Searches for an item that is below the specified item.
LVNI_TOLEFT - Searches for an item to the left of the specified item.
LVNI_TORIGHT - Searches for an item to the right of the specified item.
|
The state of the item to find can be specified with one or a combination
of the following values:
LVNI_CUT - The item has the LVIS_CUT state flag set.
LVNI_DROPHILITED - The item has the LVIS_DROPHILITED state flag set
LVNI_FOCUSED - The item has the LVIS_FOCUSED state flag set.
LVNI_SELECTED - The item has the LVIS_SELECTED state flag set.}
function LVNextSelected( IdxPrev: Integer ): Integer;
{* |<#listview>
Returns an index of next (after IdxPrev) selected item in a list view. }
function LVAdd( const aText: KOLString; ImgIdx: Integer; State: TListViewItemState;
StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer;
{* |<#listview>
Adds new line to the end of ListView control. Only content of item itself
is set (aText, ImgIdx). To change other column text and attributes of
item added, use appropriate properties / methods ().
|
Returns an index of added item.
|
There is no Unicode version defined, use LVItemAddW instead. }
function LVItemAdd( const aText: KOLString ): Integer;
{* |<#listview>
Adds an item to the end of list view. Returns an index of the item added. }
function LVInsert( Idx: Integer; const aText: KOLString; ImgIdx: Integer;
State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer;
{* |<#listview>
Inserts new line before line with index Idx in ListView control. Only
content of item itself is set (aText, ImgIdx). To change other column
text and attributes of item added, use appropriate properties / methods ().
if ImgIdx = I_IMAGECALLBACK, event handler OnGetLVItemImgIdx is responsible
for returning image index for an item ( /// not implemented yet /// )
Pass StateImgIdx and OverlayImgIdx = 0 (ignored in that case) or 1..15 to
use correspondent icon from ImageListState image list.
|
Returns an index of item inserted.
|
There is no unicode version of this method, use LVItemInsertW. }
function LVItemInsert( Idx: Integer; const aText: KOLString ): Integer;
{* |<#listview>
Inserts an item to Idx position. }
procedure LVDelete( Idx: Integer );
{* |<#listview>
Deletes item of ListView with subitems (full row - in lvsDetail view style. }
procedure LVSetItem( Idx, Col: Integer; const aText: KOLString; ImgIdx: Integer;
State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; Data: DWORD );
{* |<#listview>
Use this method to set item data and item columns data for ListView control.
It is possible to pass I_SKIP as ImgIdx, StateImgIdx, OverlayImgIdx values to
skip setting this fields. But all other are set always. Like in LVInsert /
LVAdd, ImgIdx can be I_IMAGECALLBACK to determine that image will be
retrieved in OnGetItemImgIdx event handler when needed.
|
If this method is called to set data for column > 0, parameters ImgIdx and
Data are ignored anyway.
|
There is no unicode version of this method, use other methods
to set up listed properties separately using correspondent W-functions. }
property LVItemState[ Idx: Integer ]: TListViewItemState read LVGetItemState write LVSetItemState;
{* |<#listview>
Access to list view item states set [lvisBlend, lvisHighlight, lvisFocus,
lvisSelect]. When assign new value to the property, it is possible to use
special index value -1 to change state for all items for a list view
(but only when lvoMultiselect style is applied to the list view, otherwise
index -1 is referring to the last item of the list view). }
property LVItemIndent[ Idx: Integer ]: Integer read LVGetItemIndent write LVSetItemIndent;
{* Item indentation. Indentation is calculated as this value multiplied to
image list ImgWidth value (Image list must be applied to list view).
Note: indentation supported only if IE3.0 or higher installed. }
property LVItemStateImgIdx[ Idx: Integer ]: Integer read LVGetSttImgIdx write LVSetSttImgIdx;
{* |<#listview>
Access to state image of the item. Use index -1 to assign the same state
image index to all items of the list view at once (fast).
Option lvoCheckBoxes just means, that control itself creates special inner
image list for two state images. Later it is possible to examine checked
state for items or set checked state programmatically by changing
LVItemStateImgIdx[ ] property. Value 1 corresponds to unchecked state,
2 to checked. Value 0 allows to remove checkbox at all. So, to check all
added items by default (e.g.), do following:
! ListView1.LVItemStateImgIdx[ -1 ] := 2;
|
Use 1-based index of the image
in image list ImageListState. Value 0 reserved to use as "no state image".
Values 1..15 can be used only - this is the Windows restriction on
state images. }
property LVItemOverlayImgIdx[ Idx: Integer ]: Integer read LVGetOvlImgIdx write LVSetOvlImgIdx;
{* |<#listview>
Access to overlay image of the item. Use index -1 to assign the same
overlay image to all items of the list view at once (fast). }
property LVItemData[ Idx: Integer ]: DWORD read LVGetItemData write LVSetItemData;
{* |<#listview>
Access to user defined data, assiciated with the item of the list view. }
procedure LVSelectAll;
{* |<#listview>
Call this method to select all the items of the list view control. }
property LVSelCount: Integer read GetSelLength; // write SetSelLength;
{* |<#listview>
Returns number of items selected in listview. }
property LVItemImageIndex[ Idx: Integer ]: Integer read LVGetItemImgIdx write LVSetItemImgIdx;
{* |<#listview>
Image index of items in listview. When an item is created (using LVItemAdd
or LVItemInsert), image index 0 is set by default (not -1 like in VCL!). }
property LVItems[ Idx, Col: Integer ]: KOLString read LVGetItemText write LVSetItemText;
{* |<#listview>
Access to List View item text. }
function LVItemRect( Idx: Integer; Part: TGetLVItemPart ): TRect;
{* |<#listview>
Returns rectangle occupied by given item part(s) in ListView window.
Empty rectangle is returned, if the item is not viewing currently. }
function LVSubItemRect( Idx, ColIdx: Integer ): TRect;
{* |<#listview>
Returns rectangle occupied by given item's subitem in ListView window,
in lvsDetail or lvsDetailNoHeader style. Empty rectangle (0,0,0,0) is
returned if the item is not viewing currently. Left or/and right bounds
of the rectangle returned can be outbound item rectangle if only a part
of the subitem is visible or the subitem is not visible in the item,
which is visible itself. }
property LVItemPos[ Idx: Integer ]: TPoint read LVGetItemPos write LVSetItemPos;
{* |<#listview>
Position of List View item (can be changed in icon or small icon view). }
function LVItemAtPos( X, Y: Integer ): Integer;
{* |<#listview>
Return index of item at the given position. }
function LVItemAtPosEx( X, Y: Integer; var Where: TWherePosLVItem ): Integer;
{* |<#listview>
Retrieves index of item and sets in Where, what part of item is under
given coordinates. If there are no items at the specified position,
-1 is returned. }
procedure LVMakeVisible( Item: Integer; PartiallyOK: Boolean );
{* |<#listview>
Makes listview item visible. Ignred when Item passed < 0. }
procedure LVEditItemLabel( Idx: Integer );
{* |<#listview>
Begins in-place editing of item label (first column text). }
procedure LVSort;
{* |<#listview>
Initiates sorting of list view items. This sorting procedure is available only
for Win2K, WinNT4 with IE5, Win98 or Win95 with IE5. See also LVSortData. }
procedure LVSortData;
{* |<#listview>
Initiates sorting of list view items. This sorting procedure is always available
in Windows95/98, NT/2000. But OnCompareLVItems procedure receives not indexes of
items compared but its Data field associated instead. }
procedure LVSortColumn( Idx: Integer );
{* |<#listview>
This is a method to simplify sort by column. Just call it in your OnColumnClick
event passing column index and enjoy with your list view sorted automatically
when column header is clicked. Requieres Windows2000 or Winows98, not supported
under WinNT 4.0 and below and under Windows95.
|
Either lvoSortAscending or lvoSortDescending option must be set in
LVOptions, otherwise no sorting is performed. }
function LVIndexOf( const S: KOLString ): Integer;
{* Returns first list view item index with caption matching S.
The same as LVSearchFor( S, -1, FALSE ). }
function LVSearchFor( const S: KOLString; StartAfter: Integer; Partial: Boolean ): Integer;
{* Searches an item with Caption equal to S (or starting from S, if Partial = TRUE).
Searching is started after an item specified by StartAfter parameter. }
//======== List view page:
property LVTopItem: Integer index LVM_GETTOPINDEX read GetIntVal; //LVGetTopItem;
{* |<#listview>
Returns index of topmost visible item of ListView in lvsList view style. }
property LVPerPage: Integer index LVM_GETCOUNTPERPAGE read GetIntVal; //LVGetPerPage;
{* |<#listview>
Returns the number of fully-visible items if successful. If the current
view is icon or small icon view, the return value is the total number
of items in the list view control. }
//======== List View specific events:
property OnEndEditLVItem: TOnEditLVItem read fOnEndEditLVITem write SetOnEndEditLVItem;
{* |<#listview>
Called when edit of an item label in ListView control finished. Return
True to accept new label text, or false - to not accept it (item label
will not be changed). If handler not set to an event, all changes are
accepted. }
property OnLVDelete: TOnDeleteLVItem read fOnDeleteLVItem write SetOnDeleteLVItem;
{* |<#listview>
This event is called when an item is deleted in the listview.
Do not add, delete, or rearrange items in the list view while processing
this notification. }
property OnDeleteLVItem: TOnDeleteLVItem read fOnDeleteLVItem write SetOnDeleteLVItem;
{* |<#listview>
Called for every deleted list view item. }
property OnDeleteAllLVItems: TOnEvent read fOnDeleteAllLVItems write SetOnDeleteAllLVItems;
{* |<#listview>
Called when all the items of the list view control are to be deleted. If after
returning from this event handler event OnDeleteLVItem is yet assigned,
an event OnDeleteLVItem will be called for every deleted item. }
property OnLVData: TOnLVData read fOnLVData write SetOnLVData;
{* |<#listview>
Called to provide virtual list view with actual data. To use list view as
virtaul list view, define also lvsOwnerData style and set Count property
to actual row count of the list view. This manner of working with list view
control can greatly improve performance of an application when working with
huge data sets represented in listview control. }
property OnCompareLVItems: TOnCompareLVItems read fOnCompareLVItems write fOnCompareLVItems;
{* |<#listview>
Event to compare two list view items during sort operation (initiated by
LVSort method call). Do not send any messages to the list view control
while it is sorting - results can be unpredictable! }
property OnColumnClick: TOnLVColumnClick read fOnColumnClick write SetOnColumnClick;
{* |<#listview>
This event handler is called when column of the list view control is clicked.
You can use this event to initiate sorting of list view items by this column. }
property OnLVStateChange: TOnLVStateChange read FOnLVStateChange write SetOnLVStateChange;
{* |<#listview>
This event occure when an item or items range in list view control are
changing its state (e.g. selected or unselected). }
property OnDrawItem: TOnDrawItem read fOnDrawItem write SetOnDrawItem;
{* |<#listview>
|<#listbox>
|<#combo>
This event can be used to implement custom drawing for list view, list box, dropped
list of a combobox. For a list view, custom drawing using this event is possible
only in lvsDetail and lvsDetailNoHeader styles, and OnDrawItem is called to draw
entire row at once only. See also OnLVCustomDraw event. }
property OnLVCustomDraw: TOnLVCustomDraw read FOnLVCustomDraw write SetOnLVCustomDraw;
{* |<#listview>
Custom draw event for listview. For every item to be drawn, this event
can be called several times during a single drawing cycle - depending on
a result, returned by an event handler. Stage can have one of following
values:
|
CDDS_PREERASE
CDDS_POSTERASE
CDDS_ITEMPREERASE
CDDS_PREPAINT
CDDS_ITEMPREPAINT
CDDS_ITEM
CDDS_SUBITEM + CDDS_ITEMPREPAINT
CDDS_SUBITEM + CDDS_ITEMPOSTPAINT
CDDS_ITEMPOSTPAINT
CDDS_POSTPAINT
When called, see on Stage to get know, on what stage the event is
activated. And depend on the stage and on what you want to paint,
return a value as a result, which instructs the system, if to use
default drawing on this (and follows) stage(s) for the item, and if
to notify further about different stages of drawing the item during
this drawing cycle. Possible values to return are:
|
CDRF_DODEFAULT - perform default drawing. Do not notify further for this
item (subitem) (or for entire listview, if called with
flag CDDS_ITEM reset - ?);
CDRF_NOTIFYITEMDRAW - return this value, when the event is called the
first time in a cycle of drawing, with ItemIdx = -1 and
flag CDDS_ITEM reset in Stage parameter;
CDRF_NOTIFYPOSTERASE - usually can be used to provide default erasing,
if you want to perform drawing immediately after that;
CDRF_NOTIFYPOSTPAINT - return this value to provide calling the event
after performing default drawing. Useful when you wish
redraw only a part of the (sub)item;
CDRF_SKIPDEFAULT - return this value to inform the system that all
drawing is done and system should not peform any more
drawing for the (sub)item during this drawing cycle.
CDRF_NEWFONT - informs the system, that font is changed and default
drawing should be performed with changed font;
|
If you want to get notifications for each subitem, do not use option
lvoOwnerDrawFixed, because such style prevents system from notifying
the application for each subitem to be drawn in the listview and only
notifications will be sent about entire items.
|
See also NM_CUSTOMDRAW in API Help.
}
procedure Set_LVItemHeight(Value: Integer);
function SetLVItemHeight(Value: Integer): PControl;
property LVItemHeight: Integer read fLVItemHeight write Set_LVItemHeight;
{* |<#listview>
|<#listbox>
|#combo>
It is possible to assign a value to LVItemHeight property only to
control with "owner-draw" style (lvoOwnerDrawFixed for listview,
loOwnerDrawFixed or loOwnerDrawVariable for listbox and
coOwnerDrawFixed or coOwnerDrawVariable for combobox. At least, the
control should have such option while creating it (after showing it
the first time it is possible to change its options to avoid owner
drawing later). }
//======== TreeView specific properties and methods:
function TVInsert( nParent, nAfter: THandle; const Txt: KOLString ): THandle;
{* |<#treeview>
Inserts item to a tree view. If nParent is 0 or TVI_ROOT, the item is
inserted at the root of tree view. It is possible to pass following special
values as nAfter parameter:
|
TVI_FIRST Inserts the item at the beginning of the list.
TVI_LAST Inserts the item at the end of the list.
TVI_SORT Inserts the item into the list in alphabetical order.
| }
procedure TVDelete( Item: THandle );
{* |<#treeview>
Removes an item from the tree view. If value TVI_ROOT is passed, all items
are removed. }
property TVSelected: THandle index TVGN_CARET read TVGetItemIdx write TVSetItemIdx;
{* |<#treeview>
Returns or sets currently selected item handle in tree view. }
property TVDropHilighted: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx;
{* |<#treeview>
Returns or sets item, which is currently highlighted as a drop target. }
property TVDropHilited: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx;
{* The same as TVDropHilighted. }
property TVFirstVisible: THandle index TVGN_FIRSTVISIBLE read TVGetItemIdx write TVSetItemIdx;
{* |<#treeview>
Returns or sets given item to top of tree view. }
property TVIndent: Integer index TVM_GETINDENT read GetIntVal write SetIntVal;
{* |<#treeview>
The amount, in pixels, that child items are indented relative to their
parent items. }
property TVVisibleCount: Integer index TVM_GETVISIBLECOUNT read GetIntVal;
{* |<#treeview>
Returns number of fully (not partially) visible items in tree view. }
property TVRoot: THandle index TVGN_ROOT read TVGetItemIdx;
{* |<#treeview>
Returns handle of root item in tree view (or 0, if tree is empty). }
property TVItemChild[ Item: THandle ]: THandle index TVGN_CHILD read TVGetItemNext;
{* |<#treeview>
Returns first child item for given one. }
property TVItemHasChildren[ Item: THandle ]: Boolean read TV_GetItemHasChildren write TV_SetItemHasChildren;
{* |<#treeview>
TRUE, if an Item has children. Set this value to true if you want to
force [+] sign appearing left from the node, even if there are no
subnodes added to the node yet. }
property TVItemChildCount[ Item: THandle ]: Integer read TV_GetItemChildCount;
{* |<#treeview>
Returns number of node child items in tree view.
}
property TVItemNext[ Item: THandle ]: THandle index TVGN_NEXT read TVGetItemNext;
{* |<#treeview>
Returns next sibling item handle for given one (or 0, if passed item is
the last child for its parent node). }
property TVItemPrevious[ Item: THandle ]: THandle index TVGN_PREVIOUS read TVGetItemNext;
{* |<#treeview>
Returns previous sibling item (or 0, if the is no such item). }
property TVItemNextVisible[ Item: THandle ]: THandle index TVGN_NEXTVISIBLE read TVGetItemNext;
{* |<#treeview>
Returns next visible item (passed item must be visible too, to determine,
if it is really visible, use property TVItemRect or TVItemVisible. }
property TVItemPreviousVisible[ Item: THandle ]: THandle index TVGN_PREVIOUSVISIBLE read TVGetItemNext;
{* |<#treeview>
Returns previous visible item. }
property TVItemParent[ Item: THandle ]: THandle index TVGN_PARENT read TVGetItemNext;
{* |<#treeview>
Returns parent item for given one (or 0 for root item). }
property TVItemText[ Item: THandle ]: KOLString read TVGetItemText write TVSetItemText;
{* |<#treeview>
Text of tree view item. }
function TVItemPath( Item: THandle; Delimiter: KOLChar ): KOLString;
{* |<#treeview>
Returns full path from the root item to given item. Path is calculated
as a concatenation of all parent nodes text strings, separated by
given delimiter character.
|
Please note, that returned path has no trailing delimiter, this
character is only separating different parts of the path.
|
If Item is not specified ( =0 ), path is returned
for Selected item. }
property TVItemRect[ Item: THandle; TextOnly: Boolean ]: TRect read TVGetItemRect;
{* |<#treeview>
Returns rectangle, occupied by an item in tree view. }
property TVItemVisible[ Item: THandle ]: Boolean read TVGetItemVisible write TVSetITemVisible;
{* |<#treeview>
Returs True, if item is visible in tree view. It is also possible to
assign True to this property to ensure that a tree view item is visible
(if False is assigned, this does nothing). }
function TVItemAtPos( x, y: Integer; var Where: DWORD ): THandle;
{* |<#treeview>
Returns handle of item found at specified position (relative to upper left
corener of client area of the tree view). If no item found, 0 is returned.
Variable Where receives additional flags combination, describing more
detailed, on which part of item or tree view given point is located,
such as:
|
TVHT_ABOVE Above the client area
TVHT_BELOW Below the client area
TVHT_NOWHERE In the client area, but below the last item
TVHT_ONITEM On the bitmap or label associated with an item
TVHT_ONITEMBUTTON On the button associated with an item
TVHT_ONITEMICON On the bitmap associated with an item
TVHT_ONITEMINDENT In the indentation associated with an item
TVHT_ONITEMLABEL On the label (string) associated with an item
TVHT_ONITEMRIGHT In the area to the right of an item
TVHT_ONITEMSTATEICON On the state icon for a tree-view item that is in a user-defined state
TVHT_TOLEFT To the right of the client area
TVHT_TORIGHT To the left of the client area
| }
property TVRightClickSelect: Boolean read fTVRightClickSelect write SetTVRightClickSelect;
{* |<#treeview>
Set this property to True to allow change selection to an item, clicked with right mouse button. }
property TVEditing: Boolean read fEditing;
{* |<#treeview>
Returns True, if tree view control is editing its item label. }
property TVItemBold[ Item: THandle ]: Boolean index TVIS_BOLD read TVGetItemStateFlg write TVSetItemStateFlg;
{* |<#treeview>
True, if item is bold. }
property TVItemCut[ Item: THandle ]: Boolean index TVIS_CUT read TVGetITemStateFlg write TVSetItemStateFlg;
{* |<#treeview>
True, if item is selected as part of "cut and paste" operation. }
property TVItemDropHighlighted[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg;
{* |<#treeview>
True, if item is selected as drop target. }
property TVItemDropHilited[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg;
{* The same as TVItemDropHighlighted. }
property TVItemExpanded[ Item: THandle ]: Boolean index TVIS_EXPANDED read TVGetITemStateFlg; // write TVSetItemStateFlg;
{* |<#treeview>
True, if item's list of child items is currently expanded. To change
expanded state, use method TVExpand. }
property TVItemExpandedOnce[ Item: THandle ]: Boolean index TVIS_EXPANDEDONCE read TVGetITemStateFlg; // write TVSetItemStateFlg;
{* |<#treeview>
True, if item's list of child items has been expanded at least once. }
property TVItemSelected[ Item: THandle ]: Boolean index TVIS_SELECTED read TVGetITemStateFlg write TVSetItemStateFlg;
{* |<#treeview>
True, if item is selected. }
procedure TVExpand( Item: THandle; Flags: DWORD );
{* |<#treeview>
Call it to expand/collapse item's child nodes. Possible values for Flags
parameter are:
TVE_COLLAPSE Collapses the list.
TVE_COLLAPSERESET Collapses the list and removes the child items. Note
that TVE_COLLAPSE must also be specified.
TVE_EXPAND Expands the list.
TVE_TOGGLE Collapses the list if it is currently expanded or
expands it if it is currently collapsed.
}
procedure TVSort( N: THandle );
{* |<#treeview>
By Alex Mokrov. Sorts treeview. If N = 0, entire treeview is sorted.
Otherwise, children of the given node only.
}
property TVItemImage[ Item: THandle ]: Integer index TVIF_IMAGE read TVGetItemImage write TVSetItemImage;
{* |<#treeview>
Image index for an item of tree view. To tell that there are no image
set, use index -2 (value -1 is reserved for callback image). }
property TVItemSelImg[ Item: THandle ]: Integer index TVIF_SELECTEDIMAGE read TVGetItemImage write TVSetItemImage;
{* |<#treeview>
Image index for an item of tree view in selected state. Use value -2 to
provide no image, -1 used for callback image. }
property TVItemOverlay[ Item: THandle ]: Integer index TVIS_OVERLAYMASK or $80000
read TVGetItemImage write TVSetItemImage;
{* |<#treeview>
Overlay image index for an item in tree view.
Values 1..15 can be used only - this is the Windows restriction on
overlay images. }
property TVItemStateImg[ Item: THandle ]: Integer index TVIS_STATEIMAGEMASK or $C0000
read TVGetItemImage write TVSetItemImage;
{* |<#treeview>
State image index for an item in tree view. Use 1-based index of the image
in image list ImageListState. Value 0 reserved to use as "no state image".
}
property TVItemData[ Item: THandle ]: Pointer read TVGetItemData write TVSetItemData;
{* |<#treeview>
Stores any program-defined pointer with the item. }
procedure TVEditItem( Item: THandle );
{* |<#treeview>
Begins editing given item label in tree view. }
procedure TVStopEdit( Cancel: Boolean );
{* |<#treeview>
Ends editing item label, started by user or explicitly by TVEditItem method. }
property OnTVBeginDrag: TOnTVBeginDrag read fOnTVBeginDrag write fOnTVBeginDrag;
{* |<#treeview>
Is called for tree view, when its item is to be dragging. }
property OnTVBeginEdit: TOnTVBeginEdit read fOnTVBeginEdit write fOnTVBeginEdit;
{* |<#treeview>
Is called for tree view, when its item label is to be editing. }
property OnTVEndEdit: TOnTVEndEdit read fOnTVEndEdit write fOnTVEndEdit;
{* |<#treeview>
Is called when item label is edited. It is possible to cancel
edit, returning False as a result. }
property OnTVExpanding: TOnTVExpanding read fOnTVExpanding write fOnTVExpanding;
{* |<#treeview>
Is called just before expanding/collapsing item. It is possible to
return TRUE to prevent expanding item, otherwise FALSE should be returned. }
property OnTVExpanded: TOnTVExpanded read fOnTVExpanded write fOnTVExpanded;
{* |<#treeview>
Is called after expanding/collapsing item children. }
property OnTVDelete: TOnTVDelete read fOnTVDelete write SetOnTVDelete;
{* |<#treeview>
Is called just before deleting item. You may use this event to free
resources, associated with an item (see TVItemData property). }
//----------------- by Sergey Shisminzev:
property OnTVSelChanging: TOnTVSelChanging read fOnTVSelChanging write fOnTVSelChanging;
{* |<#treeview>
Is called before changing the selection. The handler can return FALSE
to prevent changing the selection. }
//--------------------------------------
//======== Toolbar specific methods:
procedure TBAddBitmap( Bitmap: HBitmap );
{* |<#toolbar>
Adds bitmaps to a toolbar. You can pass special values as Bitmap to
add one of predefined system button images bitmaps:
|
THandle(-1) to add standard small icons,
|
THandle(-2) to add standard large icons,
|
THandle(-5) to add standard small view icons,
|
THandle(-6) to add standard large view icons,
|
THandle(-9) to add standard small history icons,
|
THandle(-10) to add standard large history icons,
(in that case use following values as indexes to the standard and view
bitmaps:
|
STD_COPY, STD_CUT, STD_DELETE, STD_FILENEW, STD_FILEOPEN, STD_FILESAVE,
STD_FIND, STD_HELP, STD_PASTE, STD_PRINT, STD_PRINTPRE, STD_PROPERTIES,
STD_REDO, STD_REPLACE, STD_UNDO,
|
VIEW_LARGEICONS, VIEW_SMALLICONS,
VIEW_LIST, VIEW_DETAILS, VIEW_SORTNAME, VIEW_SORTSIZE, VIEW_SORTDATE,
VIEW_SORTTYPE (use it as parameters BtnImgIdxArray in TBAddButtons or
TBInsertButtons methods, and in assigning value to TBButtonImage[ ]
property).
Added bitmaps have indeces starting from previous count of images
(as these are appended to existing - if any).
|
Note, that if You add your own (custom) bitmap, it is not transparent.
Do not assume that clSilver is always equal to clBtnFace. Use API
function CreateMappedBitmap to load bitmap from resource and map
desired colors as you wish (e.g., convert clTeal to clBtnFace). Or,
call defined in KOL function LoadMappedBitmap to do the same more easy.
Unfortunately, resource identifier for bitmap to pass it to LoadMappedBitmap
or to CreateMappedBitmap seems must be integer, so it is necessary to
create rc-file manually and compile using Borland Resource Compiler to
figure it out. }
function TBAddButtons( const Buttons: array of PKOLChar; const BtnImgIdxArray: array
of Integer ): Integer;
{* |<#toolbar>
Adds buttons to toolbar. Last string in Buttons array *must* be empty
('' or nil), so to add buttons without text, pass ' ' string (one space
char). It is not necessary to provide image indexes for all
buttons (it is sufficient to assign index for first button only).
But in place, correspondent to separator button (defined by string '-'),
any integer must be passed to assign follow image indexes correctly.
See example.
|*Toolbar adding buttons sample.
Code below shows how to call TBAddButtons method to add two buttons with
a separator between these buttons. idxNew and idxOld are integer
expressions assigning image indexes to buttons 'New' and 'Old'. This
indexes are zero-based and refer to bitmap images, added earlier (either
in creating toolbar by call of NewToolbar or later in call of TBAddBitmap).
!
! TBAddButtons( [ '&New', '-', '&Old', '' ], [ idxNew, 0, idxOld ] );
!
|*
To add check buttons, use prefix '+' or '-' in button definition
string. If next character is '!', such buttons are grouped to a
radio-group. Also, it is possible to use '^' prefix (must be first) to
define button with small drop-down section (use also OnTBDropDown event
to respond to clicking drop down section of such buttons).
|
This function returns command id for first added button (other
id's can be calculated incrementing the result by one for each
button, except separators, which have no command id).
|
Note: for static toolbar (single in application and created
once) ids are started from value 100. }
function TBInsertButtons( BeforeIdx: Integer; Buttons: array of PKOLChar;
BtnImgIdxArray: array of Integer ): Integer;
{* |<#toolbar>
Inserts buttons before button with given index on toolbar. Returns
command identifier for first button inserted (other can be calculated
incrementing returned value needed times. See also TBAddButtons. }
procedure TBDeleteButton( BtnID: Integer );
{* |<#toolbar>
Deletes single button given by its command id. To delete separator,
use TBDeleteBtnByIdx instead. }
procedure TBDeleteBtnByIdx( Idx: Integer );
{* |<#toolbar>
Deletes single button given by its index in toolbar (not by command ID). }
procedure TBAssignEvents( BtnID: Integer; Events: array of TOnToolbarButtonClick );
{* |<#toolbar>
Allows to assign separate OnClick events for every toolbar button.
BtnID should be toolbar button ID or index of the first button to
assign event. If it is an ID, events are assigned to buttons in
creation order. Otherwise, events are assigned in placement order.
Anyway, separator buttons are not skipped, so pass at least nil for such
button as an event.
|
Please note, that though not all buttons should exist before
assigning events to it, therefore at least the first button
(specified by BtnID) must be already added before calling TBAssignEvents. }
procedure TBResetImgIdx( BtnID, BtnCount: Integer );
{* |<#toolbar>
Resets image index for BtnCount buttons starting from BtnID. }
property CurItem: Integer read fCurItem;
{* |<#toolbar>
For toolbar, in OnClick event this property can be used to determine
which button was clicked (100-based button id in toolbar). It is also
possible to use CurIndex property (zero-based) for this purpose as
well, but do not assume, that CurItem always equal to CurIndex+100.
At least, it is possible to call TBItem2Index function to convert
button ID to its index in toolbar.
}
property TBButtonCount: Integer read GetItemsCount; //TBGetButtonCount;
{* |<#toolbar>
Returns count of buttons on toolbar. The same as Count. }
property TBBtnImgWidth: Integer read fTBBtnImgWidth write fTBBtnImgWidth;
{* |<#toolbar>
Custom toolbar buttons width. Set it before assigning buttons bitmap.
Changing this property after assigning the bitmap has no effect. }
function TBItem2Index( BtnID: Integer ): Integer;
{* |<#toolbar>
Converts button command id to button index for tool bar. }
function TBIndex2Item( Idx: Integer ): Integer;
{* |<#toolbar>
Converts toolbar button index to its command ID. }
procedure TBConvertIdxArray2ID( const IdxVars: array of PDWORD );
{* |<#toolbar>
Converts toolbar button indexes to its command IDs for an array
of indexes (each item in the array passed is a pointer to
Integer, containing button index when the procedure is callled,
then all these indexes are relaced with a correspondent button ID).}
property TBButtonEnabled[ BtnID: Integer ]: Boolean index TB_ENABLEBUTTON
read TBGetBtnStt write TBSetBtnStt;
{* |<#toolbar>
Obvious. }
property TBButtonVisible[ BtnID: Integer ]: Boolean read TBGetButtonVisible
write TBSetButtonVisible;
{* |<#toolbar>
Allows to hide/show some of toolbar buttons. }
property TBButtonChecked[ BtnID: Integer ]: Boolean index TB_CHECKBUTTON
read TBGetBtnStt write TBSetBtnStt;
{* |<#toolbar>
Allows to determine 'checked' state of a button (e.g., radio-button),
and to check it programmatically. }
{$ifdef win32}
property TBButtonMarked[ BtnID: Integer ]: Boolean index TB_MARKBUTTON
read TBGetBtnStt write TBSetBtnStt;
{* |<#toolbar>
Returns True if toolbar button is marked (highlighted). Allows to
highlight buttons assigning True to this value. }
{$endif}
property TBButtonPressed[ BtnID: Integer ]: Boolean index TB_PRESSBUTTON
read TBGetBtnStt write TBSetBtnStt;
{* |<#toolbar>
Allows to detrmine if toolbar button (given by its command ID) pressed,
and press/unpress it programmatically. }
property TBButtonText[ BtnID: Integer ]: KOLString read TBGetButtonText write TBSetButtonText;
{* |<#toolbar>
Obtains toolbar button text and allows to change it. Be sure that text
is not empty for all buttons, if You want for it to be shown (if at least
one button has empty text, no text labels will be shown at all). At
least set it to ' ' for buttons, which You do not want to show labels,
if You want from other ones to have it. }
property TBButtonImage[ BtnID: Integer ]: Integer read TBGetBtnImgIdx write TBSetBtnImgIdx;
{* |<#toolbar>
Allows to access/change button image. Do not read this property for
separator buttons, returning value is not proper. If you do not know,
is the button a separator, using function below. }
function TBButtonSeparator( BtnID: Integer ): Boolean;
{* |<#toolbar>
Returns TRUE, if a toolbar button is separator. }
property TBButtonRect[ BtnID: Integer ]: TRect read TBGetButtonRect;
{* |<#toolbar>
Obtains rectangle occupied by toolbar button in toolbar window.
(It is not possible to obtain rectangle for buttons, currently
not visible). See also function ToolbarButtonRect. }
property TBButtonWidth[ BtnID: Integer ]: Integer read TBGetBtnWidth write TBSetBtnWidth;
{* |<#toolbar>
Allows to obtain / change toolbar button width. }
property TBButtonsMinWidth: Integer index 0
{$IFDEF F_P} read TBGetBtMinMaxWidth
{$ELSE DELPHI} read FTBBtMinWidth
{$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth;
{* |<#toolbar>
Allows to set minimal width for all toolbar buttons. }
property TBButtonsMaxWidth: Integer index 1
{$IFDEF F_P} read TBGetBtMinMaxWidth
{$ELSE DELPHI} read FTBBtMaxWidth
{$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth;
{* |<#toolbar>
Allows to set maximal width for all toolbar buttons. }
function TBButtonAtPos( X, Y: Integer ): Integer;
{* |<#toolbar>
Returns command ID of button at the given position on toolbar,
or -1, if there are no button at the position. Value 0 is returned
for separators. }
function TBBtnIdxAtPos( X, Y: Integer ): Integer;
{* |<#toolbar>
Returns index of button at the given position on toolbar.
This also can be index of separator button. -1 is returned if
there are no buttons found at the position. }
function TBMoveBtn( FromIdx, ToIdx: Integer ): Boolean;
{* |<#toolbar>
By TR"]F. Moves button from one position to another. }
property TBRows: Integer read TBGetRows write TBSetRows;
{* |<#toolbar>
Returns number of rows for toolbar and allows to try to set
desired number of rows (but system can set another number of
rows in some cases). This property has no effect if tboWrapable
style not present in Options when toolbar is created. }
procedure TBSetTooltips( BtnID1st: Integer; const Tooltips: array of PKOLChar );
{* |<#toolbar>
Allows to assign tooltips to several buttons. Until this procedure
is not called, tooltips list is not created and no code is added
to executable. This method of tooltips maintainance for toolbar buttons
is useful both for static and dynamic toolbars (meaning "dynamic" -
toolbars with buttons, deleted and inserted at run-time). }
property OnTBDropDown: TOnEvent read fOnDropDown write fOnDropDown;
{* |<#toolbar>
This event is called for drop down buttons, when user click drop part
of drop down button. To determine for which button event is called,
look at CurItem or CurIndex property. It is also possible to use
common (with combobox) property OnDropDown. }
property OnTBClick: TOnEvent read fOnClick write fOnClick;
{* |<#toolbar>
The same as OnClick. }
{$ifndef wince}
property OnTBCustomDraw: TOnTBCustomDraw read fOnTBCustomDraw write SetOnTBCustomDraw;
{* |<#toolbar>
An event (mainly) to customize toolbar background. }
{$endif wince}
property MaxTextSize: DWORD read GetMaxTextSize write SetMaxTextSize;
{* |<#richedit>
This property valid also for simple edit control, not only for RichEdit.
But for usual edit control, maximum text size available is 32K. For
RichEdit, limit is 4Gb. By default, RichEdit is limited to
32767 bytes (to set maximum size available to 2Gb, assign MaxInt value
to a property). Also, to get current text size of RichEdit, use property
TextSize or RE_TextSize[ ]. }
property TextSize: Integer read GetTextSize;
{* |<#richedit>
Common for edit and rich edit controls property, which returns size of
text in edit control. Also, for any other control (or form, or applet
window) returns size (in characters) of Caption or Text (what is, the
same property actually). }
//================== RichEdit specific: ==================
{$IFNDEF NOT_USE_RICHEDIT}
property RE_TextSize[ Units: TRichTextSize ]: Integer read REGetTextSize;
{* |<#richedit>
For RichEdit control, it returns text size, measured in desired units
(rtsChars - characters, including OLE objects, counted as a single
character; rtsBytes - presize length of text image (if it would be stored
in file or stream). Please note, that for RichEdit1.0, only size in
characters can be obtained. }
function RE_TextSizePrecise: Integer;
{* |<#richedit>
By Savva. Returns length of rich edit text. }
property RE_CharFmtArea: TRichFmtArea read fRECharArea write fRECharArea;
{* |<#richedit>
By default, this property is raSelection. Changing it, You determine in
for which area characters format is applyed, when changing
character formatting properties below (not paragraph formatting).
|&A=%0
}
property RE_CharFormat: TCharFormat read REGetCharformat write RESetCharFormat;
{* |<#richedit>
In differ to follow properties, which allow to control certain formatting
attributes, this property provides low level access for formatting current
character area (see RE_CharFmtArea). It returns TCharFormat structure,
filled in with formatting attributes, and by assigning another value to
this property You can change desired attributes as You wish. Even if
RichEdit1.0 is used, TCharFormat2 is returned (but extended fields are
ignored for RichEdit1.0). }
property RE_Font: PGraphicTool read REGetFont write RESetFont;
{* |<#richedit>
Font of the first character in current selection (when retrieve).
When set (or subproperties of RE_Font are set), all font attributes are
applied to entire . To apply only needed attributes, use another
properties: RE_FmtBold, RE_FmtItalic, RE_FmtStrikeout, RE_FmtUnderline,
RE_FmtName, etc.
|
Note, that font size is measured in twips, which is about 1/10 of pixel. }
property RE_FmtBold: Boolean index CFM_BOLD read REGetFontEffects write RESetFontEffect;
{* |<#richedit>
Formatting flag. When retrieve, returns True, if fsBold style RE_Font.FontStyle
is valid for a first character in the selection. When set, changes fsBold
style (True - set, False - reset) for all characters in . }
property RE_FmtBoldValid: Boolean index CFM_BOLD read REGetFontMask;
{* }
property RE_FmtItalic: Boolean index CFM_ITALIC read REGetFontEffects write RESetFontEffect;
{* |<#richedit>
Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsItalic
style valid for the first character of the selection, and when set, changes
only fsItalic style for an . }
property RE_FmtItalicValid: Boolean index CFM_ITALIC read REGetFontMask;
{* }
property RE_FmtStrikeout: Boolean index CFM_STRIKEOUT read REGetFontEffects write RESetFontEffect;
{* |<#richedit>
Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsStrikeout
style valid for the first selected character, and when set, changes only
fsStrikeout style for an . }
property RE_FmtStrikeoutValid: Boolean index CFM_STRIKEOUT read REGetFontMask;
{* }
property RE_FmtUnderline: Boolean index CFM_UNDERLINE read REGetFontEffects write RESetFontEffect;
{* |<#richedit>
Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsUnderline
style valid for the first selected character, and when set, changes
fsUnderline style for an . }
property RE_FmtUnderlineValid: Boolean index CFM_UNDERLINE read REGetFontMask;
{* }
property RE_FmtUnderlineStyle: TRichUnderline
read REGetUnderlineEx write RESetUnderlineEx;
{* |<#richedit>
Extended underline style. To check, if this property is valid for
entire selection, examine RE_FmtUnderlineValid value. }
property RE_FmtProtected: Boolean index CFM_PROTECTED read REGetFontEffects write RESetFontEffect;
{* |<#richedit>
Formatting flag. When retrieving, shows, is the first character of the selection
is protected from changing it by user (True) or not (False). To get know,
if retrived value is valid for entire selection, check the property
RE_FmtProtectedValid. When set, makes all characters in protected (
True) or not (False). }
property RE_FmtProtectedValid: Boolean index CFM_PROTECTED read REGetFontMask;
{* |<#richedit>
True, if property RE_FmtProtected is valid for entire selection, when
retrieving it. }
property RE_FmtHidden: Boolean index CFM_HIDDEN read REGetFontEffects write RESetFontEffect;
{* |<#richedit>
For RichEdit3.0, makes text hidden (not displayed). }
property RE_FmtHiddenValid: Boolean index CFM_HIDDEN read REGetFontMask;
{* |<#richedit>
Returns True, if RE_FmtHidden style is valid for entire selection. }
property RE_FmtLink: Boolean index $20 {CFM_LINK} read REGetFontEffects write RESetFontEffect;
{* |<#richedit>
Returns True, if the first selected character is a part of link (URL). }
// by Sergey Shisminzev
property RE_FmtLinkValid: Boolean index $20 {CFM_LINK} read REGetFontMask;
{* }
property RE_FmtFontSize: Integer index (12 shl 16) or CFM_SIZE read REGetFontAttr write RESetFontAttr;
{* |<#richedit>
Formatting value: font size, in twips (1/1440 of an inch, or 1/20 of a
printer's point, or about 1/10 of pixel). When retrieving, returns
RE_Font.FontHeight.
When set, changes font size for entire (but does not change
other font attributes). }
property RE_FmtFontSizeValid: Boolean read REGetFontSizeValid;
{* |<#richedit>
Returns True, if property RE_FmtFontSize is valid for entire selection,
when retrieving it. }
property RE_FmtAutoBackColor: Boolean index CFM_BACKCOLOR read REGetFontEffects write RESetFontEffect;
{* |<#richedit>
True, when automatic back color is used. }
property RE_FmtAutoBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask;
{* }
property RE_FmtFontColor: Integer index (20 shl 16) or CFM_COLOR read REGetFontAttr write RESetFontAttr1;
{* |<#richedit>
Formatting value (font color). When retrieving, returns RE_Font.Color.
When set, changes font color for entire (but does not change
other font attributes). }
property RE_FmtFontColorValid: Boolean index CFM_COLOR read REGetFontMask;
{* |<#richedit>
Returns True, if property RE_FmtFontColor valid for entire selection,
when retrieving it. }
property RE_FmtAutoColor: Boolean index CFM_COLOR read REGetFontEffects write RESetFontEffect;
{* |<#richedit>
True, when automatic text color is used (in such case, RE_FmtFontColor
assignment is ignored for current area). }
property RE_FmtAutoColorValid: Boolean index CFM_COLOR read REGetFontMask;
{* }
property RE_FmtBackColor: Integer index ((64
{$IFDEF UNICODE_CTRLS} + 32 {$ENDIF}
) shl 16) or CFM_BACKCOLOR read REGetFontAttr write RESetFontAttr1;
{* |<#richedit>
Formatting value (back color). Only available for Rich Edit 2.0 and higher.
When set, changes background color for entire (but does not change
other font attributes). }
property RE_FmtBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask;
{* }
property RE_FmtFontOffset: Integer index (16 shl 16) or CFM_OFFSET read REGetFontAttr write RESetFontAttr;
{* |<#richedit>
Formatting value (font vertical offset from baseline, positive values
correspond to subscript). When retrieving, returns offset for first
character in the selection. When set, changes font offset for entire
. To get know, is retrieved value valid for entire selction,
check RE_FmtFontOffsetValid property. }
property RE_FmtFontOffsetValid: Boolean index CFM_OFFSET read REGetFontMask;
{* |<#richedit>
Returns True, if property RE_FmtFontOffset is valid for entire selection,
when retrieving it. }
property RE_FmtFontCharset: Integer index (25 shl 16) or CFM_CHARSET read REGetFontAttr write RESetFontAttr;
{* |<#richedit>
Returns charset for first character in current selection, when retrieved
(and to get know, if this value is valid for entire selection, check
property RE_FmtFontCharsetValid). When set, changes charset for all
characters in , but does not alter other formatting attributes. }
property RE_FmtFontCharsetValid: Boolean index CFM_CHARSET read REGetFontMask;
{* |<#richedit>
Returns True, only if rerieved property RE_FmtFontCharset is valid for
entire selection. }
property RE_FmtFontName: KOLString read REGetFontName write RESetFontName;
{* |<#richedit>
Returns font face name for first character in the selection, when retrieved,
and sets font name for entire , wnen assigned to (without
changing of other formatting attributes). To get know, if retrived
font name valid for entire selection, examine property RE_FmtFontNameValid. }
property RE_FmtFontNameValid: Boolean index CFM_FACE read REGetFontMask;
{* |<#richedit>
Returns True, only if the font name is the same for entire selection,
thus is, if rerieved property value RE_FmtFontName is valid for entire
selection. }
property RE_ParaFmt: TParaFormat read REGetParaFmt write RESetParaFmt;
{* |<#richedit>
Allows to retrieve or set paragraph formatting attributes for currently
selected paragraph(s) in RichEdit control. See also following properties,
which allow to do the same for certain paragraph format attributes
separately. }
property RE_TextAlign: TRichTextAlign read REGetTextAlign write RESetTextAlign;
{* |<#richedit>
Returns text alignment for current selection and allows to change it
(without changing other formatting attributes). }
property RE_TextAlignValid: Boolean index PFM_ALIGNMENT read REGetParaAttrValid;
{* |<#richedit>
Returns True, if property RE_TextAlign is valid for entire selection. If
False, it is concerning only start of selection. }
property RE_Numbering: Boolean read REGetNumbering write RESetNumbering;
{* |<#richedit>
Returns True, if selected text is numbered (or has style of list with
bullets). To get / change numbering style, see properties
RE_NumStyle and RE_NumBrackets. }
property RE_NumStyle: TRichNumbering read REGetNumStyle write RESetNumStyle;
{* |<#richedit>
Advanced numbering style, such as rnArabic etc. If You use it, do not
change RE_Numbering property simultaneously - this can cause changing
style to rnBullets only. }
property RE_NumStart: Integer read REGetNumStart write RESetNumStart;
{* |<#richedit>
Starting number for advanced numbering style. If this property is not
set, numbering is starting by default from 0. For rnLRoman and rnURoman
this cause, that first item has no number to be shown (ancient Roman
people did not invent '0'). }
property RE_NumBrackets: TRichNumBrackets read REGetNumBrackets write RESetNumBrackets;
{* |<#richedit>
Brackets style for advanced numbering. rnbPlain is default
brackets style, and every time, when RE_NumStyle is changed,
RE_NumBrackets is reset to rnbPlain. }
property RE_NumTab: Integer read REGetNumTab write RESetNumTab;
{* |<#richedit>
Tab between start of number and start of paragraph text. If too small too
view number, number is not displayed. (Default value seems to be sufficient
though). }
property RE_NumberingValid: Boolean index PFM_NUMBERING read REGetParaAttrValid;
{* |<#richedit>
Returns True, if RE_Numbering, RE_NumStyle, RE_NumBrackets, RE_NumTab,
RE_NumStart properties are valid for entire selection. }
property RE_Level: Integer read REGetLevel;
{* |<#richedit>
Outline level (for numbering paragraphs?). Read only. }
property RE_SpaceBefore: Integer index 0 or PFM_SPACEBEFORE read REGetSpacing write RESetSpacing;
{* |<#richedit>
Spacing before paragraph. }
property RE_SpaceBeforeValid: Boolean index PFM_SPACEBEFORE read REGetParaAttrValid;
{* |<#richedit>
True, if RE_SpaceBefore value is valid for all selected paragraph (if
False, this value is valid only for first paragraph. }
property RE_SpaceAfter: Integer index 4 or PFM_SPACEAFTER read REGetSpacing write RESetSpacing;
{* |<#richedit>
Spacing after paragraph. }
property RE_SpaceAfterValid: Boolean index PFM_SPACEAFTER read REGetParaAttrValid;
{* |<#richedit>
True, only if RE_SpaceAfter value is valid for all selected paragraphs. }
property RE_LineSpacing: Integer index 8 or PFM_LINESPACING read REGetSpacing write RESetSpacing;
{* |<#richedit>
Linespacing in paragraph (this value is based on RE_SpacingRule property). }
property RE_SpacingRule: Integer read REGetSpacingRule write RESetSpacingRule;
{* |<#richedit>
Linespacing rule. Do not know what is it. }
property RE_LineSpacingValid: Boolean index PFM_LINESPACING read REGetParaAttrValid;
{* |<#richedit>
True, only if RE_LineSpacing and RE_SpacingRule values are valid for
entire selection. }
property RE_Indent: Integer index (20 shl 16) or PFM_OFFSET read REGetParaAttr write RESetParaAttr;
{* |<#richedit>
Returns left indentation for paragraph in current selection and allows
to change it (without changing other formatting attributes). }
property RE_IndentValid: Boolean index PFM_OFFSET read REGetParaAttrValid;
{* |<#richedit>
Returns True, if RE_Indent property is valid for entire selection. }
property RE_StartIndent: Integer index (12 shl 16) or PFM_STARTINDENT read REGetParaAttr write RESetParaAttr;
{* |<#richedit>
Returns left indentation for first line in paragraph for current
selection, and allows to change it (without changing other formatting
attributes). }
property RE_StartIndentValid: Boolean read REGetStartIndentValid;
{* |<#richedit>
Returns True, if property RE_StartIndent is valid for entire selection. }
property RE_RightIndent: Integer index (16 shl 16) or PFM_RIGHTINDENT read REGetParaAttr write RESetParaAttr;
{* |<#richedit>
Returns right indent for paragraph in current selection, and allow to
change it (without changing other formatting attributes). }
property RE_RightIndentValid: Boolean index PFM_RIGHTINDENT read REGetParaAttrValid;
{* |<#richedit>
Returns True, if property RE_RightIndent is valid for entire selection only. }
property RE_TabCount: Integer read REGetTabCount write RESetTabCount;
{* |<#richedit>
Number of tab stops in current selection. This value can not be set greater
then MAX_TAB_COUNT (32). }
property RE_Tabs[ Idx: Integer ]: Integer read REGetTabs write RESetTabs;
{* |<#richedit>
Tab stops for RichEdit control. }
property RE_TabsValid: Boolean index PFM_TABSTOPS read REGetParaAttrValid;
{* |<#richedit>
Returns True, if properties RE_Tabs[ ] and RE_TabCount are valid for
entire selection. }
// following does not work now :
property RE_BorderWidth[ Side: TBorderEdge ]: Integer index 2 read REGetBorder write RESetBorder;
{ * |<#richedit>
Border width. }
property RE_BorderSpace[ Side: TBorderEdge ]: Integer index 0 read REGetBorder write RESetBorder;
{ * |<#richedit>
Border space. }
property RE_BorderStyle[ Side: TBorderEdge ]: Integer index 4 read REGetBorder write RESetBorder;
{ * |<#richedit>
Border style. }
property RE_BorderValid: Boolean index PFM_BORDER read REGetParaAttrValid;
{ * |<#richedit>
Returns True, if border style, space and width are the same for all
paragraphs in selection. }
property RE_Table: Boolean index $C000 read REGetParaEffect write RESetParaEffect;
{ * |<#richedit>
True, if current paragraph is a part of table (row, cell or cell end).
seems working as read only property. }
// end of experiment section
function RE_FmtStandard: PControl;
{* |<#richedit>
"Transparent" method (returns @Self as a result), which (when called)
provides "standard" keyboard interface for formatting Rich text (just
call this method, for example:
! RichEd1 := NewRichEdit( Panel1, [ ] ).SetAlign( caClient ).RE_FmtStandard;
Following keys will be maintained additionally:
|
CTRL+I - switch "Italic",
CTRL+B - switch "Bold",
CTRL+U - switch "Underline",
CTRL+SHIFT+U - swith underline type
and turn underline on (note, that some of underline styles
can not be shown properly in RichEdit v2.0 and lower,
though RichEdit2.0 stores data successfully).
CTRL+O - switch "StrikeOut",
CTRL+'gray+' - increase font size,
CTRL+'gray-' - decrease font size,
CTRL+SHIFT+'gray+' - superscript,
CTRL+SHIFT+'gray-' - subscript.
CTRL+SHIFT+Z - ReDo
|
And, though following standard formatting keys are provided by RichEdit
control itself in Windows2000, some of these are not functioning
automatically in earlier Windows versions, even for RichEdit2.0. So,
functionality of some of these (marked with (*) ) are added here too:
|
CTRL+L - align paragraph left, (*)
CTRL+R - align paragraph right, (*)
CTRL+E - align paragraph center, (*)
CTRL+A - select all, (*)
double-click on word - select word,
CTRL+Right - to next word,
CTRL+Left - to previous word,
CTRL+Home - to the beginning of text,
CTRL+End - to the end of text.
CTRL+Z - UnDo
|
If You originally assign some (plain) text to Text property, switching "underline"
can also change other font attributes, e.g., "bold" - if fsBold style is
in default Font. To prevent such behavior, select entire text first (see
SelectAll) and make assignment to RE_Font property, e.g.:
! RichEd1.SelectAll;
! RichEd1.RE_Font := RichEd1.RE_Font;
! RichEd1.SelLength := 0;
|
And, some other notices about formatting. Please remember, that only True
Type fonts can be succefully scaled and transformed to get desired effects
(e.g., bold). By default, RichEdit uses System font face name, which can
even have problems with fsBold style. Please remember also, that assigning
RE_Font to RE_Font just initializying formatting attributes, making all
those valid in entire text, but does not change font attributes. To use
True Type font, directly assign face name You wish, e.g.:
! RichEd1.SelectAll;
! RichEd1.RE_Font := RichEd1.RE_Font;
! RichEd1.RE_Font.FontName := 'Arial';
! RichEd1.SelLength := 0;
}
procedure RE_CancelFmtStandard;
{* Cancels RE_FmtStandard (detaching window procedure handler). }
property RE_AutoKeyboard: Boolean index 1 read REGetLangOptions write RESetLangOptions;
{* |<#richedit>
True if autokeyboard on (lovely "feature" of automatic switching keyboard
language when caret is over another language text). For older RichEdit,
is 'on' always, for newest - 'off' by default. }
property RE_AutoFont: Boolean index 2 read REGetLangOptions write RESetLangOptions;
{* |<#richedit>
True if autofont on (automatic switching font when keyboard layout is
changes). By default, is 'on' always. It is suggested to turn this option
off for Unicode control. }
property RE_AutoFontSizeAdjust: Boolean index 16 read REGetLangOptions write RESetLangOptions;
{* |<#richedit>
See IMF_AUTOFONTSIZEADJUST option in SDK:
Font-bound font sizes are scaled from insertion point size according to
script. For example, Asian fonts are slightly larger than Western ones.
This option is turned on by default. }
property RE_DualFont: Boolean index 128 read REGetLangOptions write RESetLangOptions;
{* |<#richedit>
See IMF_DUALFONT option in SDK:
Sets the control to dual-font mode. Used for Asian language support.
The control uses an English font for ASCII text and a Asian font for
Asian text. }
property RE_UIFonts: Boolean index 32 read REGetLangOptions write RESetLangOptions;
{* |<#richedit>
See IMF_UIFONTS option in SDK:
Use user-interface default fonts. This option is turned off by default. }
property RE_IMECancelComplete: Boolean index 4 read REGetLangOptions write RESetLangOptions;
{* |<#richedit>
See IMF_IMECANCELCOMPLETE option in SDK:
This flag determines how the control uses the composition string of an
IME if the user cancels it. If this flag is set, the control discards
the composition string. If this flag is not set, the control uses the
composition string as the result string. }
property RE_IMEAlwaysSendNotify: Boolean index 8 read REGetLangOptions write RESetLangOptions;
{* |<#richedit>
See IMF_IMEALWAYSSENDNOTIFY option in SDK:
Controls how Rich Edit notifies the client during IME composition:
|
0: No EN_CHANGED or EN_SELCHANGE notifications during undetermined state.
Send notification when final string comes in. (default)
|
1: Send EN_CHANGED and EN_SELCHANGE events during undetermined state. }
property RE_OverwriteMode: Boolean read REGetOverwite write RESetOverwrite;
{* |<#richedit>
This property allows to control insert/overwrite mode. First, to examine, if
insert or overwrite mode is current (but it is necessary either to
access this property, at least once, immediately after creating RichEdit
control, or to assign event OnRE_InsOvrMode_Change to your handler).
Second, to set desired mode programmatically - by assigning value to
this property (You also have to initialize monitoring procedure by either
reading RE_OverwriteMode property or assigning handler to event
OnRE_InsOvrMode_Change immediately following RichEdit control creation). }
property OnRE_InsOvrMode_Change: TOnEvent read fOnREInsModeChg write fOnREInsModeChg;
{* |<#richedit>
This event is called, whenever key INSERT is pressed in control (and for
RichEdit, this means, that insert mode is changed). }
property RE_DisableOverwriteChange: Boolean read fReOvrDisable write RESetOvrDisable;
{* |<#richedit>
It is possible to disable switching between "insert" and "overwrite" mode
by user (therefore, event OnRE_InsOvrMode_Change continue works, but it
just called when key INSERT is pressed, though RE_OverwriteMode property
is not actually changed if switching is disabled). }
function RE_LoadFromStream( Stream: PStream; Length: Integer;
Format: TRETextFormat; SelectionOnly: Boolean ): Boolean;
{* |<#richedit>
Use this method rather then assignment to RE_Text property, if
source is stored in file or stream (to minimize resources during
loading of RichEdit content). Data is loading starting from current
position in stream and no more then Length bytes are loaded (use -1
value to load to the end of stream). Loaded data replaces entire
content of RichEdit control, or selection only, depending on SelectionOnly
flag.
|
If You want to provide progress (e.g. in form of progress bar), assign
OnProgress event to your handler - and to examine current position of
loading, read TSream.Position property of soiurce stream). }
function RE_SaveToStream( Stream: PStream; Format: TRETextFormat; SelectionOnly: Boolean ): Boolean;
{* |<#richedit>
Use this method rather then RE_TextProperty to store data to file
or stream (to minimize resources during saving of RichEdit content).
Data is saving starting from current position in a stream (until
end of RichEdit data). If SelectionOnly flag is True, only selected
part of RichEdit text is saved.
|
Like for RE_LoadFromStream, it is possible to assign your method to
OnProgress event (but to calculate progress of save-to-stream operation,
compare current stream position with RE_Size[ rsBytes ] property
value). }
property OnProgress: TOnEvent read fOnProgress write fOnProgress;
{* |<#richedit>
This event is called during RE_SaveToStream, RE_LoadFromStream (and also
during RE_SaveToFile, RE_LoadFromFile and while accessing or changing
RE_Text property). To calculate relative progress, it is possible to
examine current position in stream/file with its total size while reading,
or with rich edit text size, while writing (property RE_TextSize[ rsBytes ]).
}
function RE_LoadFromFile( const Filename: KOLString; Format: TRETextFormat;
SelectionOnly: Boolean ): Boolean;
{* |<#richedit>
Use this method rather then other assignments to RE_Text property,
if a source for RichEdit is the file. See also RE_LoadFromStream. }
function RE_SaveToFile( const Filename: KOLString; Format: TRETextFormat;
SelectionOnly: Boolean ): Boolean;
{* |<#richedit>
Use this method rather then other similar, if You want to store
entire content of RichEdit or selection only of RichEdit to a file. }
property RE_Text[ Format: TRETextFormat; SelectionOnly: Boolean ]: KOLString read REReadText write REWriteText;
{* |<#richedit>
This property allows to get / replace content of RichEdit control
(entire text or selection only). Using different formats, it is
possible to exclude or replace undesired formatting information
(see TRETextFormat specification). To get or replace entire text
in reText mode (plain text only), it is possible to use habitual
for edit controls Text property.
|
Note: it is possible to append text to the end of RichEdit control
using method Add, but only if property RE_Text is accessed at least
once:
! RichEdit1.RE_Text[ reText, True ];
(This line can be written immediatelly after creating RichEdit control). }
procedure RE_Append( const S: KOLString; ACanUndo: Boolean );
{* }
procedure RE_InsertRTF( const S: KOLString );
{* }
property RE_Error: Integer read fREError;
{* |<#richedit>
Contains error code, if access to RE_Text failed. }
procedure RE_HideSelection( aHide: Boolean );
{* |<#richedit>
Allows to hide / show selection in RichEdit. }
function RE_SearchText( const Value: KOLString; MatchCase, WholeWord, ScanForward: Boolean;
SearchFrom, SearchTo: Integer ): Integer;
{* |<#richedit>
Searches given string starting from SearchFrom position up to SearchTo
position (to the end of text, if SearchTo is -1). Returns zero-based
character position of the next match, or -1 if there are no more matches.
To search in bacward direction, set ScanForward to False, and pass
SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). }
{$IFNDEF DISABLE_DEPRECATED}
{$IFNDEF _FPC}
{$IFNDEF _D2} //------- WideString not supported in D2
function RE_WSearchText( const Value: WideString; MatchCase, WholeWord, ScanForward: Boolean;
SearchFrom, SearchTo: Integer ): Integer;
{* |<#richedit>
Searches given string starting from SearchFrom position up to SearchTo
position (to the end of text, if SearchTo is -1). Returns zero-based
character position of the next match, or -1 if there are no more matches.
To search in bacward direction, set ScanForward to False, and pass
SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). }
{$ENDIF}
{$ENDIF}
{$ENDIF DISABLE_DEPRECATED}
property RE_AutoURLDetect: Boolean read REGetAutoURLDetect write RESetAutoURLDetect;
{* |<#richedit>
If set to True, automatically detects URLs (and highlights it with
blue color, applying fsItalic and fsUnderline font styles (while
typing and loading). Default value is False. Note: if event OnRE_URLClick
or event OnRE_OverURL are set, property RE_AutoURLDetect is set to True
automatically. }
property RE_URL: KOLString read fREUrl;
{* |<#richedit>
Detected URL (valid in OnRE_OverURL and OnRE_URLClick event handlers). }
property OnRE_OverURL: TOnEvent index 0
{$IFDEF F_P} read REGetOnURL
{$ELSE DELPHI} read fOnREOverURL
{$ENDIF F_P/DELPHI} write RESetOnURL;
{* |<#richedit>
Is called when mouse is moving over URL. This can be used to set
cursor, for example, depending on type of URL (to determine URL type
read property RE_URL). }
property OnRE_URLClick: TOnEvent index 8
{$IFDEF F_P} read REGetOnURL
{$ELSE DELPHI} read fOnREURLClick
{$ENDIF F_P/DELPHI} write RESetOnURL;
{* |<#richedit>
Is called when click on URL detected. }
//property RE_SelectionBar: Boolean read REGetSelectionBar write RESetSelectionBar;
//{* ??? - don't know that is this... }
function RE_NoOLEDragDrop: PControl;
{* |<#richedit>
Just prevents drop OLE objects to the rich edit control. Seems not
working for some cases. }
//function RE_Wyswig: PControl;
function RE_Bottomless: PControl;
// finished ?
property RE_Transparent: Boolean read REGetTransparent write RESetTransparent;
{* |<#richedit>
Use this property to make richedit control transparent, instead of
Ed_Transparent or Transparent. But do not place such transparent
richedit control directly on form - it can be draw incorrectly when
form is activated and rich editr control is not current active control.
Use at least panel as a parent instead.
}
property RE_Zoom: TSmallPoint read REGetZoom write RESetZoom;
{* |<#richedit>
To set zooming for rich edit control (3.0 and above), pass X as numerator
and Y as denominator. Resulting X/Y must be between 1/64 and 64. }
{$ENDIF NOT_USE_RICHEDIT}
//========== both for Edit and RichEdit: =====================
function CanUndo: Boolean;
{* |<#richedit>
|<#edit>
|<#memo>
Returns True, if the edit (or RichEdit) control can correctly process
the EM_UNDO message. }
procedure EmptyUndoBuffer;
{* |<#richedit>
|<#edit>
|<#memo>
Reset the undo flag of an edit control, preventing undoing all previous
changes. }
function Undo: Boolean;
{* |<#richedit>
|<#edit>
|<#memo>
For a single-line edit control, the return value is always TRUE. For a
multiline edit control and RichEdit control, the return value is TRUE if
the undo operation is successful, or FALSE if the undo operation fails. }
{$IFNDEF NOT_USE_RICHEDIT}
function RE_Redo: Boolean;
{* |<#richedit>
Only for RichEdit control: Returns True if successful. }
{$ENDIF NOT_USE_RICHEDIT}
//----------------------------------------------------------------------
// DateTimePicker
property OnDTPUserString: TDTParseInputEvent read FOnDTPUserString
write FOnDTPUserString;
{* Special event to parse input from the application. Option dtpoParseInput
must be set when control is created. }
property DateTime: TDateTime read GetDateTime write SetDateTime;
{* DateTime for DateTimePicker control only. }
property Date: TDateTime read GetDate write SetDate;
{* Date only for DateTimePicker control only. }
property Time: TDateTime read GetTime write SetTime;
{* Time only for DateTimePicker control only. }
property SystemTime: TSystemTime read Get_SystemTime write Set_SystemTime;
{* Date and Time as TSystemTime. When assing, use year 0 to set "no value". }
property DateTimeRange: TDateTimeRange read GetDateTimeRange
write SetDateTimeRange;
{* DateTimePicker range. If first date in the agrument assigned is NAN,
minimum system allowed value is used as the left bound, and if the second is
NAN, maximum system allowed is used as the right one. }
property DateTimePickerColors[ Index: TDateTimePickerColor ]: TColor
read GetDateTimePickerColor write SetDateTimePickerColor;
property DateTimeFormat: KOLString write SetDateTimeFormat;
//----------------------------------------------------------------------
//----------------------------------------------------------------------
// ScrollBar
property SBMin: Longint read fSBMinMax.X write SetSBMin;
{* }
property SBMax: Longint read fSBMinMax.Y write SetSBMax;
{* }
property SBMinMax: TPoint read fSBMinMax write SetSBMinMax;
{* }
property SBPosition: Integer read fSBPosition write SetSBPosition;
{* }
property SBPageSize: Integer read fSBPageSize write SetSBPageSize;
{* }
property OnSBBeforeScroll: TOnSBBeforeScroll read FOnSBBeforeScroll write FOnSBBeforeScroll;
{* }
property OnSBScroll: TOnSBScroll read FOnSBScroll write FOnSBScroll;
{* }
function SBSetScrollInfo(const SI: TScrollInfo): Integer;
function SBGetScrollInfo(var SI: TScrollInfo): Boolean;
function GetSBMinMax: TPoint;
function GetSBPageSize: Integer;
function GetSBPosition: Integer;
//----------------------------------------------------------------------
// "Through", or "transparent" methods to simplify initial
// adjustment of controls and make non-visual designing of
// forms more easy. All these functions return @Self as a
// result, so, it is possible to use such methods immediately
// in constructing statement, concatenating it with dots, e.g.:
//
// NewButton( MyForm, 'Click here' ).PlaceUnder.ResizeParentBottom;
//
{$ENDIF GDI}
function PlaceRight: PControl;
{* Places control right (to previously created on the same parent). }
function PlaceDown: PControl;
{* Places control below (to previously created on the same parent).
Left position is not changed (thus is, kept equal to Parent.Margin). }
function PlaceUnder: PControl;
{* Places control below (to previously created one, aligning its
Left position to Left position of previous control). }
function SetSize( W, H: Integer ): PControl;
{* Changes size of a control. If W or H less or equal to 0,
correspondent size is not changed. }
{$IFDEF GDI}
function Size( W, H: Integer ): PControl;
{* Like SetSize, but provides automatic resizing of parent control
(recursively). Especially useful for aligned controls. }
function SetClientSize( W, H: Integer ): PControl;
{* Like SetSize, but works setting W = ClientWidth, H = ClientHeight.
Use this method for forms, which can not be resized (dialogs). }
{$ENDIF GDI}
function AutoSize( AutoSzOn: Boolean ): PControl;
{$IFDEF GDI}
function MakeWordWrap: PControl;
{* Determines if to autosize control (like label, button, etc.) }
function IsAutoSize: Boolean;
{* TRUE, if a control is autosizing. }
function AlignLeft( P: PControl ): PControl;
{* assigns Left := P.Left }
function AlignTop( P: PControl ): PControl;
{* assigns Top := P.Top }
function ResizeParent: PControl;
{* Resizes parent, calling ResizeParentRight and ResizeParentBottom. }
function ResizeParentRight: PControl;
{* Resizes parent right edge (Margin of parent is added to right
coordinate of a control). If called second time (for the same
parent), resizes only for increasing of right edge of parent. }
function ResizeParentBottom: PControl;
{* Resizes parent bottom edge (Margin of parent is added to
bottom coordinate of a control). }
function CenterOnParent: PControl;
{* Centers control on parent, or if applied to a form, centers
form on screen. }
function Shift( dX, dY : Integer ): PControl;
{* Moves control respectively to current position (Left := Left + dX,
Top := Top + dY). }
{$ENDIF GDI}
function SetPosition( X, Y: Integer ): PControl;
{* Moves control directly to the specified position. }
{$IFDEF GDI}
function Tabulate: PControl;
{* Call it once for form/applet to provide tabulation between controls on
form/on all forms using TAB / SHIFT+TAB and arrow keys. }
function TabulateEx: PControl;
{* Call it once for form/applet to provide tabulation between controls on
form/on all forms using TAB / SHIFT+TAB and arrow keys. Arrow keys are
used more smart, allowing go to nearest control in certain direction. }
function SetAlign( AAlign: TControlAlign ): PControl;
{* Assigns passed value to property Align, aligning control on parent,
and returns @Self (so it is "transparent" function, which can be
used to adjust control at the creation, e.g.:
! MyLabel := NewLabel( MyForm, 'Label1' ).SetAlign( caBottom );
See also property Align. }
function PreventResizeFlicks: PControl;
{* If called, prevents resizing flicks for child controls, aligned to
right and bottom (but with a lot of code added to executable - about 3,5K).
There is sensible to set DoubleBuffered to True also to eliminate the
most of flicks.
|
This method been applied to a form, prevents, resizing flicks for
form and all controls on the form. If it is called for applet window,
all forms are affected. And if You want, You can apply it for certain
control only - in such case only given control and its children will
be resizing without flicks (e.g., using splitter control). }
property Checked: Boolean read GetChecked write Set_Checked;
{* |<#checkbox>
|<#radiobox>
For checkbox and radiobox - if it is checked. Do not assign
value for radiobox - use SetRadioChecked instead. }
function SetChecked(const Value: Boolean): PControl;
{* |<#checkbox>
Use it to check/uncheck check box control or push button.
Do not apply it to check radio buttons - use SetRadioChecked
method below. }
function SetRadioChecked : PControl;
{* |<#radiobox>
Use it to check radio button item correctly (unchecking all
alternative ones). Actually, method Click is called, and control
itself is returned. }
function SetRadioCheckedOld: PControl;
{* |<#radiobox>
Old version of SetRadioChecked (implemented using recommended API
call. It does not work properly, if control is not visible
(together with its form). }
property Check3: TTriStateCheck read GetCheck3 write SetCheck3;
{* |<#checkbox>
State of checkbox with BS_AUTO3STATE style. }
procedure Click;
{* |<#button>
|<#checkbox>
|<#radiobox>
Emulates click on control programmatically, sending WM_COMMAND
message with BN_CLICKED code. This method is sensible only for
buttons, checkboxes and radioboxes. }
function Perform( msgcode: DWORD; wParam, lParam: Integer): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Sends message to control's window (created if needed). }
function Postmsg( msgcode: DWORD; wParam, lParam: Integer): Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Sends message to control's window (created if needed). }
procedure AttachProc( Proc: TWindowFunc );
{* It is possible to attach dynamically any message handler to window
procedure using this method. Last attached procedure is called first.
If procedure returns True, further processing of a message is stopped.
Attached procedure can be detached using DetachProc (but do not
attach/detach procedures during handling of attached procedure -
this can hang application). }
procedure AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );
{* The same as AttachProc, but a handler is executed even after terminating
the main message loop processing (i.e. after assigning true to
AppletTerminated global variable. }
function IsProcAttached( Proc: TWindowFunc ): Boolean;
{* Returns True, if given procedure is already in chain of attached
ones for given control window proc. }
procedure DetachProc( Proc: TWindowFunc );
{* Detaches procedure attached earlier using AttachProc. }
property OnDropFiles: TOnDropFiles read FOnDropFiles write SetOnDropFiles;
{* Assign this event to your handler, if You want to accept drag and drop
files from other applications such as explorer onto your control. When
this event is assigned to a control or form, this has effect also for
all its child controls too. }
property CustomData: Pointer read fCustomData write fCustomData;
{* Can be used to exend the object when new type of control added. Memory,
pointed by this pointer, released automatically in the destructor. }
property CustomObj: PObj read fCustomObj write fCustomObj;
{* Can be used to exend the object when new type of control added. Object,
pointed by this pointer, released automatically in the destructor. }
procedure SetAutoPopupMenu( PopupMenu: PObj );
{* To assign a popup menu to the control, call SetAutoPopupMenu method of
the control with popup menu object as a parameter. }
function SupportMnemonics: PControl;
{* This method provides supporting mnemonic keys in menus, buttons, checkboxes,
toolbar buttons. }
property OnScroll: TOnScroll read FOnScroll write SetOnScroll;
{* }
protected
{$IFDEF USE_DROPDOWNCOUNT}
fDropDownCount: Cardinal;
{$ENDIF}
fGraphCtlMouseEvent: TOnGraphCtlMouse;
public
{$IFDEF USE_DROPDOWNCOUNT}
property DropDownCount: Cardinal read fDropDownCount write fDropDownCount;
{$ENDIF}
protected
fPushedBtn: PControl;
fFocused: Boolean;
fEditOptions: TEditOptions;
fEditCtl: PControl;
fSetFocus: procedure of object;
fSaveCursor: HCursor;
fLeave: TOnEvent;
fKeyboardProcess: TOnMessage;
fHot: Boolean;
fPressed : boolean;
fHotCtl: PControl;
fMouseLeaveProc: TOnEvent;
fIsGroupBox: Boolean;
fIsBitBtn: Boolean;
fIsSplitter: Boolean;
fErasingBkgnd: Boolean;
fButtonIcon: HIcon;
fActivating: Boolean;
fFixingModal: Integer;
{$IFDEF USE_GRAPHCTLS}
function DoGraphCtlPrepaint: TRect;
procedure GraphicLabelPaint( DC: HDC );
procedure GraphicCheckBoxPaint( DC: HDC );
procedure GraphicCheckBoxMouse( var Msg: TMsg );
procedure GraphicRadioBoxPaint( DC: HDC );
procedure GraphicButtonPaint( DC: HDC );
procedure GraphicButtonMouse( var Msg: TMsg );
procedure GraphButtonSetFocus;
function GraphButtonKeyboardProcess( var Msg: TMsg; var Rslt: Integer ): Boolean;
procedure LeaveGraphButton( Sender: PObj );
procedure GraphicEditPaint( DC: HDC );
procedure GraphicEditMouse( var Msg: TMsg );
function EditGraphEdit: PControl;
procedure DestroyGraphEdit( Sender: PObj );
procedure LeaveGraphEdit( Sender: PObj );
procedure ChangeGraphEdit( Sender: PObj );
procedure GraphEditboxSetFocus;
procedure GraphCtlDrawFocusRect( DC: HDC; const R: TRect );
{$IFDEF GRAPHCTL_HOTTRACK}
procedure MouseLeaveFromParentOfGraphCtl( Sender: PObj );
{$ENDIF GRAPHCTL_HOTTRACK}
procedure GroupBoxPaint( DC: HDC );
{$ENDIF USE_GRAPHCTLS}
{$IFDEF KEY_PREVIEW}
protected
fKeyPreview: Boolean;
fKeyPreviewing: Boolean;
fKeyPreviewCount: Integer;
public
property KeyPreview: Boolean read fKeyPreview write fKeyPreview;
property KeyPreviewing: Boolean read fKeyPreviewing write fKeyPreviewing;
{$ENDIF KEY_PREVIEW}
protected
fAnchorLeft: Boolean; //+Sormart
fAnchorTop: Boolean; //+Sormart
fAnchorRight: Boolean;
fAnchorBottom: Boolean;
fOldWidth, fOldHeight: Integer;
procedure SetAnchorLeft(const Value: Boolean); //+Sormart
procedure SetAnchorTop(const Value: Boolean); //+Sormart
procedure SetAnchorRight( Value: Boolean );
procedure SetAnchorBottom( Value: Boolean );
public
property AnchorLeft: Boolean read fAnchorLeft write SetAnchorLeft default true; //+Sormart
property AnchorTop: Boolean read fAnchorTop write SetAnchorTop default true; //+Sormart
property AnchorRight: Boolean read fAnchorRight write SetAnchorRight;
property AnchorBottom: Boolean read fAnchorBottom write SetAnchorBottom;
function Anchor( aLeft, aTop, aRight, aBottom: Boolean ): PControl;
public
{$IFDEF USE_CONSTRUCTORS}
//------------------------------------------------------------
// constructors here:
constructor CreateWindowed( AParent: PControl; AClassName: PKOLChar; ACtl3D: Boolean );
constructor CreateApplet( const ACaption: String );
constructor CreateForm( AParent: PControl; const ACaption: String );
constructor CreateControl( AParent: PControl; AClassName: PChar; AStyle: DWORD;
ACtl3D: Boolean; Actions: PCommandActions );
constructor CreateButton( AParent: PControl; const ACaption: String );
constructor CreateBitBtn( AParent: PControl; const ACaption: String;
AOptions: TBitBtnOptions; ALayout: TGlyphLayout; AGlyphBitmap: HBitmap;
AGlyphCount: Integer);
constructor CreateLabel( AParent: PControl; const ACaption: String );
constructor CreateWordWrapLabel( AParent: PControl; const ACaption: String );
constructor CreateLabelEffect( AParent: PControl; ACaption: String; AShadowDeep: Integer );
constructor CreatePaintBox( AParent: PControl );
constructor CreateGradientPanel( AParent: PControl; AColor1, AColor2: TColor );
constructor CreateGradientPanelEx( AParent: PControl; AColor1, AColor2: TColor;
AStyle: TGradientStyle; ALayout: TGradientLayout );
constructor CreateGroupbox( AParent: PControl; const ACaption: String );
constructor CreateCheckbox( AParent: PControl; const ACaption: String );
constructor CreateRadiobox( AParent: PControl; const ACaption: String );
constructor CreateEditbox( AParent: PControl; AOptions: TEditOptions );
constructor CreatePanel( AParent: PControl; AStyle: TEdgeStyle );
constructor CreateSplitter( AParent: PControl; AMinSizePrev, AMinSizeNext: Integer;
EdgeStyle: TEdgeStyle );
constructor CreateListbox( AParent: PControl; AOptions: TListOptions );
constructor CreateCombobox( AParent: PControl; AOptions: TComboOptions );
constructor CreateCommonControl( AParent: PControl; AClassName: PChar; AStyle: DWORD;
ACtl3D: Boolean; Actions: PCommandActions );
constructor CreateRichEdit( AParent: PControl; AOptions: TEditOptions );
constructor CreateRichEdit1( AParent: PControl; AOptions: TEditOptions );
constructor CreateProgressbar( AParent: PControl );
constructor CreateProgressbarEx( AParent: PControl; AOptions: TProgressbarOptions );
constructor CreateListView( AParent: PControl; AStyle: TListViewStyle; AOptions: TListViewOptions;
AImageListSmall, AImageListNormal, AImageListState: PImageList );
constructor CreateTreeView( AParent: PControl; AOptions: TTreeViewOptions;
AImgListNormal, AImgListState: PImageList );
constructor CreateTabControl( AParent: PControl; ATabs: array of String;
AOptions: TTabControlOptions; AImgList: PImageList; AImgList1stIdx: Integer );
constructor CreateToolbar( AParent: PControl; AAlign: TControlAlign; AOptions: TToolbarOptions;
ABitmap: HBitmap; AButtons: array of PChar;
ABtnImgIdxArray: array of Integer );
{$ENDIF USE_CONSTRUCTORS}
{$IFDEF USE_CUSTOMEXTENSIONS}
{$I CUSTOM_TCONTROL_EXTENSION.inc}
{$ENDIF}
// If an option USE_CUSTOMEXTENSIONS is enabled (at the beginning of this
// unit), You can freely extend TControl definition by your own fields,
// methods and properties. This provides You with capability to extend
// TControl implementing another kinds of visual controls without deriving
// new descendant objects from TControl. This way is provided to avoid too
// large grow of executable size. You also can derive your own controls
// from TControl using standard OOP capabilities. In such case an option
// USE_CONSTRUCTORS should be turned on (see it at the start of this unit).
// If You choose this "flat" model of extending the TControl with your
// own properties, fieds, methods, events, etc. You should provide three
// inc-files: CUSTOM_TCONTROL_EXTENSION.inc, containing such definitions
// for TControl, CUSTOM_KOL_EXTENSION.inc, containing needed global
// declarations, and CUSTOM_CODE_EXTENSION.inc, the implementation of those
// two.
// Because KOL is always grow and constantly is extending by me, I also can
// add my own complements for TControl. To avoid naming conflicts, I suggest
// to use the same naming rule for all of You. Name your fields, properies, etc.
// using a form idx_SomeName, where idx is a prefix, containing several
// (at least one) letters and digits. E.g. ZK65_OnSomething.
protected
fParentCoordX: Integer;
fParentCoordY: Integer;
// last changes (1-Jul-06) from ECM [Michalichenko Eugeny, rest in peace, friend]:
//======== ListBox
private
function GetLBTopIndex: Integer;
procedure SetLBTopIndex(const Value: Integer);
public
function LBItemAtPos(X,Y: Integer): Integer;
{* |<#listbox>
Return index of item at the given position. }
property LBTopIndex: Integer read GetLBTopIndex write SetLBTopIndex;
{* |<#listbox>
Index of the first visible item in a list box}
//_________
procedure MakeScrollable;
{* Adds scrollbars to the control if its children do not fit client area. Useful for PocketPC dialog boxes. }
{$ENDIF GDI}
procedure DisableAlign;
{* Disable alignment of child controls. }
procedure EnableAlign;
{* Enable alignment of child controls. }
end;
//[END OF TControl DEFINITION]
{$IFDEF USE_MHTOOLTIP}
{$DEFINE interface}
{$I KOLMHToolTip.pas}
{$UNDEF interface}
{$ENDIF}
{$IFDEF WIN_GDI}
function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect;
{* Use this function instead of reading TControl.TBButtonRect, if you want
to have it working the same way when standard toolbar is used or GRushControl
toolbar provided in ToGRush.pas unit.
}
procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer; const Tooltips: array of PKOLChar );
{* Use this function instead of TContol.TBSetTooltips in your project, when
you use ToGRush unit.
}
function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean;
{* Use this function instead of reading the property TControl.TBButtonEnabled
when tou use ToGRush unit. }
procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean );
{* Use this procedure instead of writing the property TControl.TBButtonEnabled
when you use ToGRush unit. }
function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean;
{* Use this function instead of reading the property TControl.TBButtonVisible
when tou use ToGRush unit. }
procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean );
{* Use this procedure instead of writing the property TControl.TBButtonVisible
when you use ToGRush unit. }
function ToolbarButtonChecked( Toolbar: PControl; BtnID: Integer): Boolean;
{* }
procedure ToolbarButtonSetChecked( Toolbar: PControl; BtnID: Integer; Checked: Boolean );
{* }
{$ENDIF WIN_GDI}
var ToolbarsIDcmd: Integer = 100;
//[Paint Background PROCEDURE]
type
TOnPaintBkgnd = procedure( Sender: PControl; DC: HDC; Rect: PRect );
{* Global event definition. Used to define Global_OnPaintBackground
event placeholder. }
procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );
var
Global_OnPaintBkgnd: TOnPaintBkgnd = DefaultPaintBackground;
{* Global event. It is assigned in XBackgounds.pas add-on to replace
PaintBackground method for all TVisual objects, allowing great
visualization effect: transparent controls over [animated] bitmap
background. Idea:
| Wei Bao. Implementation:
| Kladov Vladimir. }
procedure DummyPaintProc( Sender: PControl; DC: HDC );
//[GetShiftState DECLARATION]
function GetShiftState: DWORD;
{* Returns shift state. }
{$IFDEF WIN_GDI}
//[WndProcXXX DECLARATIONS]
function WndProcMouse( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
function WndProcKeybd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
function WndProcDummy( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
{$ENDIF}
function AutoMinimizeApplet(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
{* By Sergey Shishmintzev.
Attach this handler to your modal dialog form handle to provide automatic
minimization of all other forms in the application together with the dialog. }
//[InitCommonXXXX DECLARATIONS]
procedure InitCommonControlSizeNotify( Ctrl: PControl );
procedure InitCommonControlCommonNotify( Ctrl: PControl );
//[Buffered Draw DECLARATIONS]
procedure DummyAttachProcExtension ( DynHandlers: PList );
{$ifdef win32}
procedure TransparentAttachProcExtension ( DynHandlers: PList );
{$endif win32}
{$IFNDEF SMALLEST_CODE}
var Global_AttachProcExtension: procedure( DynHandlers: PList ) = DummyAttachProcExtension;
{$ENDIF}
{$ENDIF WIN_GDI}
var HelpFilePath: PChar;
{* Path to application help file. If not assigned, application path with
extension replaced to '.hlp' used. To use '.chm' file (HtmlHelp),
call AssignHtmlHelp with a path to a html help file (or a name). }
{$IFDEF WIN_GDI}
//[Html Help DECLARATIONS]
procedure AssignHtmlHelp( const HtmlHelpPath: KOLString );
procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: String; Cmd, Data: Integer );
{* Use this wrapper procedure to call HtmlHelp API function. }
//+++++++++++ HTML HELP DEFINITIONS SECTION:
// this section is from
// HTML Help API Interface Unit
// Copyright (c) 1999 The Helpware Group
// provided for KOL by Alexey Babenko
const
HH_DISPLAY_TOPIC = $0000; {**}
HH_HELP_FINDER = $0000; // WinHelp equivalent
HH_DISPLAY_TOC = $0001; // not currently implemented
HH_DISPLAY_INDEX = $0002; // not currently implemented
HH_DISPLAY_SEARCH = $0003; // not currently implemented
HH_SET_WIN_TYPE = $0004;
HH_GET_WIN_TYPE = $0005;
HH_GET_WIN_HANDLE = $0006;
HH_ENUM_INFO_TYPE = $0007; // Get Info type name, call repeatedly to enumerate, -1 at end
HH_SET_INFO_TYPE = $0008; // Add Info type to filter.
HH_SYNC = $0009;
HH_RESERVED1 = $000A;
HH_RESERVED2 = $000B;
HH_RESERVED3 = $000C;
HH_KEYWORD_LOOKUP = $000D;
HH_DISPLAY_TEXT_POPUP = $000E; // display string resource id or text in a popup window
HH_HELP_CONTEXT = $000F; {**}// display mapped numeric value in dwData
HH_TP_HELP_CONTEXTMENU = $0010; // text popup help, same as WinHelp HELP_CONTEXTMENU
HH_TP_HELP_WM_HELP = $0011; // text popup help, same as WinHelp HELP_WM_HELP
HH_CLOSE_ALL = $0012; // close all windows opened directly or indirectly by the caller
HH_ALINK_LOOKUP = $0013; // ALink version of HH_KEYWORD_LOOKUP
HH_GET_LAST_ERROR = $0014; // not currently implemented // See HHERROR.h
HH_ENUM_CATEGORY = $0015; // Get category name, call repeatedly to enumerate, -1 at end
HH_ENUM_CATEGORY_IT = $0016; // Get category info type members, call repeatedly to enumerate, -1 at end
HH_RESET_IT_FILTER = $0017; // Clear the info type filter of all info types.
HH_SET_INCLUSIVE_FILTER = $0018; // set inclusive filtering method for untyped topics to be included in display
HH_SET_EXCLUSIVE_FILTER = $0019; // set exclusive filtering method for untyped topics to be excluded from display
HH_INITIALIZE = $001C; // Initializes the help system.
HH_UNINITIALIZE = $001D; // Uninitializes the help system.
HH_PRETRANSLATEMESSAGE = $00fd; // Pumps messages. (NULL, NULL, MSG*).
HH_SET_GLOBAL_PROPERTY = $00fc; // Set a global property. (NULL, NULL, HH_GPROP)
{ window properties }
const
HHWIN_PROP_TAB_AUTOHIDESHOW = $00000001; // (1 << 0) Automatically hide/show tri-pane window
HHWIN_PROP_ONTOP = $00000002; // (1 << 1) Top-most window
HHWIN_PROP_NOTITLEBAR = $00000004; // (1 << 2) no title bar
HHWIN_PROP_NODEF_STYLES = $00000008; // (1 << 3) no default window styles (only HH_WINTYPE.dwStyles)
HHWIN_PROP_NODEF_EXSTYLES = $00000010; // (1 << 4) no default extended window styles (only HH_WINTYPE.dwExStyles)
HHWIN_PROP_TRI_PANE = $00000020; // (1 << 5) use a tri-pane window
HHWIN_PROP_NOTB_TEXT = $00000040; // (1 << 6) no text on toolbar buttons
HHWIN_PROP_POST_QUIT = $00000080; // (1 << 7) post WM_QUIT message when window closes
HHWIN_PROP_AUTO_SYNC = $00000100; // (1 << 8) automatically ssync contents and index
HHWIN_PROP_TRACKING = $00000200; // (1 << 9) send tracking notification messages
HHWIN_PROP_TAB_SEARCH = $00000400; // (1 << 10) include search tab in navigation pane
HHWIN_PROP_TAB_HISTORY = $00000800; // (1 << 11) include history tab in navigation pane
HHWIN_PROP_TAB_FAVORITES = $00001000; // (1 << 12) include favorites tab in navigation pane
HHWIN_PROP_CHANGE_TITLE = $00002000; // (1 << 13) Put current HTML title in title bar
HHWIN_PROP_NAV_ONLY_WIN = $00004000; // (1 << 14) Only display the navigation window
HHWIN_PROP_NO_TOOLBAR = $00008000; // (1 << 15) Don't display a toolbar
HHWIN_PROP_MENU = $00010000; // (1 << 16) Menu
HHWIN_PROP_TAB_ADVSEARCH = $00020000; // (1 << 17) Advanced FTS UI.
HHWIN_PROP_USER_POS = $00040000; // (1 << 18) After initial creation, user controls window size/position
HHWIN_PROP_TAB_CUSTOM1 = $00080000; // (1 << 19) Use custom tab #1
HHWIN_PROP_TAB_CUSTOM2 = $00100000; // (1 << 20) Use custom tab #2
HHWIN_PROP_TAB_CUSTOM3 = $00200000; // (1 << 21) Use custom tab #3
HHWIN_PROP_TAB_CUSTOM4 = $00400000; // (1 << 22) Use custom tab #4
HHWIN_PROP_TAB_CUSTOM5 = $00800000; // (1 << 23) Use custom tab #5
HHWIN_PROP_TAB_CUSTOM6 = $01000000; // (1 << 24) Use custom tab #6
HHWIN_PROP_TAB_CUSTOM7 = $02000000; // (1 << 25) Use custom tab #7
HHWIN_PROP_TAB_CUSTOM8 = $04000000; // (1 << 26) Use custom tab #8
HHWIN_PROP_TAB_CUSTOM9 = $08000000; // (1 << 27) Use custom tab #9
HHWIN_TB_MARGIN = $10000000; // (1 << 28) the window type has a margin
{ window parameters }
const
HHWIN_PARAM_PROPERTIES = $00000002; // (1 << 1) valid fsWinProperties
HHWIN_PARAM_STYLES = $00000004; // (1 << 2) valid dwStyles
HHWIN_PARAM_EXSTYLES = $00000008; // (1 << 3) valid dwExStyles
HHWIN_PARAM_RECT = $00000010; // (1 << 4) valid rcWindowPos
HHWIN_PARAM_NAV_WIDTH = $00000020; // (1 << 5) valid iNavWidth
HHWIN_PARAM_SHOWSTATE = $00000040; // (1 << 6) valid nShowState
HHWIN_PARAM_INFOTYPES = $00000080; // (1 << 7) valid apInfoTypes
HHWIN_PARAM_TB_FLAGS = $00000100; // (1 << 8) valid fsToolBarFlags
HHWIN_PARAM_EXPANSION = $00000200; // (1 << 9) valid fNotExpanded
HHWIN_PARAM_TABPOS = $00000400; // (1 << 10) valid tabpos
HHWIN_PARAM_TABORDER = $00000800; // (1 << 11) valid taborder
HHWIN_PARAM_HISTORY_COUNT = $00001000; // (1 << 12) valid cHistory
HHWIN_PARAM_CUR_TAB = $00002000; // (1 << 13) valid curNavType
{ button constants }
const
HHWIN_BUTTON_EXPAND = $00000002; // (1 << 1) Expand/contract button
HHWIN_BUTTON_BACK = $00000004; // (1 << 2) Back button
HHWIN_BUTTON_FORWARD = $00000008; // (1 << 3) Forward button
HHWIN_BUTTON_STOP = $00000010; // (1 << 4) Stop button
HHWIN_BUTTON_REFRESH = $00000020; // (1 << 5) Refresh button
HHWIN_BUTTON_HOME = $00000040; // (1 << 6) Home button
HHWIN_BUTTON_BROWSE_FWD = $00000080; // (1 << 7) not implemented
HHWIN_BUTTON_BROWSE_BCK = $00000100; // (1 << 8) not implemented
HHWIN_BUTTON_NOTES = $00000200; // (1 << 9) not implemented
HHWIN_BUTTON_CONTENTS = $00000400; // (1 << 10) not implemented
HHWIN_BUTTON_SYNC = $00000800; // (1 << 11) Sync button
HHWIN_BUTTON_OPTIONS = $00001000; // (1 << 12) Options button
HHWIN_BUTTON_PRINT = $00002000; // (1 << 13) Print button
HHWIN_BUTTON_INDEX = $00004000; // (1 << 14) not implemented
HHWIN_BUTTON_SEARCH = $00008000; // (1 << 15) not implemented
HHWIN_BUTTON_HISTORY = $00010000; // (1 << 16) not implemented
HHWIN_BUTTON_FAVORITES = $00020000; // (1 << 17) not implemented
HHWIN_BUTTON_JUMP1 = $00040000; // (1 << 18)
HHWIN_BUTTON_JUMP2 = $00080000; // (1 << 19)
HHWIN_BUTTON_ZOOM = $00100000; // (1 << 20)
HHWIN_BUTTON_TOC_NEXT = $00200000; // (1 << 21)
HHWIN_BUTTON_TOC_PREV = $00400000; // (1 << 22)
HHWIN_DEF_BUTTONS = (HHWIN_BUTTON_EXPAND
OR HHWIN_BUTTON_BACK
OR HHWIN_BUTTON_OPTIONS
OR HHWIN_BUTTON_PRINT);
{ Button IDs }
const
IDTB_EXPAND = 200;
IDTB_CONTRACT = 201;
IDTB_STOP = 202;
IDTB_REFRESH = 203;
IDTB_BACK = 204;
IDTB_HOME = 205;
IDTB_SYNC = 206;
IDTB_PRINT = 207;
IDTB_OPTIONS = 208;
IDTB_FORWARD = 209;
IDTB_NOTES = 210; // not implemented
IDTB_BROWSE_FWD = 211;
IDTB_BROWSE_BACK = 212;
IDTB_CONTENTS = 213; // not implemented
IDTB_INDEX = 214; // not implemented
IDTB_SEARCH = 215; // not implemented
IDTB_HISTORY = 216; // not implemented
IDTB_FAVORITES = 217; // not implemented
IDTB_JUMP1 = 218;
IDTB_JUMP2 = 219;
IDTB_CUSTOMIZE = 221;
IDTB_ZOOM = 222;
IDTB_TOC_NEXT = 223;
IDTB_TOC_PREV = 224;
{ Notification codes }
const
HHN_FIRST = (0-860);
HHN_LAST = (0-879);
HHN_NAVCOMPLETE = (HHN_FIRST-0);
HHN_TRACK = (HHN_FIRST-1);
HHN_WINDOW_CREATE = (HHN_FIRST-2);
type
{*** Used by command HH_GET_LAST_ERROR
NOTE: Not part of the htmlhelp.h but documented in HH Workshop help
You must call SysFreeString(xx.description) to free BSTR
}
tagHH_LAST_ERROR = {$ifndef wince}packed{$endif} record
cbStruct: Integer; // sizeof this structure
hr: Integer; // Specifies the last error code.
description: PWideChar; // (BSTR) Specifies a Unicode string containing a description of the error.
end;
HH_LAST_ERROR = tagHH_LAST_ERROR;
THHLastError = tagHH_LAST_ERROR;
type
{*** Notify event info for HHN_NAVCOMPLETE, HHN_WINDOW_CREATE }
PHHNNotify = ^THHNNotify;
tagHHN_NOTIFY = {$ifndef wince}packed{$endif} record
hdr: TNMHdr;
pszUrl: PChar; //PCSTR: Multi-byte, null-terminated string
end;
HHN_NOTIFY = tagHHN_NOTIFY;
THHNNotify = tagHHN_NOTIFY;
{** Use by command HH_DISPLAY_TEXT_POPUP}
PHHPopup = ^THHPopup;
tagHH_POPUP = {$ifndef wince}packed{$endif} record
cbStruct: Integer; // sizeof this structure
hinst: HINST; // instance handle for string resource
idString: cardinal; // string resource id, or text id if pszFile is specified in HtmlHelp call
pszText: PChar; // used if idString is zero
pt: TPOINT; // top center of popup window
clrForeground: COLORREF; // use -1 for default
clrBackground: COLORREF; // use -1 for default
rcMargins: TRect; // amount of space between edges of window and text, -1 for each member to ignore
pszFont: PChar; // facename, point size, char set, BOLD ITALIC UNDERLINE
end;
HH_POPUP = tagHH_POPUP;
THHPopup = tagHH_POPUP;
{** Use by commands - HH_ALINK_LOOKUP, HH_KEYWORD_LOOKUP}
PHHAKLink = ^THHAKLink;
tagHH_AKLINK = {$ifndef wince}packed{$endif} record
cbStruct: integer; // sizeof this structure
fReserved: BOOL; // must be FALSE (really!)
pszKeywords: PChar; // semi-colon separated keywords
pszUrl: PChar; // URL to jump to if no keywords found (may be NULL)
pszMsgText: PChar; // Message text to display in MessageBox if pszUrl is NULL and no keyword match
pszMsgTitle: PChar; // Message text to display in MessageBox if pszUrl is NULL and no keyword match
pszWindow: PChar; // Window to display URL in
fIndexOnFail: BOOL; // Displays index if keyword lookup fails.
end;
HH_AKLINK = tagHH_AKLINK;
THHAKLink = tagHH_AKLINK;
const
HHWIN_NAVTYPE_TOC = 0;
HHWIN_NAVTYPE_INDEX = 1;
HHWIN_NAVTYPE_SEARCH = 2;
HHWIN_NAVTYPE_FAVORITES = 3;
HHWIN_NAVTYPE_HISTORY = 4; // not implemented
HHWIN_NAVTYPE_AUTHOR = 5;
HHWIN_NAVTYPE_CUSTOM_FIRST = 11;
const
IT_INCLUSIVE = 0;
IT_EXCLUSIVE = 1;
IT_HIDDEN = 2;
type
PHHEnumIT = ^THHEnumIT;
tagHH_ENUM_IT = {$ifndef wince}packed{$endif} record //tagHH_ENUM_IT, HH_ENUM_IT, *PHH_ENUM_IT
cbStruct: Integer; // size of this structure
iType: Integer; // the type of the information type ie. Inclusive, Exclusive, or Hidden
pszCatName: PAnsiChar; // Set to the name of the Category to enumerate the info types in a category; else NULL
pszITName: PAnsiChar; // volitile pointer to the name of the infotype. Allocated by call. Caller responsible for freeing
pszITDescription: PAnsiChar; // volitile pointer to the description of the infotype.
end;
THHEnumIT = tagHH_ENUM_IT;
type
PHHEnumCat = ^THHEnumCat;
tagHH_ENUM_CAT = {$ifndef wince}packed{$endif} record //tagHH_ENUM_CAT, HH_ENUM_CAT, *PHH_ENUM_CAT
cbStruct: Integer; // size of this structure
pszCatName: PAnsiChar; // volitile pointer to the category name
pszCatDescription: PAnsiChar; // volitile pointer to the category description
end;
THHEnumCat = tagHH_ENUM_CAT;
type
PHHSetInfoType = ^THHSetInfoType;
tagHH_SET_INFOTYPE = {$ifndef wince}packed{$endif} record //tagHH_SET_INFOTYPE, HH_SET_INFOTYPE, *PHH_SET_INFOTYPE
cbStruct: Integer; // the size of this structure
pszCatName: PAnsiChar; // the name of the category, if any, the InfoType is a member of.
pszInfoTypeName: PAnsiChar; // the name of the info type to add to the filter
end;
THHSetInfoType = tagHH_SET_INFOTYPE;
type
HH_INFOTYPE = DWORD;
THHInfoType = HH_INFOTYPE;
PHHInfoType = ^THHInfoType; //PHH_INFOTYPE
const
HHWIN_NAVTAB_TOP = 0;
HHWIN_NAVTAB_LEFT = 1;
HHWIN_NAVTAB_BOTTOM = 2;
const
HH_MAX_TABS = 19; // maximum number of tabs
const
HH_TAB_CONTENTS = 0;
HH_TAB_INDEX = 1;
HH_TAB_SEARCH = 2;
HH_TAB_FAVORITES = 3;
HH_TAB_HISTORY = 4;
HH_TAB_AUTHOR = 5;
HH_TAB_CUSTOM_FIRST = 11;
HH_TAB_CUSTOM_LAST = HH_MAX_TABS;
HH_MAX_TABS_CUSTOM = (HH_TAB_CUSTOM_LAST - HH_TAB_CUSTOM_FIRST + 1);
{ HH_DISPLAY_SEARCH Command Related Structures and Constants }
const
HH_FTS_DEFAULT_PROXIMITY = (-1);
type
{** Used by command HH_DISPLAY_SEARCH}
PHHFtsQuery = ^THHFtsQuery;
tagHH_FTS_QUERY = {$ifndef wince}packed{$endif} record //tagHH_FTS_QUERY, HH_FTS_QUERY
cbStruct: integer; // Sizeof structure in bytes.
fUniCodeStrings: BOOL; // TRUE if all strings are unicode.
pszSearchQuery: PChar; // String containing the search query.
iProximity: LongInt; // Word proximity.
fStemmedSearch: Bool; // TRUE for StemmedSearch only.
fTitleOnly: Bool; // TRUE for Title search only.
fExecute: Bool; // TRUE to initiate the search.
pszWindow: PChar; // Window to display in
end;
THHFtsQuery = tagHH_FTS_QUERY;
{ HH_WINTYPE Structure }
type
{** Used by commands HH_GET_WIN_TYPE, HH_SET_WIN_TYPE}
PHHWinType = ^THHWinType;
tagHH_WINTYPE = {$ifndef wince}packed{$endif} record //tagHH_WINTYPE, HH_WINTYPE, *PHH_WINTYPE;
cbStruct: Integer; // IN: size of this structure including all Information Types
fUniCodeStrings: BOOL; // IN/OUT: TRUE if all strings are in UNICODE
pszType: PChar; // IN/OUT: Name of a type of window
fsValidMembers: DWORD; // IN: Bit flag of valid members (HHWIN_PARAM_)
fsWinProperties: DWORD; // IN/OUT: Properties/attributes of the window (HHWIN_)
pszCaption: PChar; // IN/OUT: Window title
dwStyles: DWORD; // IN/OUT: Window styles
dwExStyles: DWORD; // IN/OUT: Extended Window styles
rcWindowPos: TRect; // IN: Starting position, OUT: current position
nShowState: Integer; // IN: show state (e.g., SW_SHOW)
hwndHelp: HWND; // OUT: window handle
hwndCaller: HWND; // OUT: who called this window
paInfoTypes: PHHInfoType; // IN: Pointer to an array of Information Types
{ The following members are only valid if HHWIN_PROP_TRI_PANE is set }
hwndToolBar: HWND; // OUT: toolbar window in tri-pane window
hwndNavigation: HWND; // OUT: navigation window in tri-pane window
hwndHTML: HWND; // OUT: window displaying HTML in tri-pane window
iNavWidth: Integer; // IN/OUT: width of navigation window
rcHTML: TRect; // OUT: HTML window coordinates
pszToc: PChar; // IN: Location of the table of contents file
pszIndex: PChar; // IN: Location of the index file
pszFile: PChar; // IN: Default location of the html file
pszHome: PChar; // IN/OUT: html file to display when Home button is clicked
fsToolBarFlags: DWORD; // IN: flags controling the appearance of the toolbar (HHWIN_BUTTON_)
fNotExpanded: BOOL; // IN: TRUE/FALSE to contract or expand, OUT: current state
curNavType: Integer; // IN/OUT: UI to display in the navigational pane
tabpos: Integer; // IN/OUT: HHWIN_NAVTAB_TOP, HHWIN_NAVTAB_LEFT, or HHWIN_NAVTAB_BOTTOM
idNotify: Integer; // IN: ID to use for WM_NOTIFY messages
tabOrder: packed array[0..HH_MAX_TABS] of Byte; // IN/OUT: tab order: Contents, Index, Search, History, Favorites, Reserved 1-5, Custom tabs
cHistory: Integer; // IN/OUT: number of history items to keep (default is 30)
pszJump1: PChar; // Text for HHWIN_BUTTON_JUMP1
pszJump2: PChar; // Text for HHWIN_BUTTON_JUMP2
pszUrlJump1: PChar; // URL for HHWIN_BUTTON_JUMP1
pszUrlJump2: PChar; // URL for HHWIN_BUTTON_JUMP2
rcMinSize: TRect; // Minimum size for window (ignored in version 1)
cbInfoTypes: Integer; // size of paInfoTypes;
pszCustomTabs: PChar; // multiple zero-terminated strings
end;
HH_WINTYPE = tagHH_WINTYPE;
THHWinType = tagHH_WINTYPE;
const
HHACT_TAB_CONTENTS = 0;
HHACT_TAB_INDEX = 1;
HHACT_TAB_SEARCH = 2;
HHACT_TAB_HISTORY = 3;
HHACT_TAB_FAVORITES = 4;
HHACT_EXPAND = 5;
HHACT_CONTRACT = 6;
HHACT_BACK = 7;
HHACT_FORWARD = 8;
HHACT_STOP = 9;
HHACT_REFRESH = 10;
HHACT_HOME = 11;
HHACT_SYNC = 12;
HHACT_OPTIONS = 13;
HHACT_PRINT = 14;
HHACT_HIGHLIGHT = 15;
HHACT_CUSTOMIZE = 16;
HHACT_JUMP1 = 17;
HHACT_JUMP2 = 18;
HHACT_ZOOM = 19;
HHACT_TOC_NEXT = 20;
HHACT_TOC_PREV = 21;
HHACT_NOTES = 22;
HHACT_LAST_ENUM = 23;
type
{*** Notify event info for HHN_TRACK }
PHHNTrack = ^THHNTrack;
tagHHNTRACK = {$ifndef wince}packed{$endif} record //tagHHNTRACK, HHNTRACK;
hdr: TNMHdr;
pszCurUrl: PChar; // Multi-byte, null-terminated string
idAction: Integer; // HHACT_ value
phhWinType: PHHWinType; // Current window type structure
end;
HHNTRACK = tagHHNTRACK;
THHNTrack = tagHHNTRACK;
///////////////////////////////////////////////////////////////////////////////
//
// Global Control Properties.
//
const
HH_GPROPID_SINGLETHREAD = 1; // VARIANT_BOOL: True for single thread
HH_GPROPID_TOOLBAR_MARGIN = 2; // long: Provides a left/right margin around the toolbar.
HH_GPROPID_UI_LANGUAGE = 3; // long: LangId of the UI.
HH_GPROPID_CURRENT_SUBSET = 4; // BSTR: Current subset.
HH_GPROPID_CONTENT_LANGUAGE = 5; // long: LandId for desired content.
type
tagHH_GPROPID = HH_GPROPID_SINGLETHREAD..HH_GPROPID_CONTENT_LANGUAGE; //tagHH_GPROPID, HH_GPROPID
HH_GPROPID = tagHH_GPROPID;
THHGPropID = HH_GPROPID;
///////////////////////////////////////////////////////////////////////////////
//
// Global Property structure
//
{type
PHHGlobalProperty = ^THHGlobalProperty;
tagHH_GLOBAL_PROPERTY = record //tagHH_GLOBAL_PROPERTY, HH_GLOBAL_PROPERTY
id: THHGPropID;
Dummy: Integer; // Added to enforce 8-byte packing
var_: VARIANT;
end;
HH_GLOBAL_PROPERTY = tagHH_GLOBAL_PROPERTY;
THHGlobalProperty = tagHH_GLOBAL_PROPERTY;}
//[END OF HTMLHELP DECLARATIONS]
{$ENDIF WIN_GDI}
{$IFDEF WIN_GDI}
//[GetCtlBrush DECLARATIONS]
function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush;
var
Global_GetCtlBrushHandle: function( Sender: PControl ): HBrush = SimpleGetCtlBrushHandle;
{* Is called to obtain brush handle. }
{$ENDIF WIN_GDI}
Global_Align: procedure( Sender: PObj ) = DummyObjProc;
{* Is set to perform aligning of control, and only if property Align
is changed for TControl, or SetAlign method is called for it. }
{$IFDEF WIN_GDI}
//[WndFunc DECLARATION]
function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
: Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Global message handler for window. Redirects all messages to
destination windows, obtaining target TControl object address from
window itself, using GetProp API call. }
{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
//[Applet VARIABLES]
var AppletRunning: Boolean;
{* Is set to True while message loop is processing (in Run procedure). }
AppletTerminated: Boolean;
{* Is set to True when message loop is terminated. }
Applet: PControl;
{* Applet window object. Actually, can be set to main form if program
not needed in special applet button window (useful to make applet
button invisible on taskbar, or to have several forms with single
applet button - crete it in that case using NewApplet). }
AppButtonUsed: Boolean;
{* True if special window to represent applet button (may be invisible)
is used. If no, every form is represented with its own taskbar button
(always visible). }
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
//[Screen DECLARATIONS]
ScreenCursor: HCursor;
{* Set this global variable to override any cursor settings of current
form or control. }
function ScreenWidth: Integer;
{* Returns screen width in pixels. }
function ScreenHeight: Integer;
{* Returns screen height in pixels. }
//[Status DECLARATIONS]
type
TStatusOption = ( soNoSizeGrip, soTop );
{* Options available for status bars. }
TStatusOptions = Set of TStatusOption;
{* Status bar options. }
procedure DrawFormattedText( Ctl: PControl; DC: HDC; var R: TRect; Flags: DWORD {EditCtl: Boolean} );
{* This procedure can be useful to draw control's text in custom-defined controls. }
{$IFDEF USE_GRAPHCTLS}
{$IFDEF GRAPHCTL_XPSTYLES}
var DoNotDrawGraphCtlsUsingXPStyles: Boolean;
procedure DrawFormattedTextXP( Theme: THandle; Ctl: PControl; DC: HDC;
var R: TRect; CtlType, CtlStates, Flags1, Flags2: Integer );
{* This procedure can be useful to draw control's text in custom-defined controls. }
{$ENDIF}
function _NewGraphCtl( AParent: PControl; ATabStop: Boolean ): PControl;
{* Creates graphic control basics. }
function NewGraphLabel( AParent: PControl; const ACaption: String ): PControl;
{* Creates graphic label, which does not require a window handle. }
function NewWordWrapGraphLabel( AParent: PControl; const ACaption: KOLString ): PControl;
{* Creates graphic label, which does not require a window handle. }
function NewGraphPaintBox( AParent: PControl ): PControl;
{* Creates graphic paint box (just the same as graphic label, but with empty Caption). }
function NewGraphCheckBox( AParent: PControl; const ACaption: KOLString ): PControl;
{* Creates graphic checkbox. }
function NewGraphRadioBox( AParent: PControl; const ACaption: KOLString ): PControl;
{* Creates graphic radiobox. }
function NewGraphButton( AParent: PControl; const ACaption: KOLString ): PControl;
{* Creates graphic button. }
function NewGraphEditbox( AParent: PControl; Options: TEditOptions ): PControl;
{* Creates graphic edit box. To do editing, this box should be replaced with
real edit box with a handle (actually, it is enough to place an edit box
on the same Parent having the same BoundsRect). }
{$ENDIF USE_GRAPHCTLS}
{$ENDIF WIN_GDI}
//[Run DECLARATION]
procedure Run( var AppletWnd: PControl );
{* |<#appbutton>
Call this procedure to process messages loop of your program.
Pass here pointer to applet button object (if You have created it
- see NewApplet) or your main form object of type PControl (created
using NewForm).
|
|
Visual objects constructing functions
|
Following constructing functions for visual controls are available:
|#control
}
{$IFDEF WIN_GDI}
procedure TerminateExecution( var AppletWnd: PControl );
//[Applet FUNCTIONS DECLARATIONS]
procedure AppletMinimize;
{* Minimizes the application (Applet should be assigned to have effect). }
procedure AppletHide;
{* Minimizes and hides application. }
procedure AppletRestore;
{* Restores Applet when minimized. }
{$IFDEF USE_OnIdle}
//[Idle handler DECALRATIONS]
{YS+}
procedure RegisterIdleHandler( const OnIdle: TOnEvent );
{* Registers new Idle handler. Idle handler is called each time when
message queue becomes empty. }
procedure UnRegisterIdleHandler( const OnIdle: TOnEvent );
{* Unregisters Idle handler. }
{YS-}
{$ENDIF USE_OnIdle}
//[InitCommonXXXX ANOTHER DECLARATIONS]
{* ComCtrl32 controls initialization. }
{$ifdef win32}
procedure InitCommonControls; {$ifdef wince}cdecl{$else}stdcall{$endif};
{$endif win32}
procedure DoInitCommonControls( dwICC: DWORD );
{* Calls extended initialization for Common Controls (from ComCtrl32).
Pass one of following constants:
|
ICC_LISTVIEW_CLASSES = $00000001; // listview, header
ICC_TREEVIEW_CLASSES = $00000002; // treeview, tooltips
ICC_BAR_CLASSES = $00000004; // toolbar, statusbar, trackbar, tooltips
ICC_TAB_CLASSES = $00000008; // tab, tooltips
ICC_UPDOWN_CLASS = $00000010; // updown
ICC_PROGRESS_CLASS = $00000020; // progress
ICC_HOTKEY_CLASS = $00000040; // hotkey
ICC_ANIMATE_CLASS = $00000080; // animate
ICC_WIN95_CLASSES = $000000FF;
ICC_DATE_CLASSES = $00000100; // month picker, date picker, time picker, updown
ICC_USEREX_CLASSES = $00000200; // comboex
ICC_COOL_CLASSES = $00000400; // rebar (coolbar) control
ICC_INTERNET_CLASSES = $00000800;
ICC_PAGESCROLLER_CLASS = $00001000; // page scroller
ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control
|
}
const
ICC_LISTVIEW_CLASSES = $00000001; // listview, header
ICC_TREEVIEW_CLASSES = $00000002; // treeview, tooltips
ICC_BAR_CLASSES = $00000004; // toolbar, statusbar, trackbar, tooltips
ICC_TAB_CLASSES = $00000008; // tab, tooltips
ICC_UPDOWN_CLASS = $00000010; // updown
ICC_PROGRESS_CLASS = $00000020; // progress
ICC_HOTKEY_CLASS = $00000040; // hotkey
ICC_ANIMATE_CLASS = $00000080; // animate
ICC_WIN95_CLASSES = $000000FF;
ICC_DATE_CLASSES = $00000100; // month picker, date picker, time picker, updown
ICC_USEREX_CLASSES = $00000200; // comboex
ICC_COOL_CLASSES = $00000400; // rebar (coolbar) control
ICC_INTERNET_CLASSES = $00000800;
ICC_PAGESCROLLER_CLASS = $00001000; // page scroller
ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control
{$ifdef win32}
//[Ole DECLARATIONS]
function OleInit: Boolean;
{* Calls OleInitialize (once - all other calls are simulated by incrementing
call counter. Every OleInit shoud be complemented with correspondent OleUninit.
(Though, it is possible to call API function OleUnInitialize once to
cancel all OleInit calls). }
procedure OleUnInit;
{* Decrements counter and calls OleUnInitialize when it is zeroed. }
var OleInitCount: Integer;
{-}
function StringToOleStr(const Source: string): PWideChar;
{* }
{+}
function SysAllocStringLen(psz: PWideChar; len: Integer): PWideChar; {$ifdef wince}cdecl{$else}stdcall{$endif};
procedure SysFreeString( psz: PWideChar ); {$ifdef wince}cdecl{$else}stdcall{$endif};
{$endif win32}
{$ENDIF WIN_GDI}
{ -- Contructors for visual controls -- }
//[NewXXXX DECLARATIONS]
//[_NewWindowed DECLARATION]
{$IFDEF GDI}
function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar; Ctl3D: Boolean ): PControl;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function _NewWindowed( AParent: PControl; ControlClassName: PChar;
widget: PGtkWidget; need_eventbox: Boolean ): PControl;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
//[NewApplet DECLARATION]
function NewApplet( const Caption: KOLString ): PControl;
{* |<#control>
Creates applet button window, which has to be parent of all other forms
in your project (but this is *not must*). See also comments about NewForm.
|
Following methods, properties and events are useful to work with applet
control:
|#appbutton }
{$ENDIF WIN_GDI}
//[NewForm DECLARATION]
function NewForm( AParent: PControl; const Caption: KOLString ): PControl;
{* |<#control>
Creates form window object and returns pointer to it. If You use only one form,
and You are not going to do applet button on task bar invisible, it is not
necessary to create also special applet button window - just pass
your (main) form object to Run procedure. In that case, it is a good
idea to assign pointer to your main form object to Applet variable
immediately following creating it - because some objects (e.g. TTimer)
want to have Applet assigned to something.
|
|&D= %0
Following methods, properties and events are useful to work with forms
(ones common for all visual objects, such as , , ,
, etc. are not listed here - look TControl for it):
|#form }
//[_NewControl DECLARATION]
{$IFDEF GDI}
function _NewControl( AParent: PControl; ControlClassName: PKOLChar;
Style: DWORD; Ctl3D: Boolean; Actions: PCommandActions ): PControl;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function _NewControl( AParent: PControl; ControlClassName: PChar;
Style: DWORD; Ctl3D: Boolean; widget: PGtkWidget; need_eventbox: Boolean ): PControl;
{$ENDIF GTK}
{$ENDIF _X_}
//[NewButton DECLARATION]
function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
{* |<#control>
Creates button on given parent control or form.
Please note, that in Windows, buttons can not change its color
and to be .
|
Following methods, properies and events are (especially) useful with
a button:
|#button }
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
//[NewBitBtn DECLARATION]
function NewBitBtn( AParent: PControl; const Caption: KOLString;
Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl;
{* |<#control>
Creates image button (actually implemented as owner-drawn). In Options,
it is possible to determine, whether bitmap or image list used to contain
one or more (up to 5) images, correspondent to certain BitBtn state.
|
For case of imagelist (option bboImageList), it is possible to use a
number of glyphs from the image list, starting from image index given
by GlyphCount parameter. Number of used glyphs is passed in that case
in high word of GlyphCount parameter (if 0, one image is used therefore).
For bboImageList, BitBtn can be Transparent (and in that case bboNoBorder
style can be useful to draw custom buttons of non-rectangular shape).
|
For case of bitmap BitBtn, image is stretched down (if too big), but can
not be transparent. It is not necessary for bitmap BitBtn to pass correct
GlyphCount - it is calculated on base of bitmap size, if 0 is passed.
|
And, certainly, BitBtn can be without glyph image (text only). For that
case, it is therefore is more flexible and power than usual Button (but
requires more code). E.g., BitBtn can change its , ,
and to be totally .
Moreover, BitBtn can be , bboFixed, and
have property .
|
Note: if You use bboFixed Style, use OnChange event instead of OnClick,
because state is changed immediately however OnClick occure
only when mouse or space key released (and can be not called at all if
mouse button is released out of BitBtn bounds). Also, bboFixed defines
only which glyph to show (the border if it is not turned off behaves as
usual for a button, i.e. it becomes lowered and then raised again at any click).
Here You can find references to other properties, events and methods
applicable to BitBtn:
|#bitbtn }
{$ENDIF GDI}
//[NewLabel DECLARATION]
function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
{* |<#control>
Creates static text control (native Windows STATIC control).
Use property at run time to change label text. Also
it is possible to adjust label , or .
Label can be . If You want to have rotated text
label, call NewLabelEffect instead and change its .FontOrientation.
Other references certain for a label:
|#label }
{$IFDEF GDI}
//[NewWordWrapLabel DECLARATION]
function NewWordWrapLabel( AParent: PControl; const Caption: KOLString ): PControl;
{* |<#control>
Creates multiline static text control (native Windows STATIC control),
which can wrap long text onto several lines. See also NewLabel.
See also:
|#wwlabel
|#label }
//[NewLabelEffect DECLARATION]
function NewLabelEffect( AParent: PControl; const Caption: KOLString; ShadowDeep: Integer ): PControl;
{* |<#control>
Creates 3D-label with capability to rotate its text , which
is controlled by changing .FontOrientation property. If You want
to get flat effect label (e.g. to rotate it only), pass = 0.
Please note, that drawing procedure uses property, so using of
LabelEffect leads to increase size of executable.
See also:
|#3dlabel
|#label }
{$ENDIF GDI}
//[NewPaintbox DECLARATION]
function NewPaintbox( AParent: PControl ): PControl;
{* |<#control>
Creates owner-drawn STATIC control. Set its event to
perform custom painting.
|#paintbox }
{$IFDEF GDI}
//[NewImageShow DECLARATION]
function NewImageShow( AParent: PControl; AImgList: PImageList; ImgIdx: Integer ): PControl;
{* |<#control>
Creates an image show control, implemented as a paintbox which is used to
draw an image from the imagelist. At run-time, use property CurIndex to
select another image from the imagelist, and a property ImageListNormal to
use another image list. When the control is created, its size becomes
equal to dimensions of imagelist (if any). }
//[NewScrollBar DECLARATION]
function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl;
{* |<#control>
Creates simple scroll bar. }
//[NewScrollBox DECLARATION]
function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle;
Bars: TScrollerBars ): PControl;
{* |<#control>
Creates simple scrolling box, which can be used any way you wish, e.g. to scroll
certain large image. To provide automatic scrolling of a set of child controls,
use advanced scroll box, created with NewScrollBoxEx. }
procedure NotifyScrollBox( Self_, Child: PControl );
function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
{* |<#control>
Creates extended scrolling box control, which automatically scrolls child
controls (if any). }
//[NewGradientPanel DECLARATION]
function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;
{* |<#control>
Creates gradient-filled STATIC control. To adjust colors at the
run time, change and properties (which initially are
assigned from Color1, Color2 parameters), and call method
to repaint control. }
function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;
Style: TGradientStyle; Layout: TGradientLayout ): PControl;
{* |<#control>
Creates gradient-filled STATIC control. To adjust colors at the
run time, change and properties (which initially are
assigned from Color1, Color2 parameters), and call method
to repaint control. Depending on style and first line/point layout, can
looking different. Idea: Vladimir Stojiljkovic. }
//[NewPanel DECLARATION]
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
{* |<#control>
Creates panel, which can be parent for other controls (though, any
control can be used as a parent for other ones, but panel is specially
designed for such purpose). }
{$ifdef win32}
//[NewMDIxxx DECLARATIONS]
function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl;
{* |<#control>
Creates MDI client window, which is a special type of child window,
containing all MDI child windows, created calling NewMDIChild function.
On a form, MDI client behaves like a panel, so it can be placed and sized
(or aligned) like any other controls. To minimize flick during resizing
main form having another aligned controls, place MDI client window on
a panel and align it caClient in the panel.
|
Note:
MDI client must be a single on the form. }
function NewMDIChild( AParent: PControl; const ACaption: String ): PControl;
{* |<#control>
Creates MDI client window. AParent should be a MDI client window,
created with NewMDIClient function. }
{$endif win32}
//[NewSplitter DECLARATIONS]
function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;
{* |<#control>
Creates splitter control, which will separate previous one (i.e. last
created one before splitter on the same parent) from created
next, allowing to user to adjust size of separated controls by dragging
the splitter in desired direction. Created splitter becomes vertical
or horizontal depending on Align style of previous control on the same
parent (if caLeft/caRight then vertical, if caTop/caBottom then horizontal).
|
Please note, what if previous control has no Align equal to caLeft/caRight
or caTop/caBottom, splitter will not be able to function normally. If
previous control does not exist, it is yet possible to use splitter as
a resizeable panel (but set its initial Align value first - otherwise it
is not set by default. Also, change Cursor property as You wish in that
case, since it is not set too in case, when previous control does not
exist).
|
Additional parameters determine, which minimal size (width or height -
correspondently to split direction) is allowed for left (top) control
and to rest of client area of parent, correspondently. (It is possible
later to set second control for checking its size with MinSizeNext
value - using TControl.SecondControl property). If -1 passed,
correspondent control size is not checked during dragging of splitter.
Usually 0 is more suitable value (with this value, it is garantee, that
splitter will be always available even if mouse was released far from the
edge of form).
|
It is possible for user to press Escape any time while dragging splitter
to abort all adjustments made starting from left mouse button push and
begin of drag the splitter. But remember please, that such event is
controlled using timer, and therefore correspondent keyboard events
are received by currently focused control. Be sure, that pressing Escape
will not affect to any control on form, which could be focused, otherwise
filter keyboard messages (by yourself) to prevent undesired handling of
Escape key by certain controls while splitting. (Use Dragging property
to check if splitter is dragging by user with mouse).
|
See also:
NewSplitterEx
|#splitter }
function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
EdgeStyle: TEdgeStyle ): PControl;
{* |<#control>
Creates splitter control. Difference from NewSplitter is what it is possible
to determine if a splitter will be beveled or not. See also NewSplitter. }
//[NewGroupbox DECLARATION]
function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl;
{* |<#control>
Creates group box control. Note, that to group radio items, group
box is not necessary - any parent can play role of group for radio items.
See also NewPanel. }
//[NewCheckbox DECLARATION]
function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl;
{* |<#control>
Creates check box control. Special properties, methods, events:
|#checkbox }
function NewCheckBox3State( AParent: PControl; const Caption: KOLString ): PControl;
{* |<#control>
Creates check box control with 3 states. Special properties, methods,
events:
|#checkbox }
//[NewRadiobox DECLARATION]
function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl;
{* |<#control>
Creates radio box control. Alternative radio items must have the
same parent window (regardless of its kind, either groupbox (NewGroupbox),
panel (NewPanel) or form itself). Following properties, methods and events
are specially for radiobox controls:
|#radiobox }
//[NewEditbox DECLARATION]
function NewEditbox( AParent: PControl; Options: TEditOptions ): PControl;
{* |<#control>
Creates edit box control. To create multiline edit box, similar to
TMemo in VCL, apply eoMultiline in Options. Following properties, methods,
events are special for edit controls:
|#edit }
{$IFNDEF NOT_USE_RICHEDIT}
var FRichEditModule: Integer;
RichEditClass: PKOLChar;
const RichEditLibnames: array[ 0..3 ] of PKOLChar =
( 'msftedit', 'riched20',
'riched32', 'riched' );
RichEditClasses: array[ 0..3 ] of PKOLChar =
( 'RichEdit50W', 'RichEdit20A',
'RichEdit', 'RichEdit' );
var RichEditIdx: Byte = High( RichEditLibnames );
//[NewRichEdit DECLARATION]
function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
{* |<#control>
Creates rich text edit control. A rich edit control is a window in which
the user can enter and edit text. The text can be assigned character and
paragraph formatting, and can include embedded OLE objects. Rich edit
controls provide a programming interface for formatting text. However, an
application must implement any user interface components necessary to make
formatting operations available to the user.
|
Note: eoPassword, eoMultiline options have no effect for RichEdit control.
Some operations are supersided with special versions of those, created
especially for RichEdit, but in some cases it is necessary to use
another properties and methods, specially designed for RichEdit (see
methods and properties, which names are starting from RE_...).
|
Following properties, methods, events are special for edit controls:
|#richedit
}
function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;
{* |<#control>
Like NewRichEdit, but to work with older RichEdit control version 1.0
(window class 'RichEdit' forced to use instead of 'RichEdit20A', even
if library RICHED20.DLL found and loaded successfully). One more
difference - OleInit is not called, so the most of OLE capabilities
of RichEdit could not working. }
{$ENDIF NOT_USE_RICHEDIT}
//[NewListbox DECLARATION]
function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
{* |<#control>
Creates list box control. Following properties, methods and events are
special for Listbox:
|#listbox }
//[NewCombobox DECLARATION]
function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;
{* |<#control>
Creates new combo box control. Note, that it is not possible to align
combobox caLeft or caRight: this can cause infinite recursion in the
application.
|
Following properties, methods and events are
special for Combobox:
|#combo }
//[_NewCommonControl DECLARATION]
function _NewCommonControl( AParent: PControl; ClassName: PKOLChar; Style: DWORD;
Ctl3D: Boolean; Actions: PCommandActions ): PControl;
//[NewProgressbar DECLARATION]
function NewProgressbar( AParent: PControl ): PControl;
{* |<#control>
Creates progress bar control. Following properties are special for
progress bar:
|#progressbar
See also NewProgressEx. }
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
{* |<#control>
Can create progress bar with smooth style (progress is not segmented
onto bricks) or/and vertical progress bar - using additional parameter.
For list of properties, suitable for progress bars, see NewProgressbar. }
//[NewListVew DECLARATION]
function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
{* |<#control>
Creates list view control. It is very powerful control, which can partially
compensate absence of grid controls (in lvsDetail view mode). Properties,
methods and events, special for list view control are:
|#listview }
//[NewTreeView DECLARATION]
function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
ImgListNormal, ImgListState: PImageList ): PControl;
{* |<#control>
Creates tree view control. See tree view methods and properties:
|#treeview }
//[NewTabControl DECLARATION]
function NewTabControl( AParent: PControl; const Tabs: array of KOLString; Options: TTabControlOptions;
ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
{* |<#control>
Creates new tab control (like notebook). To place child control on a certain
page of TabControl, use property Pages[ Idx ], for example:
! Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' );
|
To determine number of pages at run time, use property ;
|
to determine which page is currently selected (or to change
selection), use property ;
|
to feedback to switch between tabs assign your handler to OnSelChange
event;
|
Note, that by default, tab control is created with a border lowered to
tab control's parent. To remove it, you can apply WS_EX_TRANSPARENT extended
style (see TControl.ExStyle property), but painting of some child controls
can be strange a bit in this case (no border drawing for edit controls was
found, but not always...). You can also apply style WS_THICKFRAME (TControl.Style
property) to make the border raised.
|
Other methods and properties, suitable for tab control, are:
|#tabcontrol }
{$IFNDEF OLD_ALIGN}
function NewTabEmpty( AParent: PControl; Options: TTabControlOptions;
ImgList: PImageList ): PControl;
{* |<#control>
Creates new empty tab control for using metods TC_Insert (to create Pages as Panel),
or TC_InsertControl (if you want using your custom Pages).}
{$ENDIF}
//[NewToolbar DECLARATION]
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
Bitmap: HBitmap; const Buttons: array of PKOLChar;
const BtnImgIdxArray: array of Integer ) : PControl;
{* |<#control>
Creates toolbar control. Bitmap (if present) must contain images for all buttons
excluding separators (defined by string '-' in Buttons array) and system images,
otherwise last buttons will no have images at all. Image width for every button
is assumed to be equal to Bitmap height (if last of "squares" has
insufficient width, it will not be used). To define fixed buttons, use
characters '+' or '-' as a prefix for button string (even empty). To
create groups of (radio-)buttons, use also '!' follow '+' or '-'. (These rules
are similar used in menu creation). To define drop down button, use (as
first) prefix '^'. (Do not forget to set event for this
case). If You want to assign images to buttons not in the same order
how these are placed in Bitmap (or You use system bitmap), define for every
button (in BtnImgIdxArray array) indexes for every button (excluding
separator buttons). Otherwise, it is possible to define index only for first
button (e.g., [0]). It is also possible to change TBImages[ ] property
for such purpose, or do the same in method TBSetBtnImgIdx).
|
Following properties, methods and event are specially designed to work with
toolbar control:
|#toolbar
|
If your project uses Align property to align controls, this can conflict with
toolbar native aligning. To solve such problem, place toolbar to parent panel,
which has its own Align property assigned to desired value.
|
To create toolbar with buttons, drawn from top to bottom, instead from left
to right, combine caLeft / caRight in Align parameter and style tboWrapable
when create toolbar. To adjust width of vertically aligned toolbar, it is
possible to call ResizeParentLeft for it. E.g.:
! P0 := NewPanel( W, esRaised ) .SetSize( 30, 0 ) .SetAlign( caLeft );
! // ^^^^^^^^^^^^^^^^^ //////
!TB := NewToolbar( P0, caLeft, [ tboNoDivider, tboWrapable ], DWORD(-1),
! // ////// ///////////
! [ ' ', ' ', ' ', '-', ' ', ' ' ],
! [ STD_FILEOPEN ] ).ResizeParentRight;
!//Note, that caLeft is *must*, and tboWrapable style too. SetSize for
!//parent panel is not necessary, but only if ResizeParentRight is called
!//than for Toolbar.
|
One more note: if You create toolbar without text labels (passing ' ' for
each button You add), include also option tboTextRight to fix incorrect
sizing of buttons under Windows9x.
|
And, certainly, if you use image lists rather then bitmap, all written
above about Bitmap become absolutely incorrect.
}
//[NewDateTimePicker DECLARATION]
function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions )
: PControl;
{* |<#control>
Creates date and time picker common control.
}
{ -- Constructor for Image List objet -- }
//[NewImageList DECLARATION]
function NewImageList( AOwner: PControl ): PImageList;
{* Constructor of TImageList object. Unlike other non-visual objects, image list
can be parented by TControl object (but this does not *must*), and in that
case it is destroyed automatically when its parent control is destroyed.
Every control can have several TImageList objects, linked to a simple list.
But if any TImageList object is destroyed, all following ones are destroyed
too (at least, now I implemented it so). }
{$ENDIF WIN_GDI}
//[TIMER]
type
TTimerKind = ( tkReal, tkProcess, tkProfiler ); // only for UNIX!
{++}(*TTimer = class;*){--}
PTimer = {-}^{+}TTimer;
{ ----------------------------------------------------------------------
TTimer object
----------------------------------------------------------------------- }
//[TTimer DEFINITION]
TTimer = object( TObj )
{* Easy timer incapsulation object. It uses separate topmost window,
common for all timers in the application, to handle WM_TIMER message.
This allows using timers in non-windowed application (but anyway it
should contain message handling loop for a thread).
|
Note: in UNIX, there are no special windows created, certainly. }
protected
fHandle : Integer;
fEnabled: Boolean;
fInterval: Integer;
fOnTimer: TOnEvent;
{$IFDEF LIN}
{$IFNDEF GTK}
{$IFNDEF QT}
fPrev, fNext: PTimer; // двусвязный список всех _активных_ таймеров
fTimeStart: clock_t;
fExpireNext: clock_t;
fExpireTotal: Int64;
fTimerHandled: Boolean;
fResolution: Integer;
fPeriodic: Boolean;
fMultimedia: Boolean;
{$ENDIF QT}
{$ENDIF GTK}
{$ENDIF}
procedure SetEnabled(const Value: Boolean); {$IFDEF WIN} virtual; {$ENDIF}
procedure SetInterval(const Value: Integer);
protected
{++}(*public*){--}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* Destructor. }
public
property Handle : Integer read fHandle;
{* Windows timer object handle. }
property Enabled : Boolean read fEnabled write SetEnabled;
{* True, is timer is on. Initially, always False. }
property Interval : Integer read fInterval write SetInterval;
{* Interval in milliseconds (1000 is default and means 1 second).
Note: in UNIX, if an Interval can be set to a value large then 30 minutes,
add a conditional definition SUPPORT_LONG_TIMER to the project options. }
property OnTimer : TOnEvent read fOnTimer write fOnTimer;
{* Event, which is called when time interval is over. }
{$IFDEF LIN}
{$IFNDEF GTK}
{$IFNDEF QT}
property Resolution: Integer read fResolution write fResolution; // dummy property, just for compatibility
property Periodic: Boolean read fPeriodic write fPeriodic;
{$ENDIF QT}
{$ENDIF GTK}
{$ENDIF LIN}
end;
//[END OF TTimer DEFINITION]
//[NewTimer DECLARATION]
function NewTimer( Interval: Integer ): PTimer;
{* Constructs initially disabled timer with interval 1000 (1 second). }
{$IFDEF WIN}
{$ifdef win32}
//[MULTIMEDIA TIMER]
type
{++}(*TMMTimer = class;*){--}
PMMTimer = {-}^{+}TMMTimer;
//[TMMTimer DEFINITION]
TMMTimer = object( TTimer )
{* Multimedia timer incapsulation object. Does not require Applet or special
window to handle it. System creates a thread for each high resolution
timer, so using many such objects can degrade total PC performance. }
protected
FResolution: Integer;
FPeriodic: Boolean;
procedure SetEnabled(const Value: Boolean); {-}virtual;{+}{++}(*override;*){--}
public
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* }
property Resolution: Integer read FResolution write FResolution;
{* Minimum timer resolution. The less the more accuracy (0 is exactly
Interval milliseconds between timer shots). It is recommended to set
this property greater to prevent entire system from reducing overhead.
If you change this value, reset and then set Enabled again to apply
changes. }
property Periodic: Boolean read FPeriodic write FPeriodic;
{* TRUE, if timer is periodic (default). Otherwise, timer is one-shot
(set it Enabled every time in such case for each shot). If you change
this property, reset and set Enabled property again to get effect. }
end;
//[END OF TMMTimer DEFINITION]
//[NewMMTimer DECLARATION]
function NewMMTimer( Interval: Integer ): PMMTimer;
{* Creates multimedia timer object. Initially, it has Resolution = 0,
Periodic = TRUE and Enabled = FALSE. Do not forget also to assign your
event handler to OnTimer to do something on timer shot. }
{$endif win32}
{$ENDIF WIN}
{$IFDEF LIN}
function NewMMTimer( Interval: Integer ): PTimer;
{$ENDIF LIN}
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
{ -- TTrayIcon object -- }
//[TRAYICON]
type
TOnTrayIconMouse = procedure( Sender: PObj; Message : Word ) of object;
{* Event type to be called when Applet receives a message from an icon,
added to the taskbar tray. }
{++}(*TTrayIcon = class;*){--}
PTrayIcon = {-}^{+}TTrayIcon;
{ ----------------------------------------------------------------------
TTrayIcon - icon in tray area of taskbar
----------------------------------------------------------------------- }
//[TTrayIcon DEFINITION]
TTrayIcon = object(TObj)
{* Object to place (and change) a single icon onto taskbar tray. }
protected
FIcon: HIcon;
FActive: Boolean;
FTooltip: KOLString;
FOnMouse: TOnTrayIconMouse;
FControl: PControl;
fAutoRecreate: Boolean;
FNoAutoDeactivate: Boolean;
FWnd: HWnd;
procedure SetIcon(const Value: HIcon);
procedure SetActive(const Value: Boolean);
procedure SetTrayIcon( const Value : DWORD );
procedure SetTooltip(const Value: KOLString);
procedure SetAutoRecreate(const Value: Boolean);
protected
{++}(*public*){--}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* Destructor. Use Free method instead (as usual). }
public
property Icon : HIcon read FIcon write SetIcon;
{* Icon to be shown on taskbar tray. If not set, value of Active
property has no effect. It is also possible to assign a value
to Icon property after assigning True to Active to install
icon first time or to replace icon with another one (e.g. to
get animation effect).
|
Previously allocated icon (if any) is not deleted using
DeleteObject. This is normal for icons, loaded from resource
(e.g., by LoadIcon API call). But if icon was created (e.g.) by
CreateIconIndirect, your code is responsible for destroying
of it). }
property Active : Boolean read FActive write SetActive;
{* Set it to True to show assigned Icon on taskbar tray. Default
is False. Has no effect if Icon property is not assigned.
TrayIcon is deactivated automatically when Applet is finishing
(but only if Applet window is used as a "parent" for tray
icon object). }
property Tooltip : KOLString read FTooltip write SetTooltip;
{* Tooltip string, showing automatically when mouse is moving
over installed icon. Though "huge string" type is used, only
first 63 characters are considered. Also note, that only in
most recent versions of Windows multiline tooltips are supported. }
property OnMouse : TOnTrayIconMouse read FOnMouse write FOnMouse;
{* Is called then mouse message is taking place concerning installed
icon. Only type of message can be obtained (e.g. WM_MOUSEMOVE,
WM_LBUTTONDOWN etc.) }
property AutoRecreate: Boolean read fAutoRecreate write SetAutoRecreate;
{* If set to TRUE, auto-recreating of tray icon is proveded in case,
when Explorer is restarted for some (unpredictable) reasons. Otherwise,
your tray icon is disappeared forever, and if this is the single way
to communicate with your application, the user nomore can achieve it. }
property NoAutoDeactivate: Boolean read FNoAutoDeactivate write FNoAutoDeactivate;
{* If set to true, tray icon is not removed from tray automatically on
WM_CLOSE message receive by owner control. Set Active := FALSE in
your code for such case before accepting closing the form. }
property Wnd: HWnd read FWnd write FWnd;
{* A window to use as a base window for tray icon messages. Overrides
parent Control handle is assigned. Note, that if Wnd property used,
message handling is not done automatically, and you should do this in
your code, or at least for one tray icon object, call AttachProc2Wnd. }
procedure AttachProc2Wnd;
{* Call this method for a tray icon object in case if Wnd used rather then
control. It is enough to call this method once for each Wnd used, even
if several other tray icons are also based on the same Wnd. See also
DetachProc2Wnd method. }
procedure DetachProc2Wnd;
{* Call this method to detach window procedure attached via AttachProc2Wnd.
Do it once for a Wnd, used as a base to handle tray icon messages.
Caution! If you do not call this method before destroying Wnd, the
application will not functioning normally. }
end;
{* When You create invisible application, which should be represented by
only the tray icon, prepare a handle for the window, resposible for
messages handling. Remember, that window handle is created automatically
only when a window is showing first time. If window's property Visible is
set to False, You should to call CreateWindow manually.
There is a known bug exist with similar invisible tray-iconized applications.
When a menu is activated in response to tray mouse event, if there was
not active window, belonging to the application, the menu is not disappeared
when mouse is clicked anywhere else. This bug is occure in Windows9x/ME.
To avoid it, activate first your form window. This last window shoud have
status visible (but, certainly, there are no needs to place it on visible
part of screen - change its position, so it will not be visible for user,
if You wish).
Also, to make your application "invisible" but until special event is occure,
use Applet separate from the main form, and make for both Visible := False.
This allows for You to make your form visible any time You wish, and without
making application button visible if You do not wish.
}
{= Когда Вы делаете невидимое приложение, которое должно быть представлено
только иконкой в трее, обеспечьте ненулевой Handle для окна, отвечающего
за обработку сообщений. Помните, что Handle окна создается автоматически
только в тот момент, когда оно должно появиться в первый раз. Если свойство
окна Visible установлено в FALSE, необходимо вызвать CreateWindow самостоятельно.
Существует известный BUG с подобными невидимыми минимизированными в трей
приложениями. Когда в ответ на событие мыши активизирвано выпадающее меню,
оно не исчезает по щелчку мыши вне этого меню. Происходит это в Windows9x/ME.
чтобы решить эту проблему, сначала активизируйте свое окно (форму). Это окно
должно быть видимым (но, конечно, его можно разместить вне пределов видимой
части экрана, так что пользователю его видно не будет).
Так же, чтобы сделать приложение невидимым, по крайней мере, пока это не
потребуется, используйте отдельный представитель класса TControl - глобальную
переменную Applet, и присвойте FALSE ее свойству Visible.
}
//[END OF TTrayIcon DEFINITION]
//[NewTrayIcon DECLARATION]
function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon;
{* Constructor of TTrayIcon object. Pass main form or applet as Wnd
parameter. }
//[JUST ONE]
{ -- JustOne -- }
{$ifndef wince}
type
TOnAnotherInstance = procedure( const CmdLine: KOLString ) of object;
{* Event type to use in JustOneNotify function. }
{$endif wince}
function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean;
{* Returns True, if this is a first instance. For all other instances
(application is already running), False is returned. }
function JustOneActivate( Wnd: PControl; const Identifier : KOLString ) : HWND;
{* Returns 0, if this is the first instance. If application is running already,
it will be activated and its window handle will be returned. }
{$ifndef wince}
function JustOneNotify( Wnd: PControl; const Identifier : KOLString;
const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;
{* Returns True, if this is a first instance. For all other instances
(application is already running), False is returned. If handler
aOnAnotherInstance passed, it is called (in first instance) every time
when another instance of an application is started, receiving command
line used to run it. }
{$endif wince}
{ -- string (mainly) utility procedures and functions. -- }
{$IFDEF GDI}
//[Message Box DECLARATIONS]
function MsgBox( const S: KOLString; Flags: DWORD ): DWORD;
{* Displays message box with the same title as Applet.Caption. If applet
is not running, and Applet global variable is not assigned, caption
'Error' is displayed (but actually this is not an error - the system
does so, if nil is passed as a title).
|
Returns ID_... result (correspondently to flags passed (MB_OK, MBYESNO,
etc. -> ID_OK, ID_YES, ID_NO, etc.) }
procedure MsgOK( const S: KOLString );
{* Displays message box with the same title as Applet.Caption (or 'Error',
if Applet is not running). }
function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
{* Displays message box like MsgBox, but uses Applet.Handle as a parent
(so the message has no button on a task bar). }
procedure ShowMessage( const S: KOLString );
{* Like ShowMsg, but has only styles MB_OK and MB_SETFOREGROUND. }
{$ENDIF GDI}
{$IFDEF WIN}
procedure SpeakerBeep( Freq: Word; Duration: DWORD );
{* On Windows NT, calls Windows.Beep. On Windows 9x, produces beep on speaker
of desired frequency during given duration time (in milliseconds). }
{$ENDIF WIN}
{++}(*
function FormatMessage(dwFlags: DWORD; lpSource: Pointer; dwMessageId: DWORD; dwLanguageId: DWORD;
lpBuffer: PChar; nSize: DWORD; Arguments: Pointer): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
*){--}
function SysErrorMessage(ErrorCode: Integer): KOLString;
{* Creates and returns a string containing formatted system error message.
It is possible then to display this message or write it to a log
file, e.g.:
! ShowMsg( SysErrorMessage( GetLastError ) );
|&R=%0
}
{$ENDIF WIN_GDI}
//[I64 TYPE]
type
I64 = record
{* 64 bit integer record. Use it and correspondent functions below in KOL
projects to avoid dependancy from Delphi version (earlier versions of
Delphi had no Int64 type). }
Lo, Hi: DWORD;
end;
PI64 = ^I64;
{* }
{-}
{$IFNDEF _D4orHigher}
Int64 = I64;
PInt64 = PI64;
{$ENDIF}
function MakeInt64( Lo, Hi: DWORD ): I64;
{* }
function Int2Int64( X: Integer ): I64;
{* }
procedure IncInt64( var I64: I64; Delta: Integer );
{* I64 := I64 + Delta; }
procedure DecInt64( var I64: I64; Delta: Integer );
{* I64 := I64 - Delta; }
function Add64( const X, Y: I64 ): I64;
{* Result := X + Y; }
function Sub64( const X, Y: I64 ): I64;
{* Result := X - Y; }
function Neg64( const X: I64 ): I64;
{* Result := -X; }
function Mul64i( const X: I64; Mul: Integer ): I64;
{* Result := X * Mul; }
function Div64i( const X: I64; D: Integer ): I64;
{* Result := X div D; }
function Mod64i( const X: I64; D: Integer ): Integer;
{* Result := X mod D; }
function Sgn64( const X: I64 ): Integer;
{* Result := sign( X ); i.e.:
|
if X < 0 then -1
|
if X = 0 then 0
|
if X > 0 then 1 }
function Cmp64( const X, Y: I64 ): Integer;
{* Result := sign( X - Y ); i.e.
|
if X < Y then -1
|
if X = Y then 0
|
if X > Y then 1 }
function Int64_2Str( X: I64 ): String;
{* }
function Int64_2Hex( X: I64; MinDigits: Integer ): String;
{* }
function Str2Int64( const S: String ): I64;
{* }
function Int64_2Double( const X: I64 ): Double;
{* }
function Double2Int64( D: Double ): I64;
{*
}
const
NAN = 0.0 / 0.0;
Infinity = 1.0 / 0.0;
{+}
{++}(*const NAN = 1e-100;*){--}
function IsNan(const AValue: Double): Boolean;
{* Checks if an argument passed is NAN. }
function IsInfinity(const AValue: Double): Boolean;
{* Checks if an argument passed is Infinite. }
function IntPower(Base: Extended; Exponent: Integer): Extended;
{* Result := Base ^ Exponent; }
//[String<->Double DECLARATIONS]
function Str2Double( const S: String ): Double;
{* }
function Str2Extended( const S: String ): Extended;
{* }
function Double2Str( D: Double ): String;
{* }
function Extended2Str( E: Extended ): String;
{* }
function Double2StrEx( D: Double ): String;
{* experimental, do not use }
function TruncD( D: Double ): Double;
{* Result := trunc( D ) as Double;
|
See also TBits object.
}
function IfThenElseBool( t, e, Cond: Boolean ): Boolean;
function IfThenElseInt( t, e: Integer; Cond: Boolean ): Integer;
function IfThenElseStr( const t, e: String; Cond: Boolean ): String;
{$IFDEF _D5orHigher}
function IfThenElse( t, e: Boolean; Cond: Boolean ): Boolean; overload;
function IfThenElse( t, e: Integer; Cond: Boolean ): Integer; overload;
function IfThenElse( t, e: String; Cond: Boolean ): String; overload;
function IfThenElse( t, e: Double; Cond: Boolean ): Double; overload;
{$ENDIF}
//[SMALL BIT ARRAYS DECLARATIONS]
function GetBits( N: DWORD; first, last: Byte ): DWord;
{* Retuns bits straing from and to inclusively. }
function GetBitsL( N: DWORD; from, len: Byte ): DWord;
{* Retuns len bits starting from index .
|
See also units KolMath.pas, CplxMath.pas and Err.pas.
}
//[MulDiv DECLARATION]
{$IFNDEF FPC}
function MulDiv( A, B, C: Integer ): Integer;
{* Returns A * B div C. Small and fast. }
{$ENDIF}
//[TMethod TYPE]
type
///////////////////////////////////////////
{$ifndef _D6orHigher} //
///////////////////////////////////////////
TMethod = {$ifndef wince}packed{$endif} record
{* Is defined here because using of VCL classes.pas unit is
not recommended in XCL. This record type is used often
to set/access event handlers, referring to a procedure
of object (usually to set such event to an ordinal
procedure setting Data field to nil. }
Code: Pointer; // Pointer to method code.
{* If used to fake assigning to event handler of type 'procedure
of object' with ordinal procedure pointer, use symbol '@'
before method:
|
| Method.Code := @MyProcedure;
| }
Data: Pointer; // Pointer to object, owning the method.
{* To fake event of type 'procedure of object' with setting it to
ordinal procedure assign here NIL; }
end;
{* When assigning TMethod record to event handler, typecast it with
desired event type, e.g.:
|
| SomeObject.OnSomeEvent := TOnSomeEvent( Method );
|
}
///////////////////////////////////////////
{$endif} //
///////////////////////////////////////////
PMethod = ^TMethod;
{* }
function MakeMethod( Data, Code: Pointer ): TMethod;
{* Help function to construct TMethod record. Can be useful to
assign regular type procedure/function as event handler for
event, defined as object method (do not forget, that in that
case it must have first dummy parameter to replace @Self,
passed in EAX to methods of object). }
//[Rectangles&Points DECLARATIONS]
function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; {$ifdef wince}cdecl{$else}stdcall{$endif};
{* Use it instead of VCL Rect function }
function RectsEqual( const R1, R2: TRect ): Boolean;
{* Returns True if rectangles R1 and R2 have the same bounds }
function RectsIntersected( const R1, R2: TRect ): Boolean;
{* Returns TRUE if rectangles R1 and R2 have at least one common point.
Note, that right and bottom bounds of rectangles are not their part,
so, if such points are lying on that bounds, FALSE is returned. }
function PointInRect( const P: TPoint; const R: TRect ): Boolean;
{* Returns True if point P is located in rectangle R (including
left and top bounds but without right and bottom bounds of the
rectangle). }
function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint;
{* }
function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint;
{* }
function Point2SmallPoint( const T: TPoint ): TSmallPoint;
{* }
function SmallPoint2Point( const T: TSmallPoint ): TPoint;
{* }
function MakePoint( X, Y: Integer ): TPoint;
{* Use instead of VCL function Point }
function MakeSmallPoint( X, Y: Integer ): TSmallPoint;
{* Use to construct TSmallPoint }
//[MakeFlags DECLARATION]
function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;
{* }
function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange;
{* Returns TDateTimeRange from two TDateTime bounds. }
//[Integer FUNCTIONS DECLARATIONS]
procedure Swap( var X, Y: Integer );
{* exchanging values }
function Min( X, Y: Integer ): Integer;
{* minimum of two integers }
function Max( X, Y: Integer ): Integer;
{* maximum of two integers }
{$IFDEF REDEFINE_ABS}
function Abs( X: Integer ): Integer;
{* absolute value }
{$ENDIF}
function Sgn( X: Integer ): Integer;
{* sign of X: if X < 0, -1 is returned, if > 0, then +1, otherwise 0. }
function iSqrt( X: Integer ): Integer;
{* square root }
function iCbrt( X: DWORD ): Integer;
{* cubic root
|
}
//[Integer<->String DECLARATIONS]
function Int2Hex( Value : DWord; Digits : Integer ) : String;
{* Converts integer Value into string with hex number. Digits parameter
determines minimal number of digits (will be completed by adding
necessary number of leading zeroes). }
function Int2Str( Value : Integer ) : String;
{* Obvious. }
procedure Int2PChar( s: PChar; Value: Integer );
{* Converts Value to string and puts it into buffer s. Buffer must have
enough size to store the number converted: buffer overflow does
not checked anyway! }
function UInt2Str( Value: DWORD ): String;
{* The same as Int2Str, but for unsigned integer value. }
function Int2StrEx( Value, MinWidth: Integer ): String;
{* Like Int2Str, but resulting string filled with leading spaces to provide
at least MinWidth characters. }
function Int2Rome( Value: Integer ): String;
{* Represents number 1..8999 to Rome numer. }
function Int2Ths( I : Integer ) : String;
{* Converts integer into string, separating every three digits from each
other by character ThsSeparator. (Convert to thousands). You }
function Int2Digs( Value, Digits : Integer ) : String;
{* Converts integer to string, inserting necessary number of leading zeroes
to provide desired length of string, given by Digits parameter. If
resulting string is greater then Digits, string is not truncated anyway. }
function Num2Bytes( Value : Double ) : String;
{* Converts double float to string, considering it as a bytes count.
If Value is sufficiently large, number is represented in kilobytes (with
following letter K), or in megabytes (M), gigabytes (G) or terabytes (T).
Resulting string number is truncated to two decimals (.XX) or to one (.X),
if the second is 0. }
function S2Int( S: PChar ): Integer;
{* Converts null-terminated string to Integer. Scanning stopped when any
non-digit character found. Even empty string or string not containing
valid integer number silently converted to 0. }
function Str2Int(const Value : String) : Integer;
{* Converts string to integer. First character, which can not be
recognized as a part of number, regards as a separator. Even
empty string or string without number silently converted to 0. }
function Hex2Int( const Value : String) : Integer;
{* Converts hexadecimal number to integer. Scanning is stopped
when first non-hexadicimal character is found. Leading dollar ('$')
character is skept (if present). Minus ('-') is not concerning as
a sign of number and also stops scanning.}
function cHex2Int( const Value : String) : Integer;
{* As Hex2Int, but also checks for leading '0x' and skips it. }
function Octal2Int( const Value: String ) : Integer;
{* Converts octal number to integer. Scanning is stopped on first
non-octal digit (any char except 0..7). There are no checking if
there octal numer in the parameter. If the first char is not octal
digit, 0 is returned. }
function Binary2Int( const Value: String ) : Integer;
{* Converts binary number to integer. Like Octal2Int, but only digits
0 and 1 are allowed. }
{$IFDEF WIN}
{$IFNDEF _FPC}
function Format( const fmt: KOLString; params: array of const ): KOLString;
{* Uses API call to wvsprintf, so does not understand extra formats,
such as floating point, date/time, currency conversions. See list of
available formats in win32.hlp (topic wsprintf).
|
}
{$ENDIF _FPC}
{$ENDIF WIN}
//[String FUNCTIONS DECLARATIONS]
function StrComp(const Str1, Str2: PChar): Integer;
{* Compares two strings fast. -1: Str1Str2 }
function StrComp_NoCase(const Str1, Str2: PChar): Integer;
{* Compares two strings fast without case sensitivity.
Returns: -1 when Str1Str2 }
function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
{* Compare two strings (fast). Terminating 0 is not considered, so if
strings are equal, comparing is continued up to MaxLen bytes.
Since this, pass minimum of lengths as MaxLen. }
function StrLComp_NoCase(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
{* Compare two strings fast without case sensitivity.
Terminating 0 is not considered, so if strings are equal,
comparing is continued up to MaxLen bytes.
Since this, pass minimum of lengths as MaxLen. }
function StrCopy( Dest, Source: PChar ): PChar;
{* Copy source string to destination (fast). Pointer to Dest is returned. }
function StrCat( Dest, Source: PChar ): PChar;
{* Append source string to destination (fast). Pointer to Dest is returned. }
function StrLen(const Str: PChar): Cardinal;
{* StrLen returns the number of characters in Str, not counting the null
terminator. }
function StrScanLen(Str: PChar; Chr: Char; Len: Integer): PChar;
{* Fast scans string Str of length Len searching character Chr.
Pointer to a character next to found or to Str[Len] (if no one found)
is returned. }
function StrScan(Str: PChar; Chr: Char): PChar;
{* Fast search of given character in a string. Pointer to found character
(or nil) is returned. }
function StrRScan(const Str: PChar; Chr: Char): PChar;
{* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr
does not occur in Str, StrRScan returns NIL. The null terminator is
considered to be part of the string. }
function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
{* Returns True, if string Str is starting from Pattern, i.e. if
Copy( Str, 1, StrLen( Pattern ) ) = Pattern. Str must not be nil! }
function StrIsStartingFromNoCase( Str, Pattern: PChar ): Boolean;
{* Like StrIsStartingFrom above, but without case sensitivity. }
function TrimLeft(const S: KOLstring): KOLstring;
{* Removes spaces, tabulations and control characters from the starting
of string S. }
function TrimRight(const S: KOLstring): KOLstring;
{* Removes spaces, tabulates and other control characters from the
end of string S. }
function Trim( const S : KOLstring): KOLstring;
{* Makes TrimLeft and TrimRight for given string. }
function RemoveSpaces( const S: String ): String;
{* Removes all characters less or equal to ' ' in S and returns it. }
procedure Str2LowerCase( S: PChar );
{* Converts null-terminated string to lowercase (inplace). }
function LowerCase(const S: string): string;
{* Obvious. }
function UpperCase(const S: string): string;
{* Obvious. }
function AnsiUpperCase(const S: string): string;
{* Obvious. }
function AnsiLowerCase(const S: string): string;
{* Obvious. }
{$IFNDEF _D2}
{$IFNDEF _FPC}
function WAnsiUpperCase(const S: WideString): WideString;
{* Obvious. }
function WAnsiLowerCase(const S: WideString): WideString;
{* Obvious. }
function WStrComp(const S1, S2: WideString): Integer;
{* }
function _WStrComp(S1, S2: PWideChar): Integer;
{* }
function WStrScan(Str: PWideChar; Chr: WideChar): PWideChar;
{* Fast search of given character in a string. Pointer to found character
(or nil) is returned. }
function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar;
{* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr
does not occur in Str, StrRScan returns NIL. The null terminator is
considered to be part of the string. }
{$ENDIF _FPC}
{$ENDIF _D2}
function AnsiCompareStr(const S1, S2: KOLString): Integer;
{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare
operation is controlled by the current Windows locale. The return value
is the same as for CompareStr. }
function _AnsiCompareStr(S1, S2: PKOLChar): Integer;
{* The same, but for PChar ANSI strings }
function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer;
{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare
operation is controlled by the current Windows locale. The return value
is the same as for CompareStr. }
function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer;
{* The same, but for PChar ANSI strings }
function AnsiCompareText( const S1, S2: String ): Integer;
{* }
{$IFDEF WIN}
{$IFNDEF _FPC}
function LStrFromPWCharLen(Source: PWideChar; Length: Integer): String;
{* from Delphi5 - because D2 does not contain it. }
function LStrFromPWChar(Source: PWideChar): String;
{* from Delphi5 - because D2 does not contain it. }
{$ENDIF _FPC}
{$ENDIF WIN}
function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString;
{* Returns copy of source string S starting from Idx up to the end of
string S. Works correctly for case, when Idx > Length( S ) (returns
empty string for such case). }
function CopyTail( const S : KOLString; Len : Integer ) : KOLString;
{* Returns last Len characters of the source string. If Len > Length( S ),
entire string S is returned. }
procedure DeleteTail( var S : KOLString; Len : Integer );
{* Deletes last Len characters from string. }
function IndexOfChar( const S : String; Chr : Char ) : Integer;
{* Returns index of given character (1..Length(S)), or
-1 if a character not found. }
function IndexOfCharsMin( const S, Chars : String ) : Integer;
{* Returns index (in string S) of those character, what is taking place
in Chars string and located nearest to start of S. If no such
characters in string S found, -1 is returned. }
{$IFNDEF _D2}
{$IFNDEF _FPC}
function IndexOfWideCharsMin( const S, Chars : WideString ) : Integer;
{* Returns index (in wide string S) of those wide character, what
is taking place in Chars wide string and located nearest to start of S.
If no such characters in string S found, -1 is returned. }
{$ENDIF _FPC}
{$ENDIF _D2}
function IndexOfStr( const S, Sub : String ) : Integer;
{* Returns index of given substring in source string S. If found,
1..Length(S)-Length(Sub), if not found, -1. }
function Parse( var S : KOLString; const Separators : KOLString ) : KOLString;
{* Returns first characters of string S, separated from others by
one of characters, taking place in Separators string, assigning
a tail of string (after found separator) to source string. If
no separator characters found, source string S is returned, and
source string itself becomes empty. }
{$IFNDEF _FPC}
{$IFNDEF _D2}
function WParse( var S : WideString; const Separators : WideString ) : WideString;
{* Returns first wide characters of wide string S, separated from others
by one of wide characters, taking place in Separators wide string,
assigning a tail of wide string (following found separator) to the
source one. If there are no separator characters found, source wide
string S is returned, and source wide string itself becomes empty. }
{$ENDIF _D2}
{$ENDIF _FPC}
function ParsePascalString( var S : String; const Separators : String ) : String;
{* Returns first characters of string S, separated from others by
one of characters, taking place in Separators string, assigning
a tail of string (after the found separator) to source string. If
there are no separator characters found, the source string S is returned,
and the source string itself becomes empty. Additionally: if the first (after
a blank space) is the quote "'" or '#', pascal string is assumung first
and is converted to usual string (without quotas) before analizing
of other separators. }
function String2PascalStrExpr( const S : String ) : String;
{* Converts string to Pascal-like string expression (concatenation of
strings with quotas and characters with leading '#'). }
function StrEq( const S1, S2 : String ) : Boolean;
{* Returns True, if LowerCase(S1) = LowerCase(S2). I.e., if strings
are equal to each other without caring of characters case sensitivity
(ASCII only). }
function AnsiEq( const S1, S2 : String ) : Boolean;
{* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI
stringsare equal to each other without caring of characters case
sensitivity. }
{$IFNDEF _D2}
{$IFNDEF _FPC}
function WAnsiEq( const S1, S2 : WideString ) : Boolean;
{* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI
stringsare equal to each other without caring of characters case
sensitivity. }
{$ENDIF _FPC}
{$ENDIF _D2}
function StrIn( const S : String; const A : array of String ) : Boolean;
{* Returns True, if S is "equal" to one of strings, taking place
in A array. To check equality, StrEq function is used, i.e.
comaprison is taking place without case sensitivity. }
{$IFNDEF _FPC}
type TSetOfChar = Set of Char;
{$IFNDEF _D2}
function WStrIn( const S : WideString; const A : array of WideString ) : Boolean;
{* Returns True, if S is "equal" to one of strings, taking place
in A array. To check equality, WAnsiEq function is used, i.e.
comaprison is taking place without case sensitivity. }
function CharIn( C: KOLChar; const A: TSetOfChar ): Boolean;
{* To replace expressions like S[1] in [ '0'..'z' ] to CharIn( S[ 1 ], [ '0'..'z' ] )
(and to avoid problems with Unicode version of code). }
{$ENDIF _D2}
{$ENDIF _FPC}
function StrIs( const S : String; const A : array of String; var Idx: Integer ) : Boolean;
{* Returns True, if S is "equal" to one of strings, taking place
in A array, and in such Case Idx also is assigned to an index of A element
equal to S. To check equality, StrEq function is used, i.e.
comaprison is taking place without case sensitivity. }
function IntIn( Value: Integer; const List: array of Integer ): Boolean;
{* Returns TRUE, if Value is found in a List. }
function _StrSatisfy( S, Mask : PKOLChar ) : Boolean;
{* }
function _2StrSatisfy( S, Mask: PKOLChar ): Boolean;
{* }
function StrSatisfy( const S, Mask : KOLString ) : Boolean;
{* Returns True, if S is satisfying to a given Mask (which can contain
wildcard symbols '*' and '?' interpeted correspondently as 'any
set of characters' and 'single any character'. If there are no
such wildcard symbols in a Mask, result is True only if S is maching
to Mask string.) }
function StrReplace( var S: String; const From, ReplTo: String ): Boolean;
{* Replaces first occurance of From to ReplTo in S, returns True,
if pattern From was found and replaced. }
function KOLStrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean;
{* Replaces first occurance of From to ReplTo in S, returns True,
if pattern From was found and replaced. }
{$IFNDEF _FPC}
{$IFNDEF _D2}
function WStrReplace( var S: WideString; const From, ReplTo: WideString ): Boolean;
{* Replaces first occurance of From to ReplTo in S, returns True,
if pattern From was found and replaced. See also function StrReplace.
This function is not available in Delphi2 (this version of Delphi
does not support WideString type). }
{$ENDIF _D2}
{$ENDIF _FPC}
function StrRepeat( const S: String; Count: Integer ): String;
{* Repeats given string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }
{$IFNDEF _FPC}
{$IFNDEF _D2}
function WStrRepeat( const S: WideString; Count: Integer ): WideString;
{* Repeats given wide string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }
{$ENDIF _D2}
{$ENDIF _FPC}
procedure NormalizeUnixText( var S: String );
{* In the string S, replaces all occurances of character #10 (without leading #13)
to the character #13. }
procedure Koi8ToAnsi( s: PChar );
{* Converts Koi8 text to Ansi (in place) }
function StrPCopy(Dest: PChar; const Source: string): PChar;
{* Copyes Pascal-style string into null-terminaed one. }
function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;
{* Copyes first MaxLen characters of Pascal-style string into
null-terminated one. }
function DelimiterLast( const Str, Delimiters: KOLString ): Integer;
{* Returns index of the last of delimiters given by same named parameter
among characters of Str. If there are no delimiters found, length of
Str is returned. This function is intended mainly to use in filename
parsing functions. }
function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar;
{* Returns address of the last of delimiters given by Delimiters parameter
among characters of Str. If there are no delimeters found, position of
the null terminator in Str is returned. This function is intended
mainly to use in filename parsing functions. }
{$IFDEF _D3orHigher}
function W__DelimiterLast( Str, Delimiters: PWideChar ): PWideChar;
{* }
{$ENDIF _D3orHigher}
function SkipSpaces( P: PKOLChar ): PKOLChar;
{* Skips all characters #1..' ' in a string.
}
{$IFDEF F_P}
function DummyStrFun( const S: String ): String;
{$ENDIF}
//[Memory FUNCTIONS DECLARATIONS]
function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;
{* Fast compare of two memory blocks. }
function AllocMem( Size : Integer ) : Pointer;
{* Allocates global memory and unlocks it. }
procedure DisposeMem( var Addr : Pointer );
{* Locks global memory block given by pointer, and frees it.
Does nothing, if the pointer is nil.
|
}
{$IFDEF WIN_GDI}
//[clipboard FUNCTIONS DECLARATIONS]
function ClipboardHasText: Boolean;
{* Returns true, if the clipboard contain text to paste from. }
function Clipboard2Text: String;
{* If clipboard contains text, this function returns it for You. }
{$IFNDEF _FPC}
{$IFNDEF _D2}
function Clipboard2WText: WideString;
{* If clipboard contains text, this function returns it for You (as Unicode string). }
{$ENDIF _D2}
{$ENDIF _FPC}
function Text2Clipboard( const S: String ): Boolean;
{* Puts given string to a clipboard. }
{$IFNDEF _FPC}
{$IFNDEF _D2}
function WText2Clipboard( const WS: WideString ): Boolean;
{* Puts given Unicode string to a clipboard.
|
}
{$ENDIF _D2}
{$ENDIF _FPC}
{$ifdef win32}
//[Mnemonics FUNCTIONS DECLARATIONS]
var SearchMnemonics: function ( const S: KOLString ): KOLString
= {$IFDEF F_P} DummyStrFun {$ELSE}
{$IFDEF UNICODE_CTRLS} WAnsiUpperCase {$ELSE} AnsiUpperCase {$ENDIF} {$ENDIF};
MnemonicsLocale: Integer;
procedure SupportAnsiMnemonics( LocaleID: Integer );
{* Provides encoding to work with given locale. Call this global function to
extend TControl.SupportMnemonics capability (also should be called for a form
or for Applet variable).
}
{$endif win32}
{$ENDIF WIN_GDI}
{$IFDEF WIN_GDI}
//[TDateTime TYPE DEFINITION]
type
//TDateTime = Double; // well, it is already defined so in System.pas
{* Basic date and time type. Integer part represents year and days (as is,
i.e. 1-Jan-2000 is representing by value 730141, which is a number of
days from 1-Jan-0001 to 1-Jan-2000 inclusively). Fractional part is
representing hours, minutes, seconds and milliseconds of a day
proportionally (like in VCL TDateTime type, e.g. 0.5 = 12:00, 0.25 = 6:00,
etc.). }
PDayTable = ^TDayTable;
TDayTable = array[1..12] of Word;
TDateFormat = ( dfShortDate, dfLongDate );
{* Date formats available to use in formatting date/time to string. }
TTimeFormatFlag = ( tffNoMinutes, tffNoSeconds, tffNoMarker, tffForce24 );
{* Additional flags, used for formatting time. }
TTimeFormatFlags = Set of TTimeFormatFlag;
{* Set of flags, used for formatting time. }
const
MonthDays: array [Boolean] of TDayTable =
((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
(31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31));
{* The MonthDays array can be used to quickly find the number of
days in a month: MonthDays[IsLeapYear(Y), M]. }
SecsPerDay = 24 * 60 * 60;
{* Seconds per day. }
MSecsPerDay = SecsPerDay * 1000;
{* Milliseconds per day. }
VCLDate0 = 693594;
{* Value to convert VCL "date 0" to KOL "date 0" and back.
This value corresponds to 30-Dec-1899, 0:00:00. So,
to convert VCL date to KOL date, just subtract this
value from VCL date. And to convert back from KOL date
to VCL date, add this value to KOL date.}
{++}(*
procedure GetLocalTime(var lpSystemTime: TSystemTime); {$ifdef wince}cdecl{$else}stdcall{$endif};
procedure GetSystemTime(var lpSystemTime: TSystemTime); {$ifdef wince}cdecl{$else}stdcall{$endif};
*){--}
//[Date&Time FUNCTIONS DECLARATIONS]
function Now : TDateTime;
{* Returns local date and time on running PC. }
function Date: TDateTime;
{* Returns todaylocal date. }
procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD );
{* Decodes date. }
procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD );
{* Decodes date. }
function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean;
{* Encodes date. }
function CompareSystemTime(const D1, D2 : TSystemTime) : Integer;
{* Compares to TSystemTime records. Returns -1, 0, or 1 if, correspondantly,
D1 < D2, D1 = D2 and D1 > D2. }
procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer );
{* Increases/decreases day in TSystemTime record onto given days count
(can be negative). }
procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer );
{* Increases/decreases month number in TSystemTime record onto given
months count (can be negative). Correct result is not garantee if
day number is incorrect for newly obtained month. }
function IsLeapYear(Year: Integer): Boolean;
{* Returns True, if given year is "leap" (i.e. has 29 days in the February). }
function DayOfWeek(Date: TDateTime): Integer;
{* Returns day of week (0..6) for given date. }
function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean;
{* Converts TSystemTime record to XDateTime variable. }
function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
{* Converts TDateTime variable to TSystemTime record. }
function DateTime_System2Local( DTSys: TDateTime ): TDateTime;
{* Converts DTSys representing system time (+0 Grinvich) to local time. }
function DateTime_Local2System( DTLoc: TDateTime ): TDateTime;
{* Converts DTLoc representing local time to system time (+0 Grinvich) }
function FileTime2DateTime( const ft: TFileTime; var DT: TDateTime ): Boolean;
{* }
function DateTime2FileTime( DT: TDateTime; var ft: TFileTime ): Boolean;
{* }
procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);
{* Dividing of integer onto divisor with obtaining both result of division
and remainder. }
function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
const DfltDateFormat : TDateFormat;
const DateFormat : PKOLChar ) : KOLString;
{* Formats date, stored in TSystemTime record into string, using given locale
and date/time formatting flags. (E.g.: GetUserDefaultLangID). }
function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
const Flags : TTimeFormatFlags;
const TimeFormat : PKOLChar ) : KOLString;
{* Formats time, stored in TSystemTime record into string, using given locale
and date/time formatting flags. }
function Date2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
{* Represents date as a string correspondently to Fmt formatting string.
See possible pictures in definition of the function Str2DateTimeFmt
(the first part). If Fmt string is empty, default system date format
for short date string used. }
function Time2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
{* Represents time as a string correspondently to Fmt formatting string.
See possible pictures in definition of the function Str2DateTimeFmt
(the second part). If Fmt string is empty, default system time format
for short date string used. }
function DateTime2StrShort( D: TDateTime ): String;
{* Formats date and time to string in short date format using current user
locale. }
function Str2DateTimeFmt( const sFmtStr, sS: KOLString ): TDateTime;
{* Restores date or/and time from string correspondently to a format string.
Date and time formatting string can contain following pictures (case
sensitive):
|
DATE PICTURES
d Day of the month as digits without leading zeros for single digit days.
dd Day of the month as digits with leading zeros for single digit days
ddd Day of the week as a 3-letter abbreviation as specified by a
LOCALE_SABBREVDAYNAME value.
dddd Day of the week as specified by a LOCALE_SDAYNAME value.
M Month as digits without leading zeros for single digit months.
MM Month as digits with leading zeros for single digit months
MMM Month as a three letter abbreviation as specified by a LOCALE_SABBREVMONTHNAME value.
MMMM Month as specified by a LOCALE_SMONTHNAME value.
y Year represented only be the last digit.
yy Year represented only be the last two digits.
yyyy Year represented by the full 4 digits.
gg Period/era string as specified by the CAL_SERASTRING value. The gg
format picture in a date string is ignored if there is no associated era
string. In Enlish locales, usual values are BC or AD.
TIME PICTURES
h Hours without leading zeros for single-digit hours (12-hour clock).
hh Hours with leading zeros for single-digit hours (12-hour clock).
H Hours without leading zeros for single-digit hours (24-hour clock).
HH Hours with leading zeros for single-digit hours (24-hour clock).
m Minutes without leading zeros for single-digit minutes.
mm Minutes with leading zeros for single-digit minutes.
s Seconds without leading zeros for single-digit seconds.
ss Seconds with leading zeros for single-digit seconds.
t One character–time marker string (usually P or A, in English locales).
tt Multicharacter–time marker string (usually PM or AM, in English locales).
|
E.g., 'D, yyyy/MM/dd h:mm:ss'.
See also Str2DateTimeShort function.
}
function Str2DateTimeShort( const S: String ): TDateTime;
{* Restores date and time from string correspondently to current user locale. }
function Str2DateTimeShortEx( const S: KOLString ): TDateTime;
{* Like Str2DateTimeShort above, but uses locale defined date and time
separators to avoid recognizing time as a date in some cases.
|
}
{$ENDIF WIN_GDI}
//[OpenFile CONSTANTS]
const
ofOpenRead = {$IFDEF LIN} O_RDONLY {$ELSE} $80000000 {$ENDIF};
{* Use this flag (in combination with others) to open file for "read" only. }
ofOpenWrite = {$IFDEF LIN} O_WRONLY {$ELSE} $40000000 {$ENDIF};
{* Use this flag (in combination with others) to open file for "write" only. }
ofOpenReadWrite = {$IFDEF LIN} O_RDWR {$ELSE} $C0000000 {$ENDIF};
{* Use this flag (in combination with others) to open file for "read" and "write". }
ofShareExclusive = {$IFDEF LIN} $10 {$ELSE} $00 {$ENDIF};
{* Use this flag (in combination with others) to open file for exclusive use. }
ofShareDenyWrite = {$IFDEF LIN} $20 {$ELSE} $01 {$ENDIF};
{* Use this flag (in combination with others) to open file in share mode, when
only attempts to open it in other process for "write" will be impossible.
I.e., other processes could open this file simultaneously for read only
access. }
ofShareDenyRead = {$IFDEF LIN} 0 {not supported} {$ELSE} $02 {$ENDIF};
{* Use this flag (in combination with others) to open file in share mode, when
only attempts to open it for "read" in other processes will be disabled.
I.e., other processes could open it for "write" only access. }
ofShareDenyNone = {$IFDEF LIN} $30 {$ELSE} $03 {$ENDIF};
{* Use this flag (in combination with others) to open file in full sharing mode.
I.e. any process will be able open this file using the same share flag. }
ofCreateNew = {$IFDEF LIN} O_CREAT or O_TRUNC {$ELSE} $100 {$ENDIF};
{* Default creation disposition. Use this flag for creating new file (usually
for write access. }
ofCreateAlways = {$IFDEF LIN} O_CREAT {$ELSE} $200 {$ENDIF};
{* Use this flag (in combination with others) to open existing or creating new
file. If existing file is opened, it is truncated to size 0. }
ofOpenExisting = {$IFDEF LIN} 0 {$ELSE} $300 {$ENDIF};
{* Use this flag (in combination with others) to open existing file only. }
ofOpenAlways = {$IFDEF LIN} O_CREAT {$ELSE} $400 {$ENDIF};
{* Use this flag (in combination with others) to open existing or create new
(if such file is not yet exists). }
ofTruncateExisting = {$IFDEF LIN} O_TRUNC {$ELSE} $500 {$ENDIF};
{* Use this flag (in combination with others) to open existing file and truncate
it to size 0. }
ofAttrReadOnly = {$IFDEF LIN} 0 {$ELSE} $10000 {$ENDIF};
{* Use this flag to create Read-Only file (?). }
ofAttrHidden = {$IFDEF LIN} 0 {$ELSE} $20000 {$ENDIF};
{* Use this flag to create hidden file. }
ofAttrSystem = {$IFDEF LIN} 0 {$ELSE} $40000 {$ENDIF};
{* Use this flag to create system file. }
ofAttrTemp = {$IFDEF LIN} 0 {$ELSE} $1000000 {$ENDIF};
{* Use this flag to create temp file. }
ofAttrArchive = {$IFDEF LIN} 0 {$ELSE} $200000 {$ENDIF};
{* Use this flag to create archive file. }
ofAttrCompressed = {$IFDEF LIN} 0 {$ELSE} $8000000 {$ENDIF};
{* Use this flag to create compressed file. Has effect only on NTFS, and
only if ofAttrCompressed is not specified also. }
ofAttrOffline = {$IFDEF LIN} 0 {$ELSE} $10000000 {$ENDIF};
{* Use this flag to create offline file. }
//[END OF OpenFileConstants]
//[File FUNCTIONS DECLARATIONS]
{$IFDEF _D3orHigher}
function WFileCreate(const FileName: WideString; OpenFlags: DWord): THandle;
{* }
{$ENDIF}
function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle;
{* Call this function to open existing or create new file. OpenFlags
parameter can be a combination of up to three flags (by one from
each group:
|
|&L=| %0 |
|&E= |
- 1st group. Here You decide
wish You open file for read, write or read-and-write operations;
-2nd
group - sharing. Here You can mark out sharing mode, which is used to
open file.
- 3rd group - creation disposition. Here You determine, either to create new
or open existing file and if to truncate existing or not.
|
}
function FileClose(Handle: THandle): Boolean;
{* Call it to close opened earlier file. }
function FileExists( const FileName: KOLString ) : Boolean;
{* Returns True, if given file exists.
|
Note (by Dod):
It is not documented in a help for GetFileAttributes, but it seems that
under NT-based Windows systems, FALSE is always returned for files
opened for excluseve use like pagefile.sys. }
{$IFDEF _D3orHigher}
function WFileExists( const FileName: WideString ) : Boolean;
{* Returns True, if given file exists.
|
Note (by Dod):
It is not documented in a help for GetFileAttributes, but it seems that
under NT-based Windows systems, FALSE is always returned for files
opened for excluseve use like pagefile.sys. }
{$ENDIF}
function FileSeek(Handle: THandle; MoveTo: integer; MoveMethod: TMoveMethod): DWord;
{* Changes current position in file. }
{$IFDEF _D4orHigher}
function FileFarSeek(Handle: THandle; MoveTo: Int64; MoveMethod: TMoveMethod): DWord;
{* Changes current position in file. }
{$ENDIF _D4orHigher}
function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;
{* Reads bytes from current position in file to buffer. Returns number of
read bytes. }
{$IFDEF LIN}
function GetFileSize( Handle: THandle; HiSize: PDWORD ): DWORD;
{$ENDIF LIN}
function File2Str(Handle: THandle): String;
{* Reads file from current position to the end and returns result as ansi string. }
{$IFNDEF _D2}
function File2WStr(Handle: THandle): WideString;
{* Reads file from current position to the end and returns result as unicode string. }
{$ENDIF}
function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord;
{* Writes bytes from buffer to file from current position, extending its
size if needed. }
function FileEOF( Handle: THandle ) : Boolean;
{* Returns True, if EOF is achieved during read operations or last byte is
overwritten or append made to extend file during last write operation. }
function FileFullPath( const FileName : KOLString ) : KOLString;
{* Returns full path name for given file. Validness of source FileName path
is not checked at all. }
{$IFDEF WIN} //--------------- these functions have not sense in Linux: --------
function FileShortPath( const FileName: KOLString ): KOLString;
{* Returns short path to the file or directory. }
function FileIconSystemIdx( const Path: KOLString ): Integer;
{* Returns index of the index of the system icon correspondent to the file or
directory in system icon image list. }
function FileIconSysIdxOffline( const Path: KOLString ): Integer;
{* The same as FileIconSystemIdx, but an icon is calculated for the file
as it were offline (it is possible to get an icon for file even if
it is not existing, on base of its extension only). }
function DirIconSysIdxOffline( const Path: KOLString ): Integer;
{* The same as FileIconSysIdxOffline, but for a folder rather then for a file. }
{$ENDIF WIN} //-----------------------------------------------------------------
procedure LogFileOutput( const filepath, str: String );
{* Debug function. Use it to append given string to the end of the given file. }
function StrSaveToFile( const Filename: KOLString; const Str: String ): Boolean;
{* Saves a string to a file without any changes. If file does not exists, it is
created. If it exists, it is overriden. If operation failed, FALSE is returned. }
function StrLoadFromFile( const Filename: KOLString ): String;
{* Reads entire file and returns its content as a string. If operation failed,
an empty strinng is returned.
|
by Sergey Shishmintzev: it is possible to pass Filename = 'CON' to
read input from redirected console output. }
{$IFNDEF _D2}
function WStrSaveToFile( const Filename: KOLString; const Str: WideString ): Boolean;
{* Saves a string to a file without any changes. If file does not exists, it is
created. If it exists, it is overriden. If operation failed, FALSE is returned. }
function WStrLoadFromFile( const Filename: KOLString ): WideString;
{* Reads entire file and returns its content as a string. If operation failed,
an empty strinng is returned.
|
by Sergey Shishmintzev: it is possible to pass Filename = 'CON' to
read input from redirected console output. }
{$ENDIF}
function Mem2File( Filename: PKOLChar; Mem: Pointer; Len: Integer ): Integer;
{* Saves memory block to a file (if file exists it is overriden, created new if
not exists). }
function File2Mem( Filename: PKOLChar; Mem: Pointer; MaxLen: Integer ): Integer;
{* Loads file content to memory. }
{$IFDEF WIN}
type
PFindFileData = ^TFindFileData;
TFindFileData = {$ifndef wince}packed{$endif} record
// from TWin32FindData: -------------
dwFileAttributes: DWORD;
ftCreationTime: TFileTime;
ftLastAccessTime: TFileTime;
ftLastWriteTime: TFileTime;
nFileSizeHigh: DWORD;
nFileSizeLow: DWORD;
dwReserved0: DWORD;
{$ifndef wince}dwReserved1: DWORD;{$endif}
cFileName: array[0..MAX_PATH - 1] of KOLChar;
{$ifndef wince}cAlternateFileName: array[0..13] of KOLChar;{$endif}
//-------- + handle:
FindHandle: THandle;
end;
{$ENDIF WIN}
function Find_First( const FilePathName: KOLString; var F: TFindFileData ): Boolean;
function Find_Next( var F: TFindFileData ): Boolean;
procedure Find_Close( var F: TFindFileData );
{$IFDEF _D2orD3}
function FileSize( const Path: KOLString ) : Integer;
{$ELSE}
function FileSize( const Path: KOLString ) : Int64;
{$ENDIF}
{* Returns file size in bytes without opening it. If file too large
to represent its size as Integer, -1 is returned. }
procedure FileTime( const Path: KOLString;
CreateTime, LastAccessTime, LastModifyTime: PFileTime );
{* Returns file times without opening it. }
function GetUniqueFilename( PathName: KOLstring ) : KOLString;
{* If file given by PathName exists, modifies it to create unique
filename in target folder and returns it. Modification is performed
by incrementing last number in name (if name part of file does not
represent a number, such number is generated and concatenated to
it). E.g., if file aaa.aaa is already exist, the function checks
names aaa1.aaa, aaa2.aaa, ..., aaa10.aaa, etc. For name abc123.ext,
names abc124.ext, abc125.ext, etc. will be checked. }
function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;
{* Compares time of file (createing, writing, accessing. Returns
-1, 0, 1 if correspondantly FT1FT2. }
function DirectoryExists(const Name: KOLString): Boolean;
{* Returns True if given directory (folder) exists. }
function DiskPresent( const DrivePath: KOLString ): Boolean;
{* Returns TRUE if the disk is present }
{$IFDEF _D3orHigher}
function WDirectoryExists(const Name: WideString): Boolean;
{* }
{$ENDIF}
function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean; const Mask: String ): Boolean;
{* Returns TRUE if directory does not contain files (or directories only)
satisfying given mask. }
function DirectoryEmpty(const Name: KOLString): Boolean;
{* Returns True if given directory is not exists or empty. }
//[Directory FUNCTIONS DECLARATIONS]
function DirectoryHasSubdirs( const Path: KOLString ): Boolean;
{* Returns TRUE if given directory exists and has subdirectories. }
function GetStartDir: KOLString;
{* Returns path to directory where executable is located (regardless
of current directory). }
function ExePath: KOLString;
{* Returns the path to the module (exe, dll) itself. }
//---------------------------------------------------------
// Following functions/procedures are created by Edward Aretino:
// IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter,
// ForceDirectories, CreateDir, ChangeFileExt
//---------------------------------------------------------
function ExcludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
{* If S is finished with character C, it is excluded. }
function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
{* If S is not finished with character C, it is added. }
function IncludeTrailingPathDelimiter(const S: KOLString): KOLstring;
{* by Edward Aretino. Adds '\' to the end if it is not present. }
function ExcludeTrailingPathDelimiter(const S: KOLString): KOLstring;
{* by Edward Aretino. Removes '\' at the end if it is present. }
function ExtractFileDrive( const Path: KOLString ) : KOLString;
{* Returns only drive part from exact path to a file or a directory.
For network paths, returns a computer name together with a following
name of shared directory (like '\\compname\shared\' ). }
function ExtractFilePath( const Path: KOLString ) : KOLString;
{* Returns only path part from exact path to file. }
{$IFDEF _D3orHigher}
function WExtractFilePath( const Path: WideString ) : WideString;
{* Returns only path part from exact path to file. }
{$ENDIF}
function IsNetworkPath( const Path: KOLString ): Boolean;
{* Returns TRUE, if Path is starting from '\\'. }
function ExtractFileName( const Path: KOLString ) : KOLString;
{* Extracts file name from exact path to file. }
function ExtractFileNameWOext( const Path: KOLString ) : KOLString;
{* Extracts file name from path to file or from filename. }
function ExtractFileExt( const Path: KOLString ) : KOLString;
{* Extracts extention from file name (returns it with dot '.' first) }
function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
{* Returns Path to a file with extension replaced to a new extension.
Pass a new extension started with '.', e.g. '.txt'. }
function ForceDirectories(Dir: KOLString): Boolean;
{* by Edward Aretino. Creates given directory if not present. All needed
subdirectories are created if necessary. }
function CreateDir(const Dir: KOLString): Boolean;
{* by Edward Aretino. Creates given directory. }
function ChangeFileExt(FileName: KOLString; const Extension: KOLstring): KOLstring;
{* by Edward Aretino. Changes file extention. }
function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString;
{* Returns a path with extension replaced to a given one. }
{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
function ExtractShortPathName( const Path: KOLString ): KOLString;
{* }
{$IFDEF GDI}
function FilePathShortened( const Path: KOLString; MaxLen: Integer ): KOLString;
{* Returns shortened file path to fit MaxLen characters. }
function FilePathShortenPixels( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
{* Returns shortened file path to fit MaxPixels for a given DC. If you pass
Canvas.Handle of any control or bitmap object, ensure that font is valid
for it (or call TCanvas.RequiredState( FontValid ) method before. If DC passed
= 0, call is equivalent to call FilePathShortened, and MaxPixels means in such
case maximum number of characters. }
function MinimizeName( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
{* Exactly the same as MinimizeName in FileCtrl.pas (VCL). }
{$ENDIF GDI}
function GetSystemDir: KOLString;
{* Returns path to windows system directory. }
function GetWindowsDir : KOLstring;
{* Returns path to Windows directory. }
{$ENDIF WIN} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
function GetWorkDir : KOLstring;
{* Returns path to application's working directory. }
function GetTempDir : KOLstring;
{* Returns path to default temp folder (directory to place temporary files). }
function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
{* Returns path to just created temporary file. }
function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLstring): KOLstring;
{* List of files in string, separating each path from others with a character stored
in FileOpSeparator variables (#13 by default).
E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}
function DeleteFiles( const DirPath: KOLString ): Boolean;
{* Deletes files by file mask (given with wildcards '*' and '?'). }
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
var FileOpSeparator: KOLChar = {$IFDEF OLD_COMPAT}';'{$ELSE}#13{$ENDIF};
function DoFileOp( const FromList, ToList: KOLString; FileOp: UINT; Flags: Word;
Title: PKOLChar): Boolean;
{* By Unknown Mystic. FileOp can be: FO_MOVE, FO_COPY, FO_DELETE, FO_RENAME.
Flags can be a combination of values: FOF_MULTIDESTFILES, FOF_CONFIRMMOUSE,
FOF_SILENT, FOF_RENAMEONCOLLISION, FOF_NOCONFIRMATION, FOF_WANTMAPPINGHANDLE,
FOF_ALLOWUNDO, FOF_FILESONLY, FOF_SIMPLEPROGRESS, FOF_NOCONFIRMMKDIR,
FOF_NOERRORUI. Title used only with FOF_SIMPLEPROGRESS. }
function DeleteFile2Recycle( const Filename : KOLString ) : Boolean;
{* Deletes file to recycle bin. This operation can be very slow, when
called for a single file. To delete group of files at once (fast),
pass a list of paths to files to be deleted, separating each path
from others with a character stored in FileOpSeparator variable (by default #13,
but in case when OLD_COMPAT symbol added - ';'). E.g.: 'unit1.dcu'#13'unit1.~pa'
|
FALSE is returned only in case when at least one file was not deleted
successfully.
|
Note, that files are deleted not to recycle bin, if wildcards are
used or not fully qualified paths to files. }
function CopyMoveFiles( const FromList, ToList: KOLString; Move: Boolean ): Boolean;
{* }
{-}
function DiskFreeSpace( const Path: KOLString ): I64; {+}
{* Returns disk free space in bytes. Pass a path to root directory,
e.g. 'C:\'.
|
These functions can be used independently to simplify access to Windows
registry. }
{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
//[Registry FUNCTIONS DECLARATIONS]
{++}(*
function RegSetValueEx(hKey: HKEY; lpValueName: PChar;
Reserved: DWORD; dwType: DWORD; lpData: Pointer; cbData: DWORD): Longint; {$ifdef wince}cdecl{$else}stdcall{$endif};
*){--}
function RegKeyOpenRead( Key: HKey; const SubKey: KOLString ): HKey;
{* Opens registry key for read operations (including enumerating of subkeys).
Pass either handle of opened earlier key or one of constans
HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS
as a first parameter. If not successful, 0 is returned. }
function RegKeyOpenWrite( Key: HKey; const SubKey: KOLString ): HKey;
{* Opens registry key for write operations (including adding new values or
subkeys), as well as for read operations too. See also RegKeyOpenRead. }
function RegKeyOpenCreate( Key: HKey; const SubKey: KOLString ): HKey;
{* Creates and opens key. }
function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString;
{* Reads key, which must have type REG_SZ (null-terminated string). If
not successful, empty string is returned. This function as well as all
other registry manipulation functions, does nothing, if Key passed is 0
(without producing any error). }
function RegKeyGetStrEx( Key: HKey; const ValueName: KOLString ): KOLString;
{* Like RegKeyGetStr, but accepts REG_EXPAND_SZ type, expanding all
environment variables in resulting string.
|
Code provided by neuron, e-mailto:neuron@hollowtube.mine.nu }
function RegKeyGetDw( Key: HKey; const ValueName: KOLString ): DWORD;
{* Reads key value, which must have type REG_DWORD. If ValueName passed
is '' (empty string), unnamed (default) value is reading. If not
successful, 0 is returned. }
function RegKeySetStr(Key: HKey; const ValueName: KOLString; const Value: KOLString ): Boolean;
{* Writes new key value as null-terminated string (type REG_SZ). If not
successful, returns False. }
function RegKeySetStrEx( Key: HKey; const ValueName: KOLString; const Value: KOLString;
expand: boolean): Boolean;
{* Writes new key value as REG_SZ or REG_EXPAND_SZ. - by neuron, e-mailto:neuron@hollowtube.mine.nu }
function RegKeySetDw( Key: HKey; const ValueName: KOLString; Value: DWORD ): Boolean;
{* Writes new key value as dword (with type REG_DWORD). Returns False,
if not successful. }
procedure RegKeyClose( Key: HKey );
{* Closes key, opened using RegKeyOpenRead or RegKeyOpenWrite. (But does
nothing, if Key passed is 0). }
function RegKeyDelete( Key: HKey; const SubKey: KOLString ): Boolean;
{* Deletes key. Does nothing if key passed is 0 (returns FALSE). }
function RegKeyDeleteValue( Key: HKey; const SubKey: KOLString ): Boolean;
{* Deletes value. - by neuron, e-mailto:neuron@hollowtube.mine.nu }
function RegKeyExists( Key: HKey; const SubKey: String ): Boolean;
{* Returns TRUE, if given subkey exists under given Key. }
function RegKeyValExists( Key: HKey; const ValueName: KOLString ): Boolean;
{* Returns TRUE, if given value exists under the Key.
}
function RegKeyValueSize( Key: HKey; const ValueName: KOLString ): Integer;
{* Returns a size of value. This is a size of buffer needed to store
registry key value. For string value, size returned is equal to a
length of string plus 1 for terminated null character. }
function RegKeyGetBinary( Key: HKey; const ValueName: KOLString; var Buffer; Count: Integer ): Integer;
{* Reads binary data from a registry, writing it to the Buffer.
It is supposed that size of Buffer provided is at least Count bytes.
Returned value is actul count of bytes read from the registry and written
to the Buffer.
|
This function can be used to get data of any type from the registry, not
only REG_BINARY. }
function RegKeySetBinary( Key: HKey; const ValueName: KOLString; const Buffer; Count: Integer ): Boolean;
{* Stores binary data in the registry. }
function RegKeyGetDateTime(Key: HKey; const ValueName: KOLString): TDateTime;
{* Returns datetime variable stored in registry in binary format. }
function RegKeySetDateTime(Key: HKey; const ValueName: KOLString; DateTime: TDateTime): Boolean;
{* Stores DateTime variable in the registry. }
//-------------------------------------------------------
// registry functions by Valerian Luft
//-------------------------------------------------------
function RegKeyGetSubKeys( const Key: HKEY; List: PStrList): Boolean;
{* The function enumerates subkeys of the specified open registry key.
True is returned, if successful.
}
function RegKeyGetValueNames(const Key: HKEY; List: PStrList): Boolean;
{* The function enumerates value names of the specified open registry key.
True is returned, if successful.
}
function RegKeyGetValueTyp (const Key:HKEY; const ValueName: KOLString) : DWORD;
{* The function receives the type of data stored in the specified value.
|
If the function fails, the return value is the Key value.
|
If the function succeeds, the return value return will be one of the following:
|
REG_BINARY , REG_DWORD, REG_DWORD_LITTLE_ENDIAN,
REG_DWORD_BIG_ENDIAN, REG_EXPAND_SZ, REG_LINK , REG_MULTI_SZ,
REG_NONE, REG_RESOURCE_LIST, REG_SZ
|
This part contains implementation of 'quick sort' algorithm,
based on following code:
|
| TQSort by Mike Junkin 10/19/95.
| DoQSort routine adapted from Peter Szymiczek's QSort procedure which
| was presented in issue#8 of The Unofficial Delphi Newsletter.
| TQSort changed by Vladimir Kladov (Mr.Bonanzas) to allow 32-bit
| sorting (of big arrays with more than 64K elements).
|
Finally, this sort procedure is adapted to XCL (and then to KOL)
requirements (no references to SysUtils, Classes etc. TQSort object
is transferred to a single procedure call and DoQSort method is
renamed to SortData - which is a regular procedure now). }
{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
//[Sorting TYPES]
type
TCompareEvent = function (const Data: Pointer; const e1,e2 : Dword) : Integer;
{* Event type to define comparison function between two elements of an array.
This event handler must return -1 or +1 (correspondently for cases e1e2). Items are enumerated from 0 to uNElem. }
TSwapEvent = procedure (const Data : Pointer; const e1,e2 : Dword);
{* Event type to define swap procedure which is swapping two elements of an
array. }
//[SortData FUNCTIONS DECLARATIONS]
procedure SortData( const Data: Pointer; const uNElem: Dword;
const CompareFun: TCompareEvent;
const SwapProc: TSwapEvent );
{* Call it to sort any array of data of any kind, passing total
number of items in an array and two defined (regular) function
and procedure to perform custom compare and swap operations.
First procedure parameter is to pass it to callback function
CompareFun and procedure SwapProc. Items are enumerated from
0 to uNElem-1. }
procedure SwapListItems( const L: Pointer; const e1, e2: DWORD );
{* Use this function as the last parameter for SortData call when a PList
object is sorting. SwapListItems just exchanges two items of the list. }
procedure SortIntegerArray( var A : array of Integer );
{* procedure to sort array of integers. }
procedure SortDwordArray( var A : array of DWORD );
{* Procedure to sort array of unsigned 32-bit integers.
|
}
{ -- directory list object -- }
//[DirList Object]
type
TDirItemAction = ( diSkip, diAccept, diCancel );
TOnDirItem = procedure( Sender: PObj; var DirItem: TFindFileData; var Accept: TDirItemAction )
of object;
TSortDirRules = ( sdrNone, sdrFoldersFirst, sdrCaseSensitive, sdrByName, sdrByExt,
sdrBySize, sdrBySizeDescending, sdrByDateCreate, sdrByDateChanged,
sdrByDateAccessed );
{* List of rules (options) to sort directories. Rules are passed to Sort
method in an array, and first placed rules are applied first. }
{++}(*TDirList = class;*){--}
PDirList = {-}^{+}TDirList;
{ ----------------------------------------------------------------------
TDirList - Directory scanning
----------------------------------------------------------------------- }
//[TDirList DEFINITION]
TDirList = object( TObj )
{* Allows easy directory scanning. This is not visual object, but
storage to simplify working with directory content. }
protected
FList : PList;
FPath: KOLString;
fFilters: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
fOnItem: TOnDirItem;
function Get(Idx: Integer): PFindFileData;
function GetCount: Integer;
function GetNames(Idx: Integer): KOLString;
function GetIsDirectory(Idx: Integer): Boolean;
protected
function SatisfyFilter( FileName : PKOLChar; FileAttr, FindAttr : DWord ) : Boolean;
{++}(*public*){--}
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* Destructor. As usual, call Free method to destroy an object. }
public
property Items[ Idx : Integer ] : PFindfileData read Get; default;
{* Full access to scanned items (files and subdirectories). }
property IsDirectory[ Idx: Integer ]: Boolean read GetIsDirectory;
{* Returns TRUE, if specified item represents a directory, not a file. }
property Count : Integer read GetCount;
{* Number of items. }
property Names[ Idx : Integer ] : KOLString read GetNames;
{* Full long names of directory items. }
property Path : KOLString read FPath;
{* Path of scanned directory. }
procedure Clear;
{* Call it to clear list of files. }
procedure ScanDirectory( const DirPath, Filter : KOLString; Attr : DWord );
{* Call it to rescan directory or to scan another directory content
(method Clear is called first). Pass path to directory, file filter
and attributes to scan directory immediately.
|
Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr
parameter. If 0 passed, both files and directories are listed. }
procedure ScanDirectoryEx( const DirPath, Filters : KOLString; Attr : DWord );
{* Call it to rescan directory or to scan another directory content
(method Clear is called first). Pass path to directory, file filter
and attributes to scan directory immediately.
|
Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr
parameter. }
procedure Sort( Rules : array of TSortDirRules );
{* Sorts directory entries. If empty rules array passed, default rules
array DefSortDirRules is used. }
function FileList( const Separator {e.g.: ';', or #13}: KOLString;
Dirs, FullPaths: Boolean ): KOLString;
{* Returns a string containing all names separated with Separator.
If Dirs=FALSE, only files are returned. }
property OnItem: TOnDirItem read fOnItem write fOnItem;
{* This event is called on reading each item while scanning directory.
To use it, first create PDirList object with empty path to scan, then
assign OnItem event and call ScanDirectory with correct path. }
end;
//[END OF TDirList DEFINITION]
//[NewDirList DECLARATIONS]
function NewDirList( const DirPath, Filter: KOLString; Attr: DWORD ): PDirList;
{* Creates directory list object using easy one-string filter. If Attr = FILE_ATTRIBUTE_NORMAL,
only files are scanned without directories. If Attr = 0, both files and
directories are listed. }
function NewDirListEx( const DirPath, Filters: KOLString; Attr: DWORD ): PDirList;
{* Creates directory list object using several filters, separated by ';'.
Filters starting from '^' consider to be anti-filters, i.e. files,
satisfying to those masks, are skept during scanning. }
const DefSortDirRules : array[ 0..3 ] of TSortDirRules = ( sdrFoldersFirst,
sdrByName, sdrBySize, sdrByDateCreate );
{* Default rules to sort directory entries. }
//[DirectorySize DECLARATION]
{-}
function DirectorySize( const Path: KOLString ): I64;
{* Returns directory size in bytes as large 64 bit integer. }
{+}
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
//[OpenSaveDialog OPTIONS]
type
TOpenSaveOption = ( OSCreatePrompt,
OSExtensionDiffent,
OSFileMustExist,
OSHideReadonly,
OSNoChangedir,
OSNoReferenceLinks,
OSAllowMultiSelect,
OSNoNetworkButton,
OSNoReadonlyReturn,
OSOverwritePrompt,
OSPathMustExist,
OSReadonly,
OSNoValidate
//{$IFDEF OpenSaveDialog_Extended}
,
OSTemplate,
OSHook
//{$ENDIF}
);
TOpenSaveOptions = set of TOpenSaveOption;
{* Options available for TOpenSaveDialog. }
{++}(*TOpenSaveDialog = class;*){--}
POpenSaveDialog = {-}^{+}TOpenSaveDialog;
{ ----------------------------------------------------------------------
TOpenSaveDialog
----------------------------------------------------------------------- }
//[TOpenSaveDialog DEFINITION]
TOpenSaveDialog = object( TObj )
{* Object to show standard Open/Save dialog. Initially provided
for XCL by Carlo Kok. }
protected
FFilter : KOLString;
fFilterIndex : Integer;
fOpenDialog : Boolean;
FInitialDir : KOLString;
FDefExtension : KOLString;
FFilename : KOLString;
FTitle : KOLString;
FOptions : TOpenSaveOptions;
fWnd: THandle;
fOpenReadOnly: Boolean;
public
TemplateName: KOLString; // do not forget to add OpenSaveDialog_Extended
HookProc: Pointer; // to project options conditionals!
NoPlaceBar: Boolean; // TRUE, if place bar is disabled in the new style
// dialogs (if the symbol OpenSaveDialog_Extended is
// not added in project options, place bar is always
// enabled in Windows 2000 and higher).
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* destructor }
Function Execute : Boolean;
{* Call it after creating to perform selecting of file by user. }
property Filename : KOLString read FFilename write FFileName;
{*
Filename is separated by #13 when multiselect is true and the first
file, is the path of the files selected.
|
| C:\Projects
| Test1.Dpr
| Test2.Dpr
|
If only one file is selected, it is provided as (e.g.)
C:\Projects\Test1.dpr
|
For case when OSAllowMultiselect option used, after each
call initial value for a Filename containing several files prevents
system from opening the dialog. To fix this, assign another initial
value to Filename property in your code, when you use multiselect.
}
property InitialDir : KOLString read FInitialDir write FInitialDir;
{* Initial directory path. If not set, current directory (usually
directory when program is started) is used. }
property Filter : KOLString read FFilter write FFilter;
{* A list of pairs of filter names and filter masks, separated with '|'.
If a mask contains more than one mask, it should be separated with ';'.
E.g.:
! 'All files|*.*|Text files|*.txt;*.1st;*.diz' }
property FilterIndex : Integer read FFilterIndex write FFilterIndex;
{* Index of default filter mask (0 by default, which means "first"). }
property OpenDialog : Boolean read FOpenDialog write FOpenDialog;
{* True, if "Open" dialog. False, if "Save" dialog. True is default. }
property Title : KOLString read Ftitle write Ftitle;
{* Title for dialog. }
property Options : TOpenSaveOptions read FOptions write FOptions;
{* Options. }
property DefExtension : KOLString read FDefExtension write FDefExtension;
{* Default extention. Set it to desired extension without leading period,
e.g. 'txt', but not '.txt'. }
property WndOwner: THandle read fWnd write fWnd;
{* Owner window handle. If not assigned, Applet.Handle is used (whenever
possible). Assign it, if your application has stay-on-top forms, and
a separate Applet object is used. }
property OpenReadOnly: Boolean read fOpenReadOnly;
{* TRUE after Execute, if Read Only check box was checked by the user.
Options are not affected anyway. }
end;
//[END OF TOpenSaveDialog DEFINITION]
//[Default OpenSaveDialog OPTIONS]
const DefOpenSaveDlgOptions: TOpenSaveOptions = [ OSHideReadonly,
OSOverwritePrompt, OSFileMustExist, OSPathMustExist ];
//[NewOpenSaveDialog DECLARATION]
function NewOpenSaveDialog( const Title, StrtDir: KOLString;
Options: TOpenSaveOptions ): POpenSaveDialog;
{* Creates object, which can be used (several times) to open file(s)
selecting dialog. }
//[OpenDirectory Object]
type
{++}(*TOpenDirDialog = class;*){--}
POpenDirDialog = {-}^{+}TOpenDirDialog;
TOpenDirOption = ( odBrowseForComputer, odBrowseForPrinter, odDontGoBelowDomain,
odOnlyFileSystemAncestors, odOnlySystemDirs, odStatusText,
odBrowseIncludeFiles, odEditBox, odNewDialogStyle );
{* Flags available for TOpenDirDialog object. }
// odfStatusText - do not support status callback
TOpenDirOptions = set of TOpenDirOption;
{* Set of all flags used to control ZOpenDirDialog class. }
TOnODSelChange = procedure( Sender: POpenDirDialog; NewSelDir: PKOL_Char;
var EnableOK: Integer; var StatusText: KOL_String )
of object;
{* Event type to be called when user select another directory in OpenDirDialog.
Set EnableOK to -1 to disable OK button, or to +1 to enable it.
It is also possible to set new StatusText string. }
{$ifdef wince}
{$define read_interface}
{$I KOLCEOpenDir.inc}
{$undef read_interface}
{$else}
{ ----------------------------------------------------------------------
TOpenDirDialog
----------------------------------------------------------------------- }
//[TOpenDirDialog DEFINITION]
TOpenDirDialog = object( TObj )
{* Dialog for open directories, uses SHBrowseForFolder. }
protected
FTitle: KOLString;
FOptions: TOpenDirOptions;
FCallBack: Pointer;
FCenterProc: procedure( Wnd: HWnd );
FBuf : array[ 0..MAX_PATH ] of KOLChar;
FInitialPath: String;
FCenterOnScreen: Boolean;
FDoSelChanged: procedure( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ); {$ifdef wince}cdecl{$else}stdcall{$endif};
FOnSelChanged: TOnODSelChange;
FStatusText: KOLString;
FWnd, FDialogWnd: HWnd;
function GetPath: KOLString;
procedure SetInitialPath(const Value: KOLString);
procedure SetCenterOnScreen(const Value: Boolean);
procedure SetOnSelChanged(const Value: TOnODSelChange);
function GetInitialPath: KOLString;
public
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* destructor }
function Execute : Boolean;
{* Call it to select directory by user. Returns True, if operation was
not cancelled by user. }
property Title : KOLString read FTitle write FTitle;
{* Title for a dialog. }
property Options : TOpenDirOptions read FOptions write FOptions;
{* Option flags. }
property Path : KOLString read GetPath;
{* Resulting (selected by user) path. }
property InitialPath: KOLString read GetInitialPath write SetInitialPath;
{* Set this property to a path of directory to be selected initially
in a dialog. }
property CenterOnScreen: Boolean read FCenterOnScreen write SetCenterOnScreen;
{* Set it to True to center dialog on screen. }
property OnSelChanged: TOnODSelChange read FOnSelChanged write SetOnSelChanged;
{* This event is called every time, when user selects another directory.
It is possible to enable/disable OK button in dialog and/or change
dialog status text in responce to event. }
property WndOwner: HWnd read FWnd write FWnd;
{* Owner window. If you want to provide your dialog visible over stay-on-top
form, fire it as a child of the form, assigning the handle of form window
to this property first. }
property DialogWnd: HWnd read FDialogWnd;
{* Handle to the open directory dialog itself, become available on the
first call of callback procedure (i.e. on the first call to OnSelChanged).
}
end;
//[END OF TOpenDirDialog DEFINITION]
{$endif wince}
//[NewOpenSaveDialog DECLARATION]
function NewOpenDirDialog( const Title: KOLString; Options: TOpenDirOptions ):
POpenDirDialog;
{* Creates object, which can be used (several times) to open directory
selecting dialog (using SHBrowseForFolder API call). }
//[Color Dialog Object]
type
TColorCustomOption = ( ccoFullOpen, ccoShortOpen, ccoPreventFullOpen );
type TKOLOpenDirDialog = POpenDirDialog;
{++}(*TColorDialog = class;*){--}
PColorDialog = {-}^{+}TColorDialog;
{ ----------------------------------------------------------------------
TColorDialog
----------------------------------------------------------------------- }
//[TColorDialog DEFINITION]
TColorDialog = object( TObj )
{* Color choosing dialog. }
protected
public
OwnerWindow: HWnd;
{* Owner window (can be 0). }
CustomColors: array[ 1..16 ] of TColor;
{* Array of stored custom colors. }
ColorCustomOption: TColorCustomOption;
{* Options (how to open a dialog). }
Color: TColor;
{* Returned color (if the result of Execute is True). }
function Execute: Boolean;
{* Call this method to open a dialog and wait its result. }
end;
//[END OF TColorDialog DEFINITION]
//[NewColorDialog DECLARATION]
function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog;
{* Creates color choosing dialog object. }
{$ENDIF WIN_GDI}
{$IFDEF WIN_GDI}
//[Ini files]
type
TIniFileMode = ( ifmRead, ifmWrite );
{* ifmRead is default mode (means "read" data from ini-file.
Set mode to ifmWrite to write data to ini-file, correspondent to
TIniFile. }
{$ifdef wince}
{$define read_interface}
{$I KOLCE_IniFile.inc}
{$undef read_interface}
{$else}
{++}(*TIniFile = class;*){--}
PIniFile = {-}^{+}TIniFile;
{ ----------------------------------------------------------------------
TIniFile - store/load data to ini-files
----------------------------------------------------------------------- }
//[TIniFile DEFINITION]
TIniFile = object( TObj )
{* Ini file incapsulation. The main feature is what the same block of
read-write operations could be defined (difference must be only in
Mode value).
|*Ini file sample.
This sample shows how the same Pascal operators can be used both
for read and write for the same variables, when working with TIniFile:
! procedure ReadWriteIni( Write: Boolean );
! var Ini: PIniFile;
! begin
! Ini := OpenIniFile( 'MyIniFile.ini' );
! Ini.Section := 'Main';
! if Write then // if Write, the same operators will save
! Ini.Mode := ifmWrite; // data rather then load.
! MyForm.Left := Ini.ValueInteger( 'Left', MyForm.Left );
! MyForm.Top := Ini.ValueInteger( 'Top', MyForm.Top );
! Ini.Free;
! end;
!
|* }
protected
fMode: TIniFileMode;
fFileName: KOLString;
fSection: KOLString;
protected
public
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* destructor }
property Mode: TIniFileMode read fMode write fMode;
{* ifmWrite, if write data to ini-file rather than read it. }
property FileName: KOLString read fFileName;
{* Ini file name. }
property Section: KOLString read fSection write fSection;
{* Current ini section. }
function ValueInteger( const Key: KOLString; Value: Integer ): Integer;
{* Reads or writes integer data value. }
function ValueString( const Key: KOLString; const Value: KOLString ): KOLString;
{* Reads or writes string data value. }
function ValueBoolean( const Key: KOLString; Value: Boolean ): Boolean;
{* Reads or writes boolean data value. }
function ValueData( const Key: KOLString; Value: Pointer; Count: Integer ): Boolean;
{* Reads or writes data from/to buffer. Returns True, if success. }
procedure ClearAll;
{* Clears all sections of ini-file. }
procedure ClearSection;
{* Clears current Section of ini-file. }
procedure ClearKey( const Key: KOLString );
{* Clears given key in current section. }
/////////////// + by Vyacheslav A. Gavrik:
{$IFDEF UNICODE_CTRLS}
procedure GetSectionNames(Names:PWStrList);
{$ELSE}
procedure GetSectionNames(Names:PStrList);
{$ENDIF}
{* Retrieves section names, storing it in string list passed as a parameter.
String list does not cleared before processing. Section names are added
to the end of the string list. }
{$IFDEF UNICODE_CTRLS}
procedure SectionData(Names:PWStrList);
{$ELSE}
procedure SectionData(Names:PStrList);
{$ENDIF}
{* Read/write current section content to/from string list. (Depending on
current Mode value). }
///////////////
end;
//[END OF TIniFile DEFINITION]
{$endif wince}
//[OpenIniFile DECLARATION]
function OpenIniFile( const FileName: KOLString ): PIniFile;
{* Opens ini file, creating TIniFile object instance to work with it. }
{$ENDIF WIN_GDI}
//[MENU OBJECT]
{$ifdef win32}
{$ifndef FPC}
type
TMenuitemInfo = {$ifndef wince}packed{$endif} record
cbSize: UINT;
fMask: UINT;
fType: UINT; { used if MIIM_TYPE}
fState: UINT; { used if MIIM_STATE}
wID: UINT; { used if MIIM_ID}
hSubMenu: HMENU; { used if MIIM_SUBMENU}
hbmpChecked: HBITMAP; { used if MIIM_CHECKMARKS}
hbmpUnchecked: HBITMAP; { used if MIIM_CHECKMARKS}
dwItemData: DWORD; { used if MIIM_DATA}
dwTypeData: PKOLChar; { used if MIIM_TYPE}
cch: UINT; { used if MIIM_TYPE}
hbmpItem: HBITMAP; { used if MIIM_BITMAP - not exists under Windows95 }
end;
{$endif FPC}
{$endif win32}
const
TPM_HORPOSANIMATION = $0400;
TPM_HORNEGANIMATION = $0800;
TPM_VERPOSANIMATION = $1000;
TPM_VERNEGANIMATION = $2000;
TPM_NOANIMATION = $4000;
type
{++}(*TMenu = class;*){--}
PMenu = {-}^{+}TMenu;
TOnMenuItem = procedure( Sender : PMenu; Item : Integer ) of object;
{* Event type to define OnMenuItem event. }
TMenuAccelerator = {$ifndef wince}packed{$endif} Record
{* Menu accelerator record. Use MakeAccelerator function to combine desired
attributes into a record, describing the accelerator. }
fVirt: Byte; // or-combination of FSHIFT, FCONTROL, FALT, FVIRTKEY, FNOINVERT
Key: Word; // character or virtual key code (FVIRTKEY flag is present above)
NotUsed: Byte; // not used
end;
// by Sergey Shisminzev:
TMenuOption = (moDefault, moDisabled, moChecked,
moCheckMark, moRadioMark, moSeparator, moBitmap, moSubMenu,
moBreak, moBarBreak);
{* Options to add menu items dynamically. }
TMenuOptions = set of TMenuOption;
{* Set of options for menu item to use it in TMenu.AddItem method. }
TMenuBreak = ( mbrNone, mbrBreak, mbrBarBreak );
{* Possible menu item break types. }
{ ----------------------------------------------------------------------
TMenu - main, popup menu and menu item
----------------------------------------------------------------------- }
//[TMenu DEFINITION]
TMenu = object( TObj )
protected
{$IFDEF GDI}
function GetItemHelpContext(Idx: Integer): Integer;
procedure SetItemHelpContext(Idx: Integer; const Value: Integer);
{* Dynamic menu incapsulation object. Can play role of form main menu or popup
menu, depending on kind of parent window (form or control) and order of
creation (created first (for a form) become main menu). Does not allow
merging menus, but items can be hidden. Additionally checkmark bitmaps,
shortcut key accelerators and other features are available. }
protected
FHandle: HMenu;
FId: Integer;
FControl: PControl;
{$ENDIF GDI}
fNextMenu : PMenu;
{$IFDEF GDI}
FMenuBreak: TMenuBreak;
FOnMenuItem : TOnMenuItem;
FOnRadioOff : TOnMenuItem;
fOnPopup: TOnEvent;
fByAccel: Boolean;
FPopupFlags: DWORD;
//fAutoPopup: Boolean;
FSavedState: DWORD;
FData: Pointer;
FOwnerDraw: Boolean;
{$ENDIF GDI}
FParentMenu: PMenu;
FItems: PList;
FRadioGroup: Integer;
FIsCheckItem: Boolean;
FIsSeparator: Boolean;
FVisible: Boolean;
FCaption: KOLString;
{$IFDEF _X_}
{$IFDEF GTK}
fChecked: Boolean;
fMnemonics: String;
fGtkMenuItem: PGtkWidget;
fGtkMenuShell: PGtkWidget;
fGtkMenuBar: PGtkWidget;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
FBitmap: HBitmap;
FBmpChecked: HBitmap;
FBmpItem: HBitmap;
ClearBitmapsProc: procedure( Sender: PMenu );
FClearBitmaps: Boolean;
FNotPopup: Boolean;
FAccelerator: TMenuAccelerator;
FHelpContext: Integer;
FOnMeasureItem: TOnMeasureItem;
FOnDrawItem: TOnDrawItem;
{$IFDEF USE_MENU_CURCTL}
fCurCtl: PControl;
{$ENDIF USE_MENU_CURCTL}
function GetItems( Id: HMenu ): PMenu;
function GetCount: Integer;
function GetTopParent: PMenu;
function GetState( const Index: Integer ): Boolean;
procedure SetState( const Index: Integer; Value: Boolean );
procedure SetVisible( Value: Boolean );
procedure SetData( Value: Pointer );
procedure SetMenuItemCaption( const Value: KOLString );
function FillMenuItems(AHandle: HMenu; StartIdx: Integer;
const Template: array of PKOLChar): Integer;
procedure SetMenuBreak( Value: TMenuBreak );
function GetControl: PControl;
function GetInfo( var MII: TMenuItemInfo ): Boolean;
function SetInfo( var MII: TMenuItemInfo ): Boolean;
function SetTypeInfo( var MII: TMenuItemInfo ): Boolean;
procedure SetBitmap( Value: HBitmap );
procedure SetBmpChecked( Value: HBitmap );
procedure SetBmpItem( Value: HBitmap );
procedure ClearBitmaps;
procedure SetAccelerator( const Value: TMenuAccelerator );
{$IFDEF GDI}
procedure SetHelpContext( Value: Integer );
{$ENDIF GDI}
procedure SetSubmenu( Value: HMenu );
procedure SetOnMeasureItem( const Value: TOnMeasureItem );
procedure SetOnDrawItem( const Value: TOnDrawItem );
procedure SetOwnerDraw( Value: Boolean );
protected
function GetItemChecked( Item : Integer ) : Boolean;
procedure SetItemChecked( Item : Integer; Value : Boolean );
function GetItemBitmap(Idx: Integer): HBitmap;
procedure SetItemBitmap(Idx: Integer; const Value: HBitmap);
function GetItemText(Idx: Integer): KOLString;
procedure SetItemText(Idx: Integer; const Value: KOLString);
function GetItemEnabled(Idx: Integer): Boolean;
procedure SetItemEnabled(Idx: Integer; const Value: Boolean);
function GetItemVisible(Idx: Integer): Boolean;
procedure SetItemVisible(Idx: Integer; const Value: Boolean);
function GetItemAccelerator(Idx: Integer): TMenuAccelerator;
procedure SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator);
function GetItemSubMenu( Idx: Integer ): HMenu;
{$ENDIF GDI}
{$ifdef wince}
procedure ReCreate;
procedure SaveState;
{$endif wince}
public
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
{* To release menu dynamically, call Free method instead. All (popup)
menus created after this (for the same control) are destroyed in
that case too.
|
It is not necessary to release menu object manually: all menus,
created with given form (or control), are automatically released,
when owner form (or control) is destroyed.
}
{$IFDEF GDI}
property Handle : HMenu read FHandle;
{* Handle of Windows menu object. }
property MenuId: Integer read FId;
{* Id of the menu item object. If menu item has subitems, it has
also submenu Handle. Top parent menu object itself has no Id.
Id-s areassigned automatically starting from 4096. Do not
(re)create menu items instantly, because such values are not
reused, and maximum possible Id value must not exceed 65535. }
property Parent: PMenu read FParentMenu;
{* Parent menu item (or parent menu). }
property TopParent: PMenu read GetTopParent;
{* Top parent menu, owning all nested subitems. }
property Owner: PControl read GetControl;
{* Parent control or form. }
property Caption: KOLString read FCaption write SetMenuItemCaption;
{* Menu item caption text (including '&' indicating mnemonic characters,
and keyboard accelerator representation string, usually following
tabulation character). }
property Items[ Id: HMenu ]: PMenu read GetItems;
{* Returns menu item object by its index or by menu id. Since menu id
values are starting from 4096, values from 0 to 4095 are interpreted
as absolute index of menu item. Be careful accessing menu items or
submenus by index, if you dynamically insert or delete items or
submenus. In this version, separators are enumerating too, like
all other items. Use index -1 to access object itself. The first
item of a menu (or the first subitem of submenu item) has index 0.
Children are enumerating before all siblings. The maximum available
index is (Count - 1), when accessing menu items by index. }
property Count: Integer read GetCount;
{* Count of items together with all its nested subitems. }
function IndexOf( Item: PMenu ): Integer;
{* Returns index of an item. This index can be used to access
menu item. Value -2 is returned, if the Item is not a child for menu
or menu item, and has no parents, which are children for it, etc.
Menu object itself always has index -1. }
property OnMenuItem : TOnMenuItem read FOnMenuItem write FOnMenuItem;
{* Is called when menu item is clicked. Absolute index of menu item
clicked is passed as the second parameter. TopParent always is
passed as a Sender parameter. }
property ByAccel: Boolean read fByAccel;
{* True, when OnMenuItem is called not by mouse, but by accelerator key.
Check this flag for entire menu (TopParent), not for item itself.
(Note, that Sender in OnMenuItem always is TopParent menu object). )
}
property IsSeparator: Boolean read FIsSeparator;
{* TRUE, if a separator menu item. }
property MenuBreak: TMenuBreak read FMenuBreak write SetMenuBreak;
{* Menu item break type. }
property OnUncheckRadioItem : TOnMenuItem read FOnRadioOff write FOnRadioOff;
{* Is called when radio item becomes unchecked in menu in result of
checking another radio item of the same radio group. }
property RadioGroup: Integer read FRadioGroup write FRadioGroup;
{* Radio group index. Several neighbour items with the same radio group
index form radio group. Only single item from the same group can be
checked at a time. }
property IsCheckItem: Boolean read FIsCheckItem;
{* If menu item is defined as check item, it is checked automatically
when clicked. }
procedure RadioCheckItem;
{* Call this method to check radio item. (Calling this method for
an item, which is not belonging to a radio group, just sets its
Checked state to TRUE). }
property Checked: Boolean index MFS_CHECKED read GetState write SetState;
{* Checked state of the item. }
property Enabled: Boolean
{$IFDEF F_P}
index $80000000 or MFS_DISABLED
{$ELSE DELPHI}
index Integer( $80000000 or MFS_DISABLED )
{$ENDIF F_P/DELPHI}
read GetState write SetState;
{* Enabled state of the item. Whaen assigned, Grayed state also is
set to arbitrary value (i.e., when Enabled is set to true, Grayed
is set to FALSE. }
property DefaultItem: Boolean index MFS_DEFAULT read GetState write SetState;
{* Set this property to TRUE to make menu item default. Default item
is drawn with bold.
|
If you change DefaultItem at run-time and whant
to provide changing its visual state, recreate the item first resetting
Visible property, then setting it again. }
property Highlight: Boolean index MFS_HILITE read GetState write SetState;
{* Highlight state of the item. }
property Visible: Boolean read FVisible write SetVisible;
{* Visibility of menu item. }
property Data: Pointer read FData write SetData;
{* Data pointer, associated with the menu item. }
property Bitmap: HBitmap read FBitmap write SetBitmap;
{* Bitmap used for unchecked state of the menu item. }
property BitmapChecked: HBitmap read FBmpChecked write SetBmpChecked;
{* Bitmap used for checked state of the menu item. }
property BitmapItem: HBitmap read FBmpItem write SetBmpItem;
{* Bitmap used for item itself. In addition, following special values
are possible:
HBMMENU_CALLBACK, HBMMENU_MBAR_CLOSE, HBMMENU_MBAR_CLOSE_D,
HBMMENU_MBAR_MINIMIZE, HBMMENU_MBAR_MINIMIZE_D, HBMMENU_MBAR_RESTORE,
HBMMENU_POPUP_CLOSE, HBMMENU_POPUP_MAXIMIZE, HBMMENU_POPUP_MINIMIZE,
HBMMENU_POPUP_RESTORE, HBMMENU_SYSTEM. }
property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator;
{* Accelerator for menu item. }
{$IFDEF GDI}
property HelpContext: Integer read FHelpContext write SetHelpContext;
{* Help context for entire menu (help context can not be assigned to
individual menu items). }
{$ENDIF GDI}
procedure AssignEvents( StartIdx: Integer; const Events: array of TOnMenuItem );
{* It is possible to assign its own event handler to every menu item
using this call. This procedure also is called automatically in
a constructor NewMenuEx. }
function Popup( X, Y : Integer ): Integer; {!ecm}
{* Only for popup menu - to popup it at the given position on screen.
Return: If you specify TPM_RETURNCMD in the uFlags parameter, the return
value is the menu-item identifier of the item that the user selected.
If the user cancels the menu without making a selection, or if an error
occurs, then the return value is zero.
If you do not specify TPM_RETURNCMD in the uFlags parameter, the return
value is nonzero if the function succeeds and zero if it fails. }
function PopupEx( X, Y: Integer ): Integer; {!ecm}
{* This version of popup command is very useful, when popup menu is activated
when its parent window is not visible (e.g., for a kind of applications,
which always are invisible, and can be activated only using tray icon).
PopupEx method provides correct tracking of menu disappearing when mouse
is clicked anywhere else on screen, fixing strange menu behavior in some
Windows versions (NT).
|
Actually, when PopupEx used, parent form is shown but below of visible
screen, and when menu is disappearing, previous state of the form (visibility
and position) are restored. If such solvation is not satisfying You,
You can do something else (e.g., use region clipping, etc.) }
property OnPopup: TOnEvent read fOnPopup write fOnPopup;
{* This event occurs before the popup menu is shown. }
property NotPopup: Boolean read FNotPopup write FNotPopup;
{* Set this property to true to prevent popup of popup menu, e.g. in
OnPopup event handler. }
property Flags: DWORD read FPopupFlags write FPopupFlags;
{* Pop-up flags, which are used to call TrackPopupMenuEx, when Popup or
PopupEx method is called. Can be a combination of following values:
|
TPM_CENTERALIGN or TPM_LEFTALIGN or TPM_RIGHTALIGN
|
TPM_BOTTOMALIGN or TPM_TOPALIGN or TPM_VCENTERALIGN
|
TPM_NONOTIFY or TPM_RETURNCMD
|
TPM_LEFTBUTTON or TPM_RIGHTBUTTON
|
TPM_HORNEGANIMATION or TPM_HORPOSANIMATION or TPM_NOANIMATION or
TPM_VERNEGANIMATION or TPM_VERPOSANIMATION
|
TPM_HORIZONTAL or TPM_VERTICAL.
|
By default, a combination TPM_LEFTALIGN or TPM_LEFTBUTTON is used. }
function Insert(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem;
Options: TMenuOptions): PMenu;
{* Inserts new menu item before item, given by Id (>=4096) or index
value InsertBefore. Pointer to an object created is returned. }
property SubMenu: HMenu read FHandle; // write SetSubMenu;
{* Submenu associated with the menu item. The same as Handle. It was possible
in ealier versions to change this value, replacing (removing, assigning)
entire popup menu as a submenu for menu item.
But in modern version of TMenu, this is not possible.
Instead, entire menu object should be added or removed using
InsertSubmenu or RemoveSubmenu methods. }
procedure InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer );
{* Inserts existing menu item (together with its subitems if any present)
into given position. See also RemoveSubMenu. }
function RemoveSubMenu( ItemToRemove: Integer ): PMenu;
{* Removes menu item from the menu, returning TMenu object, representing it,
if submenu item, having its own children, detached. If an individual menu
item is removed, nil is returned.
This function can be useful to add or remove dynamically entire submenus
(created together with its subitems). }
property OnMeasureItem: TOnMeasureItem read FOnMeasureItem write SetOnMeasureItem;
{* This event is called for owner-drawn menu items. Event handler should return
menu item height in lower word of a result and item width (for menu) in
high word of result. If either for height or for width returned value is 0,
a default one is used. }
property OnDrawItem: TOnDrawItem read FOnDrawItem write SetOnDrawItem;
{* This event is called for owner-drawn menu items. }
property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw;
{* Set this property to true for some items to make it owner-draw. }
// For compatibility with old code (be sure that item with given index
// actually exists):
function GetMenuItemHandle( Idx : Integer ): DWORD;
{* Returns Id of menu item with given index. }
property ItemHandle[ Idx: Integer ]: DWORD read GetMenuItemHandle;
{* Returns handle for item given by index. }
property ItemChecked[ Idx : Integer ] : Boolean read GetItemChecked write SetItemChecked;
{* True, if correspondent menu item is checked. }
procedure RadioCheck( Idx : Integer );
{* Call this method to check radio item. For radio items, do not
use assignment to ItemChecked or Checked properties. }
property ItemBitmap[ Idx: Integer ]: HBitmap read GetItemBitmap write SetItemBitmap;
{* This property allows to assign bitmap to menu item (for unchecked state
only - for checked menu items default checkmark bitmap is used). }
procedure AssignBitmaps( StartIdx: Integer; Bitmaps: array of HBitmap );
{* Can be used to assign bitmaps to several menu items during one call. }
property ItemText[ Idx: Integer ]: KOLString read GetItemText write SetItemText;
{* This property allows to get / modify menu item text at run time. }
property ItemEnabled[ Idx: Integer ]: Boolean read GetItemEnabled write SetItemEnabled;
{* Controls enabling / disabling menu items. Disabled menu items are
displayed (grayed) but inaccessible to click. }
property ItemVisible[ Idx: Integer ]: Boolean read GetItemVisible write SetItemVisible;
{* This property allows to simulate visibility of menu items (implementing
it by removing or inserting again if needed. For items of submenu, which
is made invisible, True is returned. If such item made Visible, entire
submenu with all its parent menu items becomes visible. To release menu
properly it is necessary to make before all its items visible again.
This does not matter, if menu is released at the end of execution, but
can be sensible if owner form is destroyed and re-created at run time
dynamically. }
property ItemHelpContext[ Idx: Integer ]: Integer read GetItemHelpContext
write SetItemHelpContext;
function ParentItem( Idx: Integer ): Integer;
{* Returns index of parent menu item (for submenu item). If there are no
such item (Idx corresponds to root level menu item), -1 is returned. }
property ItemAccelerator[ Idx: Integer ]: TMenuAccelerator read GetItemAccelerator write SetItemAccelerator;
{* Allows to get / change accelerator key kodes assigned to menu items.
Has no effect unless SupportMnemonics called for a form. }
property ItemSubmenu[ Idx: Integer ]: HMenu read GetItemSubmenu; // write SetItemSubmenu;
{* Retrieves submenu item dynamically. See also SubMenu property. }
// by Sergey Shisminzev:
function AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;
{* Adds menu item dynamically. Returns ID of the added item. }
function InsertItem(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;
{* Inserts menu item before an item with ID, given by InsertBefore parameter. }
function InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions;
ByPosition: Boolean): Integer;
{* Inserts menu item by command or by position, dependant on ByPosition parameter }
procedure RedrawFormMenuBar;
{* }
{$IFDEF USE_MENU_CURCTL}
property CurCtl: PControl read fCurCtl write fCurCtl;
{* By Alexander Pravdin. This property is assigned to a control which were
initiated a pop-up, for popup menu. }
{$ENDIF USE_MENU_CURCTL}
{$ENDIF GDI}
end;
//[END OF TMenu DEFINITION]
{$IFDEF WIN_GDI}
//[MenuStructSize VARIABLE]
function MenuStructSize: Integer;
{* Returns 44 under Windows95, and 48 (=sizeof(TMenuItemInfo) under all other
Windows versions. }
var FDynamicMenuID: DWORD = $1000;
{$ENDIF WIN_GDI}
//[NewMenu DECLARATION]
function NewMenu( AParent : PControl; MaxCmdReserve: DWORD;
const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu;
{* Menu constructor. First created menu becomes main menu of form (if AParent
is a form). All other menus becomes popup (can be activated using Popup
method). To provide dynamic replacing of main menu, create all popup
menus as children of any other control, not form itself.
When Menu is created, pass FirstCmd integer value to set it
as ID of first menu item (all other ID's obtained by incrementing this value),
and Template, which is an array of PChar (usually array of string constants),
containing list of menu item identifiers and/or formatting characters.
|
FirstCmd value is assigned to first menu item created as its ID,
all follow menu items are assigned to ID's obtained from FirstCmd incrementing
it by 1. It is desirable to provide not intersected ranges of ID's for
defferent menus in the applet.
|
Following formatting characters can be used in menu template strings:
|&L=
%1
- to underline next character and use it as a shortcut character
when possible;
- to make item checked. If also
|! is used before
&
| than radioitem is defined;
- item not checked;
- separator (between two items);
- start of submenu;
- end of submenu;
|
To get access to menu items, use constants 0, 1, etc. It is a good idea
to create special enumerated type to index correspondent menu items
using Ord( ) operator. Note in that case, that it is necessary only to
define constants correspondent to identifiers (positions, correspondent
to separators or submenu brackets are not identified by numbers).
|
}
function NewMenuEx( AParent : PControl; FirstCmd : Integer;
const Template : array of PKOLChar; aOnMenuItems: array of TOnMenuItem ): PMenu;
{* Creates menu, assigning its own event handler for every (enough) menu item. }
{$IFDEF WIN_GDI}
//[MakeAccelerator DECLARATION]
function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;
{* Creates accelerator item to assign it to TMenu.ItemAccelerator[ ] property
easy.}
//[GetAcceleratorText DECLARATION]
// {YS} added 7 Aug 2004
function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLstring;
{* Returns text representation of accelerator.
|
}
//[Window FUNCTIONS DECLARATIONS]
type
TWindowChildKind = ( wcActive, wcFocus, wcCapture, wcMenuOwner,
wcMoveSize, wcCaret );
{* Type of window child kind. Used in function GetWindowChild. }
function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd;
{* Returns child of given top-level window, having given characteristics.
For example, it is possible to get know for foreground window,
which of its child window has focus. This function does not work in old
Windows 95 (returns Wnd in that case). But for Windows 98, Windows NT/2000
this function works fine. To obtain focused child of the window,
use GetFocusedWindow, which is independant from Windows version. }
{$ifdef win32}
function GetFocusedChild( Wnd: HWnd ): HWnd;
{* Returns focused child of given window (which should be foreground
and active, certainly). 0 is returned either if Wnd is not active
or Wnd has no focused child window. }
function Stroke2Window( Wnd: HWnd; const S: String ): Boolean;
{* Posts characters from string S to those child window of Wnd, which
has focus now (top-level window Wnd must be foreground, and have
focused edit-aware control to receive the stroke).
|
This function allows only to post typeable characters (including
such special symbols as #13 (Enter), #9 (Tab), #8 (BackSpace), etc.
|
See also function Stroke2WindowEx, which allows to post any key down
and up events, simulating keyboard for given (automated) application. }
function Stroke2WindowEx( Wnd: HWnd; const S: String; Wait: Boolean ): Boolean;
{* In addition to function Stroke2Window, this one can send special keys
to given window, including functional keys and navigation keys. To
post special key to target window, place a combination of names of
such key together with keys, which should be passed simultaneously,
between square or figure brackets. For example, [Ctrl F1], [Alt Shift Home],
[Ctrl E]. For letters and usual characters, it is not necessary to
simulate pressing it with determining all Shift combinations and it is
sufficient to pass characters as is. (E.g., not '[Shift 1]', but '!'). }
{$endif win32}
function FindWindowByThreadID( ThreadID : DWORD ) : HWnd;
{* Searches for window, belonging to a given thread. }
function DesktopPixelFormat: TPixelFormat;
{* Returns the pixel format correspondent to current desktop color resolution.
Use this function to decide which format to use for converting bitmap,
planned to draw transparently using TBitmap.DrawTransparent or
TBitmap.StretchDrawTransparent methods. }
function GetDesktopRect : TRect;
{* Returns rectangle of screen, free of taskbar and other
similar app-bars, which reduces size of available desktop
when created. }
function GetWorkArea: TRect;
{* The same as GetDesktopRect, but obtained calling SystemParametersInfo. }
function ExecuteWait( const AppPath, CmdLine, DfltDirectory: KOLString;
Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean;
{* Allows to execute an application and wait when it is finished. Pass
INFINITE constant as TimeOut, if You sure that application is finished
anyway. If another value passed as a TimeOut (in milliseconds), and
application was not finished for that time, ExecuteWait is returning
FALSE, and if ProcID is not nil, than ProcID^ contains started process
handle (it can be used to wait it more, or to terminate it using
TerminateProcess API function).
|
Launching application can be console or GUI - it does not matter.
Pass SW_SHOW, SW_HIDE or other SW_XXX constant as Show parameter
as appropriate.
|
True is returned only in case when application specified was launched
successfully and finished for TimeOut specified. Otherwise, check
ProcID^ variable: if it is 0, process could not be launched (and it
is possible to get information about error using GetLastError API
function in a such case). You can freely pass nil in place of ProcID
parameter, but this is acually correct only when TimeOut is INFINITE. }
{$ifdef win32}
function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString;
Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean;
{* Executes an application with its console input and output redirection.
Terminating of the application is not waiting, but if ProcID pointer
is defined, it receives process Id launched, so it is possible to
call WaitForSingleObject for it. InPipe is a pointer to THandle variable
which receives a handle to input pipe of the console redirected. The same
is for OutPipeWr and OutPipeRd, but for output of the console redirected.
Before reading from OutPipeRd^, first close OutPipeWr^. If you run
simple console application, for which you want to read results after its
termination, you can use ExecuteConsoleAppIORedirect instead.
|
Notes: if your application is not console and it does not create console
using AllocConsole, this function will fail to redirect input-output. }
function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: String;
Show: DWORD; const InStr: String; var OutStr: String; WaitTimeout: DWORD )
: Boolean;
{* Executes an application, redirecting its console input and output.
After redirecting input and output and launching the application,
content of InStr is written to input stream of the application, then
the application is waiting for its termination (WaitTimeout milliseconds
or INFINITE, as passed) and console output of the application is read to
OutStr. TRUE is returned only in case, when all these tasks are
completed successfully.
|
Notes: if your application is not console and it does not create console
using AllocConsole, this function will fail to redirect input-output. }
function WindowsShutdown( const Machine : KOLString; Force, Reboot : Boolean ) : Boolean;
{* Shut down of Windows NT. Pass Machine = '' to shutdown this PC.
Pass Reboot = True to reboot immediatelly after shut down. }
{$endif win32}
type
TWindowsVersion = ( wv31, wv95, wv98, wvME, wvNT, wvY2K, wvXP, wvServer2003,
wvVista, wvCE );
{* Windows versions constants. }
TWindowsVersions = Set of TWindowsVersion;
{* Set of Windows version (e.g. to define a range of versions supported by the
application). }
function WinVer : TWindowsVersion;
{* Returns Windows version. }
function IsWinVer( Ver : TWindowsVersions ) : Boolean;
{* Returns True if Windows version is in given range of values. }
//[Parameters FUNCTIONS DECLARATIONS]
function ParamStr( Idx: Integer ): KOLString;
{* Returns command-line parameter by index. This function supersides
standard ParamStr function. }
function ParamCount: Integer;
{* Returns number of parameters in command line.
|
}
{$ifdef wince}
type
TCePlatform = (cpWinCE, cpPocketPC, cpSmartphone);
{*
Windows CE platfrom constants.
}
function CePlatform: TCePlatform;
{* Returns Windows CE platfrom. }
procedure CeFormSIPAware(Form: PControl; ShowSIP: boolean);
{* Call this procedure to resize form when SIP is activated
|
}
{$endif wince}
{$ENDIF WIN_GDI}
{$IFDEF INPACKAGE}
{$IFDEF ASM_VERSION}
{$UNDEF ASM_VERSION}
{$ENDIF}
{$ENDIF}
{$IFDEF WIN_GDI}
//{$DEFINE CHK_BITBLT}
procedure Chk_BitBlt;
{$IFDEF ASM_VERSION}
{$DEFINE ASM_DC}
{$ENDIF}
{$IFDEF ASM_DC}
procedure StartDC;
procedure FinishDC;
{$ENDIF ASM_VERSION}
//[WndProcXXX OTHER DECLARATIONS]
function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var CreatingWindow: PControl;
//ActiveWindow: HWnd;
{$ENDIF WIN_GDI}
//[Assert OPERATOR DECLARATION]
{-}
{$IFDEF _D2}
// Assert operator was not available in Delphi2. Provide here easy Assert
// procedure for Delphi2.
procedure Assert( Cond: Boolean; const Msg: String );
var AssertErrorProc: procedure( const Message, Filename: AnsiString; LineNumber: Integer );
{$ENDIF}
{+}
//[CUSTOM EXTENSIONS]
{$IFDEF USE_CUSTOMEXTENSIONS}
{$I CUSTOM_KOL_EXTENSION.inc} // See comments in TControl
{$ENDIF}
{$IFDEF DEBUG_ENDSESSION}
var EndSession_Initiated: Boolean;
{$ENDIF}
{$IFDEF WIN_GDI}
//[FMMNotify VARIABLE]
var
FMMNotify: procedure( var Msg: TMsg );
//[procedure ClearText forward declaration]
procedure ClearText( Sender: PControl );
//[procedure ClearListbox forward declaration]
procedure ClearListbox( Sender: PControl );
//[procedure ClearCombobox forward declaration]
procedure ClearCombobox( Sender: PControl );
//[procedure ClearListView forward declaration]
procedure ClearListView( Sender: PControl );
//[procedure ClearTreeView forward declaration]
procedure ClearTreeView( TV: PControl );
//[START OF ACTIONS]
const
ButtonActions: TCommandActions = (
aClear: ClearText;
aAddText: nil;
aClick: BN_CLICKED;
aEnter: BN_SETFOCUS;
aLeave: BN_KILLFOCUS;
aChange: 0; //BN_CLICKED;
aSelChange: 0;
aGetCount: 0;
aSetCount: 0;
aGetItemLength: 0;
aGetItemText: 0;
aSetItemText: 0;
aGetItemData: 0;
aSetItemData: 0;
aAddItem: 0;
aDeleteItem: 0;
aInsertItem: 0;
aFindItem: 0;
aFindPartial: 0;
aItem2Pos: 0;
aPos2Item: 0;
//aGetSelStart: 0;
aGetSelCount: 0;
aGetSelected: 0;
aGetSelRange: 0;
//aExGetSelRange: 0;
aGetCurrent: 0;
aSetSelected: 0;
aSetCurrent: 0;
aSetSelRange: 0;
aExSetSelRange: 0;
aGetSelection: 0;
aReplaceSel: 0;
aTextAlignLeft: BS_LEFT;
aTextAlignRight: BS_RIGHT;
aTextAlignCenter: BS_CENTER;
aTextAlignMask: 0;
aVertAlignCenter: BS_VCENTER shr 8;
aVertAlignTop: BS_TOP shr 8;
aVertAlignBottom: BS_BOTTOM shr 8;
aDir: 0;
aSetLimit: 0;
aSetImgList: 0;
aAutoSzX: 14;
aAutoSzY: 6;
aSetBkColor: 0;
aItem2XY: 0;
);
const
LabelActions: TCommandActions = (
aClear: ClearText;
aAddText: nil;
aClick: 0;
aEnter: 0;
aLeave: 0;
aChange: 0;
aSelChange: 0;
aGetCount: 0;
aSetCount: 0;
aGetItemLength: 0;
aGetItemText: 0;
aSetItemText: 0;
aGetItemData: 0;
aSetItemData: 0;
aAddItem: 0;
aDeleteItem: 0;
aInsertItem: 0;
aFindItem: 0;
aFindPartial: 0;
aItem2Pos: 0;
aPos2Item: 0;
//aGetSelStart: 0;
aGetSelCount: 0;
aGetSelected: 0;
aGetSelRange: 0;
//aExGetSelRange: 0;
aGetCurrent: 0;
aSetSelected: 0;
aSetCurrent: 0;
aSetSelRange: 0;
aExSetSelRange: 0;
aGetSelection: 0;
aReplaceSel: 0;
aTextAlignLeft: SS_LEFT;
aTextAlignRight: SS_RIGHT;
aTextAlignCenter: SS_CENTER;
aTextAlignMask: SS_LEFTNOWORDWRAP;
aVertAlignCenter: SS_CENTERIMAGE shr 8;
aVertAlignTop: 0;
aVertAlignBottom: 0;
aDir: 0;
aSetLimit: 0;
aSetImgList: 0;
aAutoSzX: 1;
aAutoSzY: 1;
aSetBkColor: 0;
aItem2XY: 0;
);
const
EN_LINK = $070b;
EditActions: TCommandActions = (
aClear: ClearText;
aAddText: nil;
aClick: 0;
aEnter: EN_SETFOCUS;
aLeave: EN_KILLFOCUS;
aChange: EN_CHANGE;
aSelChange: 0;
aGetCount: EM_GETLINECOUNT;
aSetCount: 0;
aGetItemLength: EM_LINELENGTH;
aGetItemText: EM_GETLINE;
aSetItemText: EM_REPLACESEL;
aGetItemData: 0;
aSetItemData: 0;
aAddItem: 0;
aDeleteItem: 0;
aInsertItem: 0;
aFindItem: 0;
aFindPartial: 0;
aItem2Pos: EM_LINEINDEX;
aPos2Item: EM_LINEFROMCHAR;
//aGetSelStart: 0;
aGetSelCount: EM_GETSEL;
aGetSelected: 0;
aGetSelRange: EM_GETSEL;
//aExGetSelRange: 0;
aGetCurrent: EM_LINEINDEX;
aSetSelected: 0;
aSetCurrent: 0;
aSetSelRange: EM_SETSEL;
aExSetSelRange: 0;
aGetSelection: 0;
aReplaceSel: EM_REPLACESEL;
aTextAlignLeft: ES_LEFT;
aTextAlignRight: ES_RIGHT;
aTextAlignCenter: ES_CENTER;
aTextAlignMask: 0;
aVertAlignCenter: 0;
aVertAlignTop: 0;
aVertAlignBottom: 0;
aDir: 0;
aSetLimit: EM_SETLIMITTEXT;
aSetImgList: 0;
aAutoSzX: 0;
aAutoSzY: 6;
aSetBkColor: 0;
aItem2XY: EM_POSFROMCHAR;
);
const
ListActions: TCommandActions = (
aClear: ClearListbox;
aAddText: nil;
aClick: LBN_DBLCLK;
aEnter: LBN_SETFOCUS;
aLeave: LBN_KILLFOCUS;
aChange: 0;
aSelChange: LBN_SELCHANGE;
aGetCount: LB_GETCOUNT;
aSetCount: LB_SETCOUNT;
aGetItemLength: LB_GETTEXTLEN;
aGetItemText: LB_GETTEXT;
aSetItemText: 0;
aGetItemData: LB_GETITEMDATA;
aSetItemData: LB_SETITEMDATA;
aAddItem: LB_ADDSTRING;
aDeleteItem: LB_DELETESTRING;
aInsertItem: LB_INSERTSTRING;
aFindItem: LB_FINDSTRINGEXACT;
aFindPartial: LB_FINDSTRING;
aItem2Pos: 0;
aPos2Item: 0;
//aGetSelStart: 0;
aGetSelCount: LB_GETSELCOUNT;
aGetSelected: LB_GETSEL;
aGetSelRange: 0;
//aExGetSelRange: 0;
aGetCurrent: LB_GETCURSEL;
aSetSelected: LB_SETSEL;
aSetCurrent: LB_SETCURSEL;
aSetSelRange: 0;
aExSetSelRange: 0;
aGetSelection: 0;
aReplaceSel: 0;
aTextAlignLeft: 0;
aTextAlignRight: 0;
aTextAlignCenter: 0;
aTextAlignMask: 0;
aVertAlignCenter: 0;
aVertAlignTop: 0;
aVertAlignBottom: 0;
aDir: LB_DIR;
aSetLimit: 0;
aSetImgList: 0;
aAutoSzX: 0;
aAutoSzY: 0;
aSetBkColor: 0;
aItem2XY: LB_GETITEMRECT;
);
const
ComboActions: TCommandActions = (
aClear: ClearCombobox;
aAddText: nil;
aClick: CBN_DBLCLK;
aEnter: CBN_SETFOCUS;
aLeave: CBN_KILLFOCUS;
aChange: CBN_EDITCHANGE;
aSelChange: CM_CBN_SELCHANGE; // CBN_SELCHANGE;
aGetCount: CB_GETCOUNT;
aSetCount: 0;
aGetItemLength: CB_GETLBTEXTLEN;
aGetItemText: CB_GETLBTEXT;
aSetItemText: 0;
aGetItemData: CB_GETITEMDATA;
aSetItemData: CB_SETITEMDATA;
aAddItem: CB_ADDSTRING;
aDeleteItem: CB_DELETESTRING;
aInsertItem: CB_INSERTSTRING;
aFindItem: CB_FINDSTRINGEXACT;
aFindPartial: CB_FINDSTRING;
aItem2Pos: 0;
aPos2Item: 0;
//aGetSelStart: 0;
aGetSelCount: 0;
aGetSelected: CB_GETCURSEL;
aGetSelRange: 0;
//aExGetSelRange: 0;
aGetCurrent: CB_GETCURSEL;
aSetSelected: 0;
aSetCurrent: CB_SETCURSEL;
aSetSelRange: 0;
aExSetSelRange: 0;
aGetSelection: 0;
aReplaceSel: 0;
aTextAlignLeft: 0; //ES_LEFT;
aTextAlignRight: 0; //ES_RIGHT;
aTextAlignCenter: 0; //ES_CENTER;
aTextAlignMask: 0;
aVertAlignCenter: 0;
aVertAlignTop: 0;
aVertAlignBottom: 0;
aDir: CB_DIR;
aSetLimit: 0;
aSetImgList: 0;
aAutoSzX: 0;
aAutoSzY: 6;
aSetBkColor: 0;
aItem2XY: 0;
);
const
ListViewActions: TCommandActions = (
aClear: ClearListView;
aAddText: nil;
aClick: 0;
aEnter: 0;
aLeave: 0;
aChange: LVN_ITEMCHANGED;
aSelChange: 0;
aGetCount: LVM_GETITEMCOUNT;
aSetCount: LVM_SETITEMCOUNT;
aGetItemLength: 0;
aGetItemText: 0;
aSetItemText: 0;
aGetItemData: 0;
aSetItemData: 0;
aAddItem: 0;
aDeleteItem: 0;
aInsertItem: 0;
aFindItem: 0;
aFindPartial: 0;
aItem2Pos: 0;
aPos2Item: 0;
//aGetSelStart: LVM_GETSELECTIONMARK;
aGetSelCount: { $8000 or} LVM_GETSELECTEDCOUNT;
aGetSelected: LVM_GETITEMSTATE;
aGetSelRange: 0;
//aExGetSelRange: 0;
aGetCurrent: LVM_GETNEXTITEM;
aSetSelected: 0;
aSetCurrent: 0;
aSetSelRange: 0;
aExSetSelRange: 0;
aGetSelection: 0;
aReplaceSel: 0;
aTextAlignLeft: 0;
aTextAlignRight: 0;
aTextAlignCenter: 0;
aTextAlignMask: 0;
aVertAlignCenter: 0;
aVertAlignTop: 0;
aVertAlignBottom: 0;
aDir: 0;
aSetLimit: 0;
aSetImgList: LVM_SETIMAGELIST;
aAutoSzX: 0;
aAutoSzY: 0;
aSetBkColor: LVM_SETBKCOLOR;
aItem2XY: LVM_GETITEMRECT;
);
const
TreeViewActions: TCommandActions = (
aClear: ClearTreeView;
aAddText: nil;
aClick: 0;
aEnter: 0;
aLeave: 0;
aChange: TVN_ENDLABELEDIT;
aSelChange: TVN_SELCHANGED;
aGetCount: TVM_GETCOUNT;
aSetCount: 0;
aGetItemLength: 0;
aGetItemText: 0;
aSetItemText: 0;
aGetItemData: 0;
aSetItemData: 0;
aAddItem: 0;
aDeleteItem: 0;
aInsertItem: 0;
aFindItem: 0;
aFindPartial: 0;
aItem2Pos: 0;
aPos2Item: 0;
//aGetSelStart: 0;
aGetSelCount: 0;
aGetSelected: 0;
aGetSelRange: 0;
//aExGetSelRange: 0;
aGetCurrent: 0;
aSetSelected: 0;
aSetCurrent: 0;
aSetSelRange: 0;
aExSetSelRange: 0;
aGetSelection: 0;
aReplaceSel: 0;
aTextAlignLeft: 0;
aTextAlignRight: 0;
aTextAlignCenter: 0;
aTextAlignMask: 0;
aVertAlignCenter: 0;
aVertAlignTop: 0;
aVertAlignBottom: 0;
aDir: CB_DIR;
aSetLimit: 0;
aSetImgList: TVM_SETIMAGELIST;
aAutoSzX: 0;
aAutoSzY: 0;
aSetBkColor: {$ifdef wince}0{$else}TVM_SETBKCOLOR{$endif};
aItem2XY: TVM_GETITEMRECT;
);
const
TabControlActions: TCommandActions = (
aClear: ClearText;
aAddText: nil;
aClick: 0;
aEnter: 0;
aLeave: 0;
aChange: TCN_SELCHANGE;
aSelChange: TCN_SELCHANGE;
aGetCount: TCM_GETITEMCOUNT;
aSetCount: 0;
aGetItemLength: 0;
aGetItemText: 0;
aSetItemText: 0;
aGetItemData: 0;
aSetItemData: 0;
aAddItem: 0;
aDeleteItem: 0;
aInsertItem: 0;
aFindItem: 0;
aFindPartial: 0;
aItem2Pos: 0;
aPos2Item: 0;
//aGetSelStart: 0;
aGetSelCount: 0;
aGetSelected: 0;
aGetSelRange: 0;
//aExGetSelRange: 0;
aGetCurrent: TCM_GETCURSEL;
aSetSelected: 0;
aSetCurrent: TCM_SETCURSEL; //TCM_SETCURFOCUS;
aSetSelRange: 0;
aExSetSelRange: 0;
aGetSelection: 0;
aReplaceSel: 0;
aTextAlignLeft: 0;
aTextAlignRight: 0;
aTextAlignCenter: 0;
aTextAlignMask: 0;
aVertAlignCenter: 0;
aVertAlignTop: 0;
aVertAlignBottom: 0;
aDir: CB_DIR;
aSetLimit: 0;
aSetImgList: TCM_SETIMAGELIST;
aAutoSzX: 0;
aAutoSzY: 0;
aSetBkColor: 0;
aItem2XY: TCM_GETITEMRECT;
);
{$IFNDEF NOT_USE_RICHEDIT}
const
RichEditActions: TCommandActions = (
aClear: ClearText;
aAddText: nil;
aClick: 0;
aEnter: EN_SETFOCUS;
aLeave: EN_KILLFOCUS;
aChange: EN_CHANGE;
aSelChange: EN_SELCHANGE;
aGetCount: EM_GETLINECOUNT;
aSetCount: 0;
aGetItemLength: EM_LINELENGTH;
aGetItemText: EM_GETLINE;
aSetItemText: EM_REPLACESEL;
aGetItemData: 0;
aSetItemData: 0;
aAddItem: 0;
aDeleteItem: 0;
aInsertItem: 0;
aFindItem: 0;
aFindPartial: 0;
aItem2Pos: EM_LINEINDEX;
aPos2Item: EM_LINEFROMCHAR;
//aGetSelStart: 0;
aGetSelCount: EM_GETSEL;
aGetSelected: 0;
aGetSelRange: EM_GETSEL;
//aExGetSelRange: EM_EXGETSEL;
aGetCurrent: EM_LINEINDEX;
aSetSelected: 0;
aSetCurrent: 0;
aSetSelRange: 0;
aExSetSelRange: EM_EXSETSEL;
aGetSelection: EM_GETSELTEXT;
aReplaceSel: EM_REPLACESEL;
aTextAlignLeft: ES_LEFT;
aTextAlignRight: ES_RIGHT;
aTextAlignCenter: ES_CENTER;
aTextAlignMask: 0;
aVertAlignCenter: 0;
aVertAlignTop: 0;
aVertAlignBottom: 0;
aDir: 0;
aSetLimit: EM_EXLIMITTEXT;
aSetImgList: 0;
aAutoSzX: 0;
aAutoSzY: 0;
aSetBkColor: EM_SETBKGNDCOLOR;
aItem2XY: EM_POSFROMCHAR;
);
{$ENDIF NOT_USE_RICHEDIT}
const
BaseFileMethods: TStreamMethods = (
fSeek: SeekFileStream;
fGetSiz: GetSizeFileStream;
fSetSiz: DummySetSize;
fRead: DummyReadWrite;
fWrite: DummyReadWrite;
fClose: CloseFileStream;
fCustom: nil;
fWait: nil;
);
MemoryMethods: TStreamMethods = (
fSeek: SeekMemStream;
fGetSiz: GetSizeMemStream;
fSetSiz: SetSizeMemStream;
fRead: ReadMemStream;
fWrite: WriteMemStream;
fClose: CloseMemStream;
fCustom: nil;
fWait: nil;
);
{$ENDIF WIN_GDI}
{$IFDEF DEBUG_MCK}
procedure dummy_Log( const s: String );
var mck_Log: procedure( const s: String ) = dummy_Log;
{$ENDIF}
type
TThemedElement = (
teButton,
teClock,
teComboBox,
teEdit,
teExplorerBar,
teHeader,
teListView,
teMenu,
tePage,
teProgress,
teRebar,
teScrollBar,
teSpin,
teStartPanel,
teStatus,
teTab,
teTaskBand,
teTaskBar,
teToolBar,
teToolTip,
teTrackBar,
teTrayNotify,
teTreeview,
teWindow
);
var DrawThemeBackground: function(hTheme: DWORD; hdc: HDC; iPartId, iStateId: Integer;
const pRect: TRect; pClipRect: PRECT): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
OpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
ThemeLibrary: THandle;
IsThemeBackgroundPartiallyTransparent: function(hTheme: DWORD;
iPartId, iStateId: Integer): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
DrawThemeParentBackground: function(hwnd: HWND; hdc: HDC; prc: PRECT): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
CloseThemeData: function(hTheme: DWORD): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
DrawThemeText: function(hTheme: DWORD; hdc: HDC; iPartId, iStateId: Integer;
pszText: LPCWSTR; iCharCount: Integer; dwTextFlags, dwTextFlags2: DWORD;
const pRect: TRect): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
IsThemeActive: function: BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
IsAppThemed: function: BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
GetThemeColor: function(hTheme: DWORD; iPartId, iStateId, iPropId: Integer;
var pColor: COLORREF): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
const
themelib = 'uxtheme';
type
PThemedElementDetails = ^TThemedElementDetails;
TThemedElementDetails = record
Element: TThemedElement;
Part,
State: Integer;
end;
TThemedEdit = (
teEditDontCare,
teEditRoot,
teEditTextNormal, teEditTextHot, teEditTextSelected, teEditTextDisabled, teEditTextFocused, teEditTextReadOnly, teEditTextAssist,
teEditCaret
);
//[IMPLEMENTATION]
implementation
//[USES-2]
{uses
//ShellAPI,
//commdlg // removing reference to commdlg decreases executable about 0.5 K
; //, commctrl;
// in Delphi3, including of commctrl.pas increases executable
// onto about 30K. So, all needed definitions are copied here
// (see commctrl.inc).}
//[END OF USES-2]
{$IFDEF _X_}
{$undef uses_2}
{$IFNDEF NOT_USE_KOLMATH}
{$define uses_2}
{$ENDIF NOT_USE_KOLMATH}
{$IFDEF uses_2}
uses {$IFNDEF NOT_USE_KOLMATH} KOLmath
{$IFNDEF NOT_USE_EXCEPTION} , err
{$IFDEF REDECLARATION_INSERTED_AUTOMATICALLY}
, gdk2, pango, gtk2
{$ENDIF REDECLARATION_INSERTED_AUTOMATICALLY}
{$ENDIF NOT_USE_EXCEPTION}
{$ENDIF NOT_USE_KOLMATH};
{$ENDIF uses_2}
{$ELSE}
{$IFDEF USE_GRUSH}
uses ToGRush;
{$ELSE}
{$IFDEF INPACKAGE}
uses mirror, SysUtils;
{$ENDIF INPACKAGE}
{$ENDIF USE_GRUSH}
{$ENDIF _X_}
{$IFDEF WIN32}
{$IFDEF UNICODE_CTRLS}
{$DEFINE implementation_part} {$I KOL_unicode.inc} {$UNDEF implementation_part}
{$ENDIF UNICODE_CTRLS}
{$ENDIF WIN32}
{$IFDEF DEBUG_MCK}
procedure dummy_Log( const s: String );
begin
//
end;
{$ENDIF}
{$IFDEF WIN}
{$ifdef win32}
type
PSHFileInfoA = ^TSHFileInfoA;
PSHFileInfoW = ^TSHFileInfoW;
PSHFileInfo = PSHFileInfoA;
_SHFILEINFOA = record
hIcon: HICON; { out: icon }
iIcon: Integer; { out: icon index }
dwAttributes: DWORD; { out: SFGAO_ flags }
szDisplayName: array [0..MAX_PATH-1] of AnsiChar; { out: display name (or path) }
szTypeName: array [0..79] of AnsiChar; { out: type name }
end;
_SHFILEINFOW = record
hIcon: HICON; { out: icon }
iIcon: Integer; { out: icon index }
dwAttributes: DWORD; { out: SFGAO_ flags }
szDisplayName: array [0..MAX_PATH-1] of WideChar; { out: display name (or path) }
szTypeName: array [0..79] of WideChar; { out: type name }
end;
_SHFILEINFO = {$IFDEF UNICODE_CTRLS} _SHFILEINFOW {$ELSE} _SHFILEINFOA {$ENDIF};
TSHFileInfoA = _SHFILEINFOA;
TSHFileInfoW = _SHFILEINFOW;
TSHFileInfo = {$IFDEF UNICODE_CTRLS} TSHFileInfoW {$ELSE} TSHFileInfoA {$ENDIF};
SHFILEINFOA = _SHFILEINFOA;
SHFILEINFOW = _SHFILEINFOW;
SHFILEINFO = {$IFDEF UNICODE_CTRLS} SHFILEINFOW {$ELSE} SHFILEINFOA {$ENDIF};
const
SHGFI_ICON = $000000100; { get icon }
SHGFI_DISPLAYNAME = $000000200; { get display name }
SHGFI_TYPENAME = $000000400; { get type name }
SHGFI_ATTRIBUTES = $000000800; { get attributes }
SHGFI_ICONLOCATION = $000001000; { get icon location }
SHGFI_EXETYPE = $000002000; { return exe type }
SHGFI_SYSICONINDEX = $000004000; { get system icon index }
SHGFI_LINKOVERLAY = $000008000; { put a link overlay on icon }
SHGFI_SELECTED = $000010000; { show icon in selected state }
SHGFI_LARGEICON = $000000000; { get large icon }
SHGFI_SMALLICON = $000000001; { get small icon }
SHGFI_OPENICON = $000000002; { get open icon }
SHGFI_SHELLICONSIZE = $000000004; { get shell size icon }
SHGFI_PIDL = $000000008; { pszPath is a pidl }
SHGFI_USEFILEATTRIBUTES = $000000010; { use passed dwFileAttribute }
function SHGetFileInfoA(pszPath: PAnsiChar; dwFileAttributes: DWORD;
var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'SHGetFileInfoA';
{$IFDEF UNICODE_CTRLS}
function SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD;
var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'SHGetFileInfoW';
{$ENDIF UNICODE_CTRLS}
type
FILEOP_FLAGS = Word;
PRINTEROP_FLAGS = Word;
PSHFileOpStructA = ^TSHFileOpStructA;
PSHFileOpStructW = ^TSHFileOpStructW;
PSHFileOpStruct = PSHFileOpStructA;
_SHFILEOPSTRUCTA = {$ifndef wince}packed{$endif} record
Wnd: HWND;
wFunc: UINT;
pFrom: PAnsiChar;
pTo: PAnsiChar;
fFlags: FILEOP_FLAGS;
fAnyOperationsAborted: BOOL;
hNameMappings: Pointer;
lpszProgressTitle: PAnsiChar; { only used if FOF_SIMPLEPROGRESS }
end;
_SHFILEOPSTRUCTW = {$ifndef wince}packed{$endif} record
Wnd: HWND;
wFunc: UINT;
pFrom: PWideChar;
pTo: PWideChar;
fFlags: FILEOP_FLAGS;
fAnyOperationsAborted: BOOL;
hNameMappings: Pointer;
lpszProgressTitle: PWideChar; { only used if FOF_SIMPLEPROGRESS }
end;
_SHFILEOPSTRUCT = _SHFILEOPSTRUCTA;
TSHFileOpStructA = _SHFILEOPSTRUCTA;
TSHFileOpStructW = _SHFILEOPSTRUCTW;
TSHFileOpStruct = TSHFileOpStructA;
SHFILEOPSTRUCTA = _SHFILEOPSTRUCTA;
SHFILEOPSTRUCTW = _SHFILEOPSTRUCTW;
SHFILEOPSTRUCT = SHFILEOPSTRUCTA;
const
FO_MOVE = $0001;
FO_COPY = $0002;
FO_DELETE = $0003;
FO_RENAME = $0004;
FOF_MULTIDESTFILES = $0001;
FOF_CONFIRMMOUSE = $0002;
FOF_SILENT = $0004; { don't create progress/report }
FOF_RENAMEONCOLLISION = $0008;
FOF_NOCONFIRMATION = $0010; { Don't prompt the user. }
FOF_WANTMAPPINGHANDLE = $0020; { Fill in SHFILEOPSTRUCT.hNameMappings
Must be freed using SHFreeNameMappings }
FOF_ALLOWUNDO = $0040;
FOF_FILESONLY = $0080; { on *.*, do only files }
FOF_SIMPLEPROGRESS = $0100; { means don't show names of files }
FOF_NOCONFIRMMKDIR = $0200; { don't confirm making any needed dirs }
FOF_NOERRORUI = $0400; { don't put up error UI }
function SHFileOperationW(const lpFileOp: TSHFileOpStructW): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'SHFileOperationW';
function SHFileOperationA(const lpFileOp: TSHFileOpStructA): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'SHFileOperationA';
type
PNotifyIconDataA = ^TNotifyIconDataA;
PNotifyIconDataW = ^TNotifyIconDataW;
PNotifyIconData = PNotifyIconDataA;
_NOTIFYICONDATAA = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array [0..63] of AnsiChar;
end;
_NOTIFYICONDATAW = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array [0..63] of WideChar;
end;
_NOTIFYICONDATA = _NOTIFYICONDATAA;
TNotifyIconDataA = _NOTIFYICONDATAA;
TNotifyIconDataW = _NOTIFYICONDATAW;
TNotifyIconData = TNotifyIconDataA;
NOTIFYICONDATAA = _NOTIFYICONDATAA;
NOTIFYICONDATAW = _NOTIFYICONDATAW;
NOTIFYICONDATA = NOTIFYICONDATAA;
const
NIM_ADD = $00000000;
NIM_MODIFY = $00000001;
NIM_DELETE = $00000002;
NIF_MESSAGE = $00000001;
NIF_ICON = $00000002;
NIF_TIP = $00000004;
{$IFDEF UNICODE_CTRLS}
function Shell_NotifyIcon(dwMessage: DWORD; lpData: PNotifyIconDataW): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'Shell_NotifyIconW';
{$ELSE}
function Shell_NotifyIcon(dwMessage: DWORD; lpData: PNotifyIconData): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'Shell_NotifyIconA';
{$ENDIF UNICODE_CTRLS}
{$IFDEF UNICODE_CTRLS}
function ExtractIcon(hInst: HINST; lpszExeFileName: PKOLChar;
nIconIndex: UINT): HICON; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'ExtractIconW';
{$ELSE}
function ExtractIcon(hInst: HINST; lpszExeFileName: PKOLChar;
nIconIndex: UINT): HICON; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'ExtractIconA';
{$ENDIF UNICODE_CTRLS}
{$endif win32}
{$ENDIF WIN}
{$IFDEF WIN_GDI}
{$ifdef win32}
type
HDROP = Longint;
function DragQueryPoint(Drop: HDROP; var Point: TPoint): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'DragQueryPoint';
{$IFDEF UNICODE_CTRLS}
function DragQueryFile(Drop: HDROP; FileIndex: UINT; FileName: PWideChar; cb: UINT): UINT; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'DragQueryFileW';
{$ELSE}
function DragQueryFile(Drop: HDROP; FileIndex: UINT; FileName: PChar; cb: UINT): UINT; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'DragQueryFileA';
{$ENDIF UNICODE_CTRLS}
procedure DragFinish(Drop: HDROP); {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'DragFinish';
procedure DragAcceptFiles(Wnd: HWND; Accept: BOOL); {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'DragAcceptFiles';
const
OFN_READONLY = $00000001;
OFN_OVERWRITEPROMPT = $00000002;
OFN_HIDEREADONLY = $00000004;
OFN_NOCHANGEDIR = $00000008;
OFN_SHOWHELP = $00000010;
OFN_ENABLEHOOK = $00000020;
OFN_ENABLETEMPLATE = $00000040;
OFN_ENABLETEMPLATEHANDLE = $00000080;
OFN_NOVALIDATE = $00000100;
OFN_ALLOWMULTISELECT = $00000200;
OFN_EXTENSIONDIFFERENT = $00000400;
OFN_PATHMUSTEXIST = $00000800;
OFN_FILEMUSTEXIST = $00001000;
OFN_CREATEPROMPT = $00002000;
OFN_SHAREAWARE = $00004000;
OFN_NOREADONLYRETURN = $00008000;
OFN_NOTESTFILECREATE = $00010000;
OFN_NONETWORKBUTTON = $00020000;
OFN_NOLONGNAMES = $00040000;
OFN_EXPLORER = $00080000;
OFN_NODEREFERENCELINKS = $00100000;
OFN_LONGNAMES = $00200000;
OFN_ENABLEINCLUDENOTIFY = $00400000;
OFN_ENABLESIZING = $00800000;
OFN_DONTADDTORECENT = $02000000;
OFN_FORCESHOWHIDDEN = $10000000; // Show All files including System and hidden files
OFN_EX_NOPLACESBAR = $00000001;
OFN_SHAREFALLTHROUGH = 2;
OFN_SHARENOWARN = 1;
OFN_SHAREWARN = 0;
type
POpenFilename = ^TOpenFilename;
tagOFN = {$ifndef wince}packed{$endif} record
lStructSize: DWORD;
hWndOwner: HWND;
hInstance: HINST;
lpstrFilter: PKOLChar;
lpstrCustomFilter: PKOLChar;
nMaxCustFilter: DWORD;
nFilterIndex: DWORD;
lpstrFile: PKOLChar;
nMaxFile: DWORD;
lpstrFileTitle: PKOLChar;
nMaxFileTitle: DWORD;
lpstrInitialDir: PKOLChar;
lpstrTitle: PKOLChar;
Flags: DWORD;
nFileOffset: Word;
nFileExtension: Word;
lpstrDefExt: PKOLChar;
lCustData: LPARAM;
lpfnHook: function(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): UINT {$ifdef wince}cdecl{$else}stdcall{$endif};
lpTemplateName: PKOLChar;
{$IFDEF OpenSaveDialog_Extended}
//---------- added from Windows2000:
pvReserved: Pointer;
dwReserved: DWORD;
FlagsEx: DWORD;
{$ENDIF}
end;
TOpenFilename = tagOFN;
OPENFILENAME = tagOFN;
{$IFDEF UNICODE_CTRLS}
function GetOpenFileName(var OpenFile: TOpenFilename): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'comdlg32.dll' name 'GetOpenFileNameW';
function GetSaveFileName(var OpenFile: TOpenFilename): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'comdlg32.dll' name 'GetSaveFileNameW';
{$ELSE}
function GetOpenFileName(var OpenFile: TOpenFilename): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'comdlg32.dll' name 'GetOpenFileNameA';
function GetSaveFileName(var OpenFile: TOpenFilename): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'comdlg32.dll' name 'GetSaveFileNameA';
{$ENDIF UNICODE_CTRLS}
type
PChooseColorA = ^TChooseColorA;
PChooseColorW = ^TChooseColorW;
PChooseColor = PChooseColorA;
tagCHOOSECOLORA = {$ifndef wince}packed{$endif} record
lStructSize: DWORD;
hWndOwner: HWND;
hInstance: HWND;
rgbResult: COLORREF;
lpCustColors: ^COLORREF;
Flags: DWORD;
lCustData: LPARAM;
lpfnHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT {$ifdef wince}cdecl{$else}stdcall{$endif};
lpTemplateName: PAnsiChar;
end;
tagCHOOSECOLORW = {$ifndef wince}packed{$endif} record
lStructSize: DWORD;
hWndOwner: HWND;
hInstance: HWND;
rgbResult: COLORREF;
lpCustColors: ^COLORREF;
Flags: DWORD;
lCustData: LPARAM;
lpfnHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT {$ifdef wince}cdecl{$else}stdcall{$endif};
lpTemplateName: PWideChar;
end;
tagCHOOSECOLOR = tagCHOOSECOLORA;
TChooseColorA = tagCHOOSECOLORA;
TChooseColorW = tagCHOOSECOLORW;
TChooseColor = TChooseColorA;
const
CC_RGBINIT = $00000001;
CC_FULLOPEN = $00000002;
CC_PREVENTFULLOPEN = $00000004;
CC_SHOWHELP = $00000008;
CC_ENABLEHOOK = $00000010;
CC_ENABLETEMPLATE = $00000020;
CC_ENABLETEMPLATEHANDLE = $00000040;
CC_SOLIDCOLOR = $00000080;
CC_ANYCOLOR = $00000100;
function ChooseColor(var CC: TChooseColor): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'comdlg32.dll' name 'ChooseColorA';
{$endif win32}
{$IFDEF GDI}
//[procedure Chk_BitBlt_ShowError]
procedure Chk_BitBlt_ShowError;
var Rslt: Integer;
begin
Rslt := GetLastError;
ShowMessage( 'BitBlt ERROR: ' + Int2Str( Rslt )
+ ' ' + SysErrorMessage( Rslt ) );
end;
//[END Chk_BitBlt_ShowError]
//[procedure Chk_BitBlt]
{$ifdef wince}
procedure Chk_BitBlt;
begin
end;
{$else}
procedure Chk_BitBlt;
var Rslt: Integer;
begin
asm
MOV Rslt, EAX
end;
if Rslt = 0 then
begin
Chk_BitBlt_ShowError;
asm
int 3;
end;
end;
end;
{$endif wince}
//[END Chk_BitBlt]
{$ENDIF GDI}
{-}
{$ifdef _D2}
//[PROCEDURE Assert]
procedure Assert( Cond: Boolean; const Msg: String );
begin
if not Cond then
begin
AssertErrorProc( Msg, '', 0 );
//MsgOK( Msg );
asm
int 3;
end;
end;
end;
//[API CreateDIBSection]
function CreateDIBSection(DC: HDC; const p2: TBitmapInfo; p3: UINT;
var p4: Pointer; p5: THandle; p6: DWORD): HBITMAP; {$ifdef wince}cdecl{$else}stdcall{$endif};
external gdi32 name 'CreateDIBSection';
//[PROCEDURE _LStrFromPCharLen]
procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
asm
{ -> EAX pointer to dest }
{ EDX source }
{ ECX length }
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
{ allocate new string }
MOV EAX,EDI
CALL System.@NewAnsiString
MOV ECX,EDI
MOV EDI,EAX
TEST ESI,ESI
JE @@noMove
MOV EDX,EAX
MOV EAX,ESI
CALL Move
{ assign the result to dest }
@@noMove:
MOV EAX,EBX
CALL System.@LStrClr
MOV [EBX],EDI
POP EDI
POP ESI
POP EBX
end;
{$endif}
{+}
{$ifdef win32}
//[API InitCommonControls]
procedure InitCommonControls; external cctrl name 'InitCommonControls';
type
TInitCommonControlsEx = {$ifndef wince}packed{$endif} record
dwSize: DWORD;
dwICC: DWORD;
end;
PInitCommonControlsEx = ^TInitCommonControlsEx;
var ComCtl32_Module: HModule;
//[procedure DoInitCommonControls]
procedure DoInitCommonControls( dwICC: DWORD );
var Proc: procedure( ICC: PInitCommonControlsEx ); {$ifdef wince}cdecl{$else}stdcall{$endif};
ICC: TInitCommonControlsEx;
begin
InitCommonControls;
if ComCtl32_Module = 0 then
ComCtl32_Module := LoadLibrary( 'comctl32' );
@ Proc := GetProcAddress( ComCtl32_Module, 'InitCommonControlsEx' );
if Assigned( Proc ) then
begin
ICC.dwSize := Sizeof( ICC );
ICC.dwICC := dwICC;
Proc( @ ICC );
end;
end;
{$else}
procedure DoInitCommonControls( dwICC: DWORD );
var
ICC: TInitCommonControlsEx;
begin
ICC.dwSize := Sizeof( ICC );
ICC.dwICC := dwICC;
InitCommonControlsEx(@ICC);
end;
{$endif win32}
//[END DoInitCommonControls]
const size_TRect = 16; // used often in assembler versions of code
{-}
{$IFDEF ASM_VERSION}
const
EmptyString: String = '';
//[PROCEDURE EAX2PChar]
procedure EAX2PChar;
asm
TEST EAX, EAX
JNZ @@exit
MOV EAX, offset[EmptyString]
@@exit:
end;
//[PROCEDURE EDX2PChar]
procedure EDX2PChar;
asm
TEST EDX, EDX
JNZ @@exit
MOV EDX, offset[EmptyString]
@@exit:
end;
//[PROCEDURE ECX2PChar]
procedure ECX2PChar;
asm
JECXZ @@convert
RET
@@convert:
MOV ECX, offset[EmptyString]
@@exit:
end;
//[PROCEDURE RemoveStr]
procedure RemoveStr;
asm
{ <- [ESP+4] = string to remove
-> ESP := ESP + 4
EAX = 0
}
POP EAX
XCHG EAX, [ESP]
PUSH EAX
MOV EAX, ESP
CALL System.@LStrClr
POP EAX
end;
{$ELSE ASM_VERSION}
{$ENDIF ASM_VERSION}
{+}
const PossibleColorBits : array[1..7] of Byte = ( 1, 4, 8, 16, 24, 32, 0 );
function FindFilter( const Filter: KOLString): KOLString; forward;
function WriteExMemoryStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD; forward;
procedure CreateComboboxWnd( Combo: PControl ); forward;
procedure ComboboxDropDown( Sender: PObj ); forward;
function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
{$ifndef wince}
function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; forward;
{$endif wince}
function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; forward;
function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
function CompareStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD ); forward;
function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
procedure ApplyImageLists2Control( Sender: PControl ); forward;
procedure ApplyImageLists2ListView( Sender: PControl ); forward;
{$ifdef win32}
function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif}; forward;
function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ):
Integer; {$ifdef wince}cdecl{$else}stdcall{$endif}; forward;
{$endif win32}
function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif}; forward;
function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo; forward;
procedure PreparePF16bit( DIBHeader: PBitmapInfo ); forward;
procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
procedure _RotateBitmapRight( SrcBmp: PBitmap ); forward;
procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer ); forward;
procedure DetachBitmapFromCanvas( Sender: PBitmap ); forward;
function ColorBits( ColorsCount : Integer ) : Integer; forward;
procedure AlignChildrenProc(Sender: PObj); forward;
function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function CollectTabControls( Form: PControl ): PList; forward;
{$IFNDEF NOT_USE_RICHEDIT}
function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
{$ENDIF NOT_USE_RICHEDIT}
function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean; forward;
function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
forward;
function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
forward;
function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
forward;
procedure Tabulate2Next( Form: PControl; Dir: Integer ); forward;
function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
forward;
{$IFDEF GRAPHCTL_XPSTYLES}
{$I visual_xp_styles.inc}
{$ENDIF}
{$ifdef wince}
var
_CePlatform: byte = 255;
function CePlatform: TCePlatform;
var
buf: array[0..50] of WideChar;
begin
if _CePlatform = $FF then begin
Result := cpWinCE;
if SystemParametersInfo(SPI_GETPLATFORMTYPE, sizeof(buf), @buf, 0) then begin
if WStrCmp(@buf, 'PocketPC') = 0 then
Result := cpPocketPC
else
if WStrCmp(@buf, 'SmartPhone') = 0 then
Result := cpSmartphone;
end
else
if GetLastError = ERROR_ACCESS_DENIED then
Result := cpSmartphone;
_CePlatform:=byte(Result);
end
else
Result:=TCePlatform(_CePlatform);
end;
function WndProcSIPAware(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
begin
Result:=False;
case Msg.message of
WM_ACTIVATE:
begin
if PSHACTIVATEINFO(Sender.fCustomData).bits < 0 then begin
SHSipPreference(Msg.hwnd, SIPSTATE(PSHACTIVATEINFO(Sender.fCustomData).bits + 10));
PSHACTIVATEINFO(Sender.fCustomData).bits:=0;
end;
SHHandleWMActivate(Msg.hwnd, Msg.wParam, Msg.lParam, Sender.fCustomData, SHA_INPUTDIALOG);
end;
WM_SETTINGCHANGE:
SHHandleWMSettingChange(Msg.hwnd, Msg.wParam, Msg.lParam, Sender.fCustomData);
end;
end;
procedure CeFormSIPAware(Form: PControl; ShowSIP: boolean);
procedure CreateSIPPref(C: PControl);
var
i: integer;
begin
for i:=0 to C.ChildCount - 1 do
CreateSIPPref(C.Children[i]);
if C.ChildCount > 0 then
CreateWindowEx(0, 'SIPPREF', '', WS_CHILD , -10, -10, 5, 5, C.Handle, 0, 0, 0);
end;
begin
GetMem(Form.fCustomData, SizeOf(SHACTIVATEINFO));
FillChar(Form.fCustomData^, SizeOf(SHACTIVATEINFO), 0);
with PSHACTIVATEINFO(Form.fCustomData)^ do begin
cbSize:=SizeOf(SHACTIVATEINFO);
if ShowSIP then
bits:=integer(SIP_UP) - 10
else
bits:=integer(SIP_FORCEDOWN) - 10;
end;
Form.AttachProc(WndProcSIPAware);
SHInitExtraControls;
Form.CreateChildWindows;
CreateSIPPref(Form);
end;
function InsertMenuItem(Menu: HMENU; uItem: UINT; fByPosition: BOOL; const MII: TMenuItemInfo): BOOL;
var
id, Flags: UINT;
begin
if MII.hSubMenu <> 0 then begin
Flags:=MF_POPUP;
id:=MII.hSubMenu;
end
else begin
id:=MII.wID;
Flags:=MII.fType and not MFT_RADIOCHECK;
if MII.fType and MFT_SEPARATOR = 0 then
Flags:=Flags or MII.fState;
end;
if fByPosition then
Flags:=Flags or MF_BYPOSITION;
Result:=InsertMenu(Menu, uItem, Flags and not MF_DISABLED, id, MII.dwTypeData);
if (MII.fType and MFT_RADIOCHECK <> 0) and (MII.fState and MFS_CHECKED <> 0) then
CheckMenuRadioItem(Menu, MII.wID, MII.wID, MII.wID, MF_BYCOMMAND);
end;
var
CeSetMenuProc: procedure (Wnd: HWND; Menu: PMenu) = nil;
procedure CeSetMenu(Wnd: HWND; Menu: PMenu);
begin
if Assigned(CeSetMenuProc) then
CeSetMenuProc(Wnd, Menu);
end;
procedure CeSetMenuHandler(Wnd: HWND; Menu: PMenu);
var
mbi: SHMENUBARINFO;
tb: TBButton;
tbbi : TBBUTTONINFO;
i, j: integer;
st: byte;
R, BR: TRect;
begin
if (Menu <> nil) and (CePlatform = cpSmartphone) then
Menu.SaveState;
GetWindowRect(Wnd, BR);
mbi.hwndMB:=SHFindMenuBar(Wnd);
if (mbi.hwndMB <> 0) and (CePlatform = cpSmartphone) then begin
DestroyWindow(mbi.hwndMB);
mbi.hwndMB:=0;
end;
if mbi.hwndMB = 0 then begin
FillChar(mbi, SizeOf(mbi), 0);
with mbi do begin
cbSize:=SizeOf(mbi);
hwndParent:=Wnd;
nToolBarId:=20000;
hInstRes:=HINSTANCE;
if CePlatform = cpSmartphone then
if Menu <> nil then begin
i:=0;
for j:=0 to Menu.FItems.Count - 1 do
with PMenu(Menu.FItems.Items[j])^ do
if Visible then begin
Inc(i);
if (i = 1) and (SubMenu <> 0) then
Inc(nToolBarId)
else
if i = 2 then begin
if SubMenu <> 0 then
Inc(nToolBarId, 2);
break;
end;
end;
end;
end;
if not SHCreateMenuBar(@mbi) then
exit;
end;
while SendMessage(mbi.hwndMB, TB_DELETEBUTTON, 0, 0) <> 0 do ;
if Menu <> nil then begin
i:=0;
for j:=0 to Menu.FItems.Count - 1 do
with PMenu(Menu.FItems.Items[j])^ do
if Visible then begin
if FSavedState and MFS_DISABLED = 0 then
st:=TBSTATE_ENABLED
else
st:=0;
if FSavedState and MFS_CHECKED <> 0 then
st:=st or TBSTATE_CHECKED;
if CePlatform = cpSmartphone then begin
if i = 2 then
break; // smartphones have maximum 2 top level menu items.
tbbi.cbSize := sizeof(tbbi);
tbbi.pszText := PKOLChar(Caption);
tbbi.idCommand := FID;
tbbi.dwMask := TBIF_TEXT or TBIF_COMMAND or TBIF_STATE;
tbbi.fsState:=st;
SendMessage(mbi.hwndMB, TB_SETBUTTONINFO, i + 1, LPARAM(@tbbi));
if FHandle <> 0 then begin
tbbi.dwMask := TBIF_LPARAM;
SendMessage (mbi.hwndMB, TB_GETBUTTONINFO, FID, LPARAM(@tbbi));
DestroyMenu(FHandle);
FHandle:=HMENU(tbbi.lParam);
ReCreate;
end;
end
else begin
FillChar(tb, SizeOf(tb), 0);
tb.iBitmap:=I_IMAGENONE;
tb.idCommand:=fID;
tb.iString:=longint(PKOLChar(Caption));
tb.fsState:=st;
if SubMenu <> 0 then
tb.fsStyle:=TBSTYLE_DROPDOWN or $0080 or TBSTYLE_AUTOSIZE
else
tb.fsStyle:=TBSTYLE_BUTTON or TBSTYLE_AUTOSIZE;
tb.dwData:=SubMenu;
SendMessage(mbi.hwndMB, TB_INSERTBUTTON, i, LPARAM(@tb));
end;
Inc(i);
end;
if (CePlatform = cpSmartphone) and (i = 1) then begin
tbbi.dwMask := TBIF_STATE;
tbbi.fsState:=0;
SendMessage(mbi.hwndMB, TB_SETBUTTONINFO, 2, LPARAM(@tbbi));
end;
end;
GetWindowRect(mbi.hwndMB, R);
if BR.Bottom > R.Top then
SetWindowPos(wnd, 0, 0, 0, BR.Right - BR.Left, R.Top - BR.Top, SWP_NOZORDER or SWP_NOREPOSITION or SWP_NOMOVE);
end;
{$endif wince}
{$IFDEF SNAPMOUSE2DFLTBTN}
var FoundMsgBoxWnd: HWnd;
function EnumProcSnapMouse2DfltBtn( W: HWnd; lParam: Integer ): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
var ClassBuf: array[ 0..31 ] of KOLChar;
begin
GetClassName( W, ClassBuf, Sizeof( ClassBuf ) div Sizeof( KOLChar ) );
Result := TRUE;
if ClassBuf = '#32770' then
begin
FoundMsgBoxWnd := W;
Result := FALSE;
end;
end;
function WndProcSnapMouse2DfltBtn( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;
var W: HWnd;
R: TRect;
P: TPoint;
SnapMouse: Integer;
begin
SnapMouse := 0;
if SystemParametersInfo( SPI_GETSNAPTODEFBUTTON, 0, @ SnapMouse, 0 ) then
if SnapMouse <> 0 then
begin
FoundMsgBoxWnd := 0;
EnumThreadWindows( GetCurrentThreadID, @ EnumProcSnapMouse2DfltBtn, 0 );
if FoundMsgBoxWnd <> 0 then
begin
W := GetWindow( FoundMsgBoxWnd, GW_CHILD );
while W <> 0 do
begin
if GetWindowLong( W, GWL_STYLE ) and BS_DEFPUSHBUTTON <> 0 then
begin
GetWindowRect( W, R );
P.X := (R.Left + R.Right) div 2;
P.Y := (R.Top + R.Bottom) div 2;
SetCursorPos( P.X, P.Y );
end;
W := GetWindow( W, GW_HWNDNEXT );
end;
Applet.DetachProc( WndProcSnapMouse2DfltBtn );
end;
end;
Result := FALSE;
end;
{$ENDIF SNAPMOUSE2DFLTBTN}
{$IFDEF GDI}
//[function MsgBox]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function MsgBox( const S: KOLString; Flags: DWORD ): DWORD;
var Title: PKOLChar;
begin
Title := nil;
if assigned( Applet ) then
begin
Title := PKOLChar( Applet.fCaption );
end;
{$IFDEF SNAPMOUSE2DFLTBTN}
if Assigned( Applet ) then
begin
Applet.AttachProc( WndProcSnapMouse2DfltBtn );
Applet.Postmsg( 0, 0, 0 );
end;
{$ENDIF}
Result := MessageBox( 0, PKOLChar( S ), Title, Flags );
{$IFDEF SNAPMOUSE2DFLTBTN}
if Assigned( Applet ) then
Applet.DetachProc( WndProcSnapMouse2DfltBtn );
{$ENDIF}
end;
//[END MsgBox]
{$ENDIF ASM_VERSION}
//[PROCEDURE MsgOK]
procedure MsgOK( const S: KOLString );
begin
MsgBox( S, MB_OK );
end;
//[function ShowMsg]
{$IFDEF ASM_UNICODE}
function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
asm
push edx // Flags
mov ecx, [Applet]
{$IFDEF SNAPMOUSE2DFLTBTN}
jecxz @@0
pushad
xchg eax, ecx
mov edx, offset[WndProcSnapMouse2DfltBtn]
call TControl.AttachProc
popad
@@0:
{$ENDIF}
mov edx, 0
jecxz @@1
mov edx, [ecx].TControl.fHandle
mov ecx, [ecx].TControl.fCaption
@@1: push ecx // Title
push eax // S
push edx // Wnd
call MessageBox
{$IFDEF SNAPMOUSE2DFLTBTN}
mov ecx, [Applet]
jecxz @@2
pushad
xchg eax, ecx
mov edx, offset[WndProcSnapMouse2DfltBtn]
call TControl.DetachProc
popad
@@2:
{$ENDIF}
end;
{$ELSE PASCAL}
function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
var Title: PKOLChar;
Wnd: HWnd;
begin
{$IFDEF SNAPMOUSE2DFLTBTN}
if Assigned( Applet ) then
Applet.AttachProc( WndProcSnapMouse2DfltBtn );
{$ENDIF}
Title := nil;
Wnd := 0;
if assigned( Applet ) then
begin
Title := PKOLChar( Applet.fCaption );
//{$IFNDEF SNAPMOUSE2DFLTBTN}
Wnd := Applet.Handle;
//{$ENDIF}
end;
Result := MessageBox( Wnd, PKOLChar( S ), Title, Flags );
{$IFDEF SNAPMOUSE2DFLTBTN}
if Assigned( Applet ) then
Applet.DetachProc( WndProcSnapMouse2DfltBtn );
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END ShowMsg]
//[procedure ShowMessage]
procedure ShowMessage( const S: KOLString );
begin
ShowMsg( S, MB_OK or MB_SETFOREGROUND or MB_DEFBUTTON1 );
end;
//[END ShowMessage]
{$ENDIF GDI}
{$IFDEF WIN_GDI}
//[procedure SpeakerBeep]
procedure SpeakerBeep( Freq: Word; Duration: DWORD );
begin
{$ifdef win32}
if WinVer >= wvNT then
Windows.Beep( Freq, Duration )
else
begin
if Freq < 18 then Exit;
Freq := 1193181 div Freq;
if Freq = 0 then Exit;
asm
mov al,0b6H
out 43H,al
mov ax,Freq
//xchg al, ah
out 42h,al
xchg al, ah
out 42h,al
in al,61H
or al,03H
out 61H,al
end {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ;
Sleep(Duration);
asm
in al,61H
and al,0fcH
out 61H,al
end {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ;
end;
{$endif win32}
end;
//[END SpeakerBeep]
{$ENDIF WIN_GDI}
{++}(*
//[API FormatMessage]
function FormatMessage; external kernel32 name 'FormatMessageA';
*){--}
//[FUNCTION SysErrorMessage]
function SysErrorMessage(ErrorCode: Integer): KOLString;
var
Len: Integer;
Buffer: array[0..255] of KOLChar;
begin
Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
SizeOf(Buffer), nil);
while (Len > 0) and ((Buffer[Len - 1] >= #0) and (Buffer[Len - 1] <= ' ')) do Dec(Len);
SetString(Result, Buffer, Len);
end;
//[END SysErrorMessage]
{$ENDIF WIN_GDI}
//[function GetShiftState]
function GetShiftState: DWORD;
{$IFDEF WIN}
const Buttons: array[0..6] of Byte = ( VK_SHIFT, VK_CONTROL, VK_MENU, VK_LBUTTON,
VK_RBUTTON, VK_MBUTTON, VK_CAPITAL );
Flags: array[0..6] of Byte = ( MK_SHIFT, MK_CONTROL, MK_ALT, MK_LBUTTON,
MK_RBUTTON, MK_MBUTTON, MK_LOCK );
var i, mask: Integer;
{$ENDIF WIN} //todo: for Linux / GTK ?
begin
Result := 0;
{$IFDEF WIN}
mask := 1;
for i := High( Buttons ) downto 0 do
begin
if GetKeyState( Buttons[ i ] ) and mask <> 0 then
Result := Result or Flags[ i ];
mask := $8000;
end;
{$ENDIF WIN}
end;
//[END GetShiftState]
//[function MakeMethod]
function MakeMethod( Data, Code: Pointer ): TMethod;
begin
Result.Data := Data;
Result.Code := Code;
end;
//[END MakeMethod]
//[FUNCTION MakeRect]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
Result.Left := Left;
Result.Top := Top;
Result.Right:= Right;
Result.Bottom := Bottom;
end;
{$ENDIF ASM_VERSION}
//[END MakeRect]
//[FUNCTION RectsEqual]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function RectsEqual( const R1, R2: TRect ): Boolean;
begin
Result := CompareMem( @R1, @R2, Sizeof( TRect ) );
end;
{$ENDIF ASM_VERSION}
//[END RectsEqual]
//[function RectsIntersected]
function RectsIntersected( const R1, R2: TRect ): Boolean;
begin
Result := ((R1.Left <= R2.Left) and (R1.Right > R2.Left ) or
(R1.Left <= R2.Right) and (R1.Right >= R2.Right) or
(R1.Left >= R2.Left) and (R1.Right <= R2.Right))
and
((R1.Top <= R2.Top) and (R1.Bottom > R2.Top) or
(R1.Top <= R2.Bottom) and (R1.Bottom >= R2.Bottom) or
(R1.Top >= R2.Top) and (R1.Bottom <= R2.Bottom)) ;
end;
//[END RectsIntersected]
//[FUNCTION PointInRect]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function PointInRect( const P: TPoint; const R: TRect ): Boolean;
begin
Result := (P.x >= R.Left) and (P.x < R.Right)
and (P.y >= R.Top) and (P.y < R.Bottom);
end;
{$ENDIF ASM_VERSION}
//[END PointInRect]
//[FUNCTION OffsetPoint]
{$IFDEF ASM_VERSION}
function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint;
asm
ADD EDX, [EAX].TPoint.X
ADD ECX, [EAX].TPoint.Y
MOV EAX, [Result]
MOV [EAX].TPoint.X, EDX
MOV [EAX].TPoint.Y, ECX
end;
{$ELSE ASM_VERSION} // Pascal
function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint;
begin
Result := MakePoint( T.X + dX, T.Y + dY );
end;
{$ENDIF ASM_VERSION}
//[FUNCTION OffsetSmallPoint]
{$IFDEF ASM_VERSION}
function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint;
asm
SHL EDX, 16
SHLD ECX, EDX, 16
CALL @@1
@@1:
ROL EAX, 16
ROL ECX, 16
ADD AX, CX
end;
{$ELSE ASM_VERSION} // Pascal
function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint;
begin
Result.x := T.x + dX;
Result.y := T.y + dY;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}
function Point2SmallPoint( const T: TPoint ): TSmallPoint;
asm
XCHG EDX, EAX
MOV EAX, [EDX].TPoint.Y-2
MOV AX, word ptr [EDX].TPoint.X
end;
{$ELSE ASM_VERSION} // Pascal
function Point2SmallPoint( const T: TPoint ): TSmallPoint;
begin
Result.x := T.X;
Result.y := T.Y;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}
function SmallPoint2Point( const T: TSmallPoint ): TPoint;
asm
MOVSX ECX, AX
MOV [EDX].TPoint.X, ECX
SAR EAX, 16
MOV [EDX].TPoint.Y, EAX
end;
{$ELSE ASM_VERSION} //Pascal
function SmallPoint2Point( const T: TSmallPoint ): TPoint;
begin
Result := MakePoint( T.x, T.y );
end;
{$ENDIF ASM_VERSION}
//[FUNCTION MakePoint]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function MakePoint( X, Y: Integer ): TPoint;
begin
Result.x := X;
Result.y := Y;
end;
{$ENDIF ASM_VERSION}
//[END MakePoint]
{$IFDEF ASM_VERSION}
function MakeSmallPoint( X, Y: Integer ): TSmallPoint;
asm
SHL EAX, 16
SHRD EAX, EDX, 16
end;
{$ELSE ASM_VERSION} // Pascal
function MakeSmallPoint( X, Y: Integer ): TSmallPoint;
begin
Result.x := X;
Result.y := Y;
end;
{$ENDIF ASM_VERSION}
//[FUNCTION MakeFlags]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;
var I : Integer;
Mask : DWORD;
begin
Result := 0;
Mask := FlgSet^;
for I := 0 to High( FlgArray ) do
begin
if (FlgArray[ I ] < 0) and not LongBool( Mask and 1 ) then
Result := Result or not FlgArray[ I ]
else
if (FlgArray[ I ] >= 0) and LongBool( Mask and 1 ) then
Result := Result or FlgArray[ I ];
Mask := Mask shr 1;
end;
end;
{$ENDIF ASM_VERSION}
//[END MakeFlags]
function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange;
begin
Result.FromDate := D1;
Result.ToDate := D2;
end;
//[procedure Swap]
{$IFDEF ASM_VERSION}
procedure Swap( var X, Y: Integer );
asm
MOV ECX, [EDX]
XCHG ECX, [EAX]
MOV [EDX], ECX
end;
{$ELSE ASM_VERSION} //Pascal
procedure Swap( var X, Y: Integer );
var Tmp: Integer;
begin
Tmp := X;
X := Y;
Y := Tmp;
end;
{$ENDIF ASM_VERSION}
//[END Swap]
//[function Min]
{$IFDEF ASM_VERSION}
function Min( X, Y: Integer ): Integer;
asm
{$IFDEF F_P}
MOV EAX, [X]
MOV EDX, [Y]
{$ENDIF F_P}
{$IFDEF USE_CMOV}
CMP EAX, EDX
CMOVG EAX, EDX
{$ELSE}
CMP EAX, EDX
JLE @@exit
MOV EAX, EDX
@@exit:
{$ENDIF}
end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
function Min( X, Y: Integer ): Integer;
begin
if X < Y then
Result:=X
else
Result:=Y;
end;
{$ENDIF ASM_VERSION}
//[END Min]
//[function Max]
{$IFDEF ASM_VERSION}
function Max( X, Y: Integer ): Integer;
asm
{$IFDEF F_P}
MOV EAX, [X]
MOV EDX, [Y]
{$ENDIF F_P}
{$IFDEF USE_CMOV}
CMP EAX, EDX
CMOVL EAX, EDX
{$ELSE}
CMP EAX, EDX
JGE @@exit
MOV EAX, EDX
@@exit:
{$ENDIF}
end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
function Max( X, Y: Integer ): Integer;
begin
if X > Y then
Result:=X
else
Result:=Y;
end;
{$ENDIF ASM_VERSION}
//[END Max]
{$IFDEF REDEFINE_ABS}
//[function Abs]
function Abs( X: Integer ): Integer;
asm
{$IFDEF F_P}
MOV EAX, [X]
{$ENDIF F_P}
cdq
xor eax, edx
sub eax, edx
end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};
//[END Abs]
{$ENDIF}
//[function Sgn]
{$IFDEF ASM_VERSION}
function Sgn( X: Integer ): Integer;
asm
CMP EAX, 0
{$IFDEF USE_CMOV}
MOV EDX, -1
CMOVL EAX, EDX
MOV EDX, 1
CMOVG EAX, EDX
{$ELSE}
JZ @@exit
MOV EAX, 1
JG @@exit
MOV EAX, -1
@@exit:
{$ENDIF}
end;
{$ELSE ASM_VERSION} //Pascal
function Sgn( X: Integer ): Integer;
begin
if X > 0 then
Result:=1
else
Result:=-1;
end;
{$ENDIF ASM_VERSION}
//[END Sgn]
//[function iSqrt]
function iSQRT( X: Integer ): Integer;
{$IFDEF _D4orHigher}
// new version is more efficient but code is not compatible with older compilers
var I, N: Int64;
begin
Result := 0;
while Result < X do
begin
I := 1;
while I > 0 do
begin
N := (Result + I) * (Result + I);
if N > X then
begin
I := I shr 1;
break;
end
else
if N = X then
begin
Result := Result + I;
Exit;
end;
I := I * 2;
end;
if I <= 0 then Exit;
Result := Result + I;
end;
end;
{$ELSE _D3 or below or FPC1}
var m, y, b: DWORD;
begin
m := $40000000;
y := 0;
while m <> 0 do // 16 times
begin
b := y or m;
y := y shr 1;
if x >= b then
begin
x := x - b;
y := y or m;
end;
m := m shr 2;
end;
Result := y;
end;
{$ENDIF}
//[END iSqrt]
function iCbrt( X: DWORD ): Integer;
var s: Integer;
y, b: DWORD;
begin
s := 30;
y := 0;
while s >= 0 do // 11 times
begin
y := 2 * y;
b := (3 * y * (y+1) + 1) shl s;
s := s - 3;
if x >= b then
begin
x := x - b;
y := y + 1;
end;
end;
Result := y;
end;
{$IFDEF WIN_GDI}
{$IFDEF ASM_DC}
//[PROCEDURE StartDC]
procedure StartDC;
asm
{ <- EBX : PBitmap
-> EAX = dc
[ESP+8] = var dc
[ESP+4] = var SaveBmp
}
PUSH 0
CALL CreateCompatibleDC
POP EDX
PUSH EAX
PUSH EDX
MOV EAX, EBX
CALL [EBX].TBitmap.fDetachCanvas
MOV EAX, EBX
CALL TBitmap.GetHandle
PUSH EAX
PUSH dword ptr [ESP+8]
CALL SelectObject
POP EDX
PUSH EAX
PUSH EDX
MOV EAX, [ESP+8]
end;
//[END StartDC]
//[procedure FinishDC]
procedure FinishDC;
asm
POP ECX
POP EAX
POP EDX
PUSH ECX
PUSH EDX
PUSH EAX
PUSH EDX
CALL SelectObject
CALL DeleteDC
end;
//[END FinishDC]
{$ENDIF ASM_DC}
//[function EnumDynHandlers FORWARD DECLARATION]
function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
forward;
{$ENDIF WIN_GDI}
//[procedure DummyObjProc]
procedure DummyObjProc( Sender: PObj );
begin
end;
//[procedure DummyObjProcParam]
procedure DummyObjProcParam( Sender: PObj; Param: Pointer );
begin
end;
//[procedure DummyPaintProc]
procedure DummyPaintProc( Sender: PControl; DC: HDC );
begin
end;
{$IFDEF WIN}
{$ENDIF WIN}
{-}
{ _TObj }
//[procedure Free_And_Nil]
procedure Free_And_Nil( var Obj );
var Obj1: PObj;
begin
Obj1 := PObj( Obj );
Pointer( Obj ) := nil;
Obj1.Free;
end;
//[procedure _TObj.Init]
procedure _TObj.Init;
begin
{$IFDEF _D2orD3}
FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, 0 );
{$ENDIF}
end;
//[function _TObj.VmtAddr]
function _TObj.VmtAddr: Pointer;
asm
{$ifdef cpuarm}
ldr r0,[r0]
{$else}
MOV EAX, [EAX]
{$endif cpuarm}
end;
{ TObj }
class function TObj.AncestorOfObject(Obj: Pointer): Boolean;
asm
{$ifdef cpuarm}
mov r0,#0
{$else}
MOV ECX, [EAX]
MOV EAX, EDX
JMP @@loop1
@@loop:
MOV EAX,[EAX]
@@loop1:
TEST EAX,EAX
JE @@exit
CMP EAX,ECX
JNE @@loop
@@success:
MOV AL,1
@@exit:
{$endif cpuarm}
end;
{+}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
constructor TObj.Create;
begin
Init;
{++}(* inherited; *){--}
end;
{$ENDIF ASM_VERSION}
{$IFDEF OLD_REFCOUNT}
//[procedure TObj.DoDestroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TObj.DoDestroy;
begin
{$IFDEF OLD_REFCOUNT}
if fRefCount > 0 then
begin
if not LongBool( fRefCount and 1) then
Dec( fRefCount, 2 );
RefDec;
end
else
Self.Destroy;
if fRefCount <> 0 then
begin
if not LongBool( fRefCount and 1) then
Dec( fRefCount );
end
else
Self.Destroy;
{$ELSE}
if fRefCount > 0 then
RefDec
else
Self.Destroy;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$ENDIF OLD_REFCOUNT}
//[procedure TObj.RefDec]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TObj.RefDec: Integer;
begin
Result := 0; // stop Delphi alerting the Warning
if @ Self = nil then Exit;
Dec( fRefCount, 2 );
{$IFDEF OLD_REFCOUNT}
if (fRefCount < 0) and LongBool(fRefCount and 1) then
{$ifdef FPC}
Dispose(PObj(@Self),Destroy);
{$else}
Destroy;
{$endif FPC}
{$ELSE}
if fRefCount < 0 then
{$ifdef FPC}
Dispose(PObj(@Self),Destroy);
{$else}
Destroy;
{$endif FPC}
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[procedure TObj.RefInc]
procedure TObj.RefInc;
begin
Inc( fRefCount, 2 );
end;
{-}
//[function TObj.VmtAddr]
function TObj.VmtAddr: Pointer;
asm
{$ifdef cpuarm}
ldr r0,[r0,#-4]
{$else}
MOV EAX, [EAX - 4]
{$endif cpuarm}
end;
//[function TObj.InstanceSize]
function TObj.InstanceSize: Integer;
asm
{$ifdef cpuarm}
ldr r0,[r0]
ldr r0,[r0,#-4]
{$else}
MOV EAX, [EAX]
MOV EAX,[EAX-4]
{$endif cpuarm}
end;
{+}
{$IFDEF OLD_FREE}
//[procedure TObj.Free]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION}
procedure TObj.Free;
begin
//if @ Self <> nil then
RefDec;
end;
{$ENDIF ASM_VERSION}
{$ENDIF OLD_FREE}
{$UNDEF ASM_LOCAL}
{$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
{$IFDEF CRASH_DEBUG} {$UNDEF ASM_LOCAL} {$ENDIF}
{$IFDEF ASM_DEBUG} {$DEFINE ASM_LOCAL} {$ENDIF}
{$IFDEF ASM_LOCAL}
{$ELSE ASM_VERSION} //Pascal
destructor TObj.Destroy;
begin
Final;
{$IFDEF DEBUG_ENDSESSION}
if EndSession_Initiated then
LogFileOutput( GetStartDir + 'es_debug.txt',
'FINALLED: ' + Int2Hex( DWORD( @ Self )
{$IFDEF USE_NAMES}
+ ' (name:' + FName + ')'
{$ENDIF}
, 8 ) );
{$ENDIF}
{$IFDEF USE_NAMES}
fName := '';
if fNamedObjList <> nil then Free_And_Nil(fNamedObjList);
{$ENDIF}
{-}
//Dispose( @Self );
{$IFDEF CRASH_DEBUG}
FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, #$DD );
{$ENDIF}
{$ifndef FPC}
FreeMem( @ Self );
{$endif FPC}
{+} {++}(*
inherited; *){--}
end;
{$ENDIF ASM_VERSION}
{++}(*
//[procedure TObj.Init]
procedure TObj.Init;
begin
end;
*){--}
//[procedure TObj.Final]
{$IFDEF ASM_VERSION}
procedure TObj.Final;
asm //cmd //opd
PUSH EBX
XCHG EBX, EAX
XOR ECX, ECX
XCHG ECX, [EBX].fOnDestroy.TMethod.Code
JECXZ @@freeloop
MOV EDX, EBX
MOV EAX, [EDX].fOnDestroy.TMethod.Data
CALL ECX
@@freeloop:
MOV ECX, [EBX].fAutoFree
JECXZ @@eloop
MOV EDX, [ECX].TList.fItems
MOV ECX, [ECX].TList.fCount
JECXZ @@eloop
MOV EAX, [EDX+ECX*4-4]
MOV EDX, [EDX+ECX*4-8]
PUSH EAX
PUSH EDX
MOV EAX, [EBX].fAutoFree
LEA EDX, [ECX-2]
XOR ECX, ECX
MOV CL, 2
CALL TList.DeleteRange
POP EDX
POP EAX
CALL EDX
JMP @@freeloop
@@eloop:
XOR EAX, EAX
XCHG [EBX].fAutoFree, EAX
CALL TObj.RefDec
@@exit:
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
procedure TObj.Final;
var N: Integer;
ProcMethod: TMethod;
{$IFDEF _D2orD3}
Proc: TObjectMethod;
{$ELSE}
Proc: TObjectMethod Absolute ProcMethod;
{$ENDIF}
begin
if Assigned( fOnDestroy ) then
begin
fOnDestroy( @Self );
fOnDestroy := nil;
end;
while (fAutoFree <> nil) and (fAutoFree.fCount > 0) do
begin
N := fAutoFree.fCount - 2;
ProcMethod.Code := fAutoFree.fItems[ N ];
ProcMethod.Data := fAutoFree.fItems[ N + 1 ];
fAutoFree.DeleteRange( N, 2 );
{-}
{$IFDEF _D2orD3}
Proc := TObjectMethod( ProcMethod );
{$ENDIF}
Proc;
{+}{++}(*
asm
MOV EAX, [ProcMethod.Data]
{$IFDEF F_P}
PUSH EAX
{$ENDIF F_P}
MOV ECX, [ProcMethod.Code]
CALL ECX
end {$IFDEF F_P}[ 'EAX', 'EDX', 'ECX' ]{$ENDIF};
*){--}
end;
fAutoFree.Free;
fAutoFree := nil;
end;
{$ENDIF ASM_VERSION}
//[procedure TObj.Add2AutoFree]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TObj.Add2AutoFree(Obj: PObj);
begin
if fAutoFree = nil then
fAutoFree := NewList;
fAutoFree.Insert( 0, Obj );
fAutoFree.Insert( 0, Pointer( @TObj.RefDec ) );
end;
{$ENDIF ASM_VERSION}
//[procedure TObj.Add2AutoFreeEx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod );
{$IFDEF F_P}
var Ptr1, Ptr2: Pointer;
{$ENDIF F_P}
begin
if fAutoFree = nil then
fAutoFree := NewList;
{$IFDEF F_P}
asm
MOV EAX, [Proc]
MOV [Ptr1], EAX
MOV EAX, [Proc+4]
MOV [Ptr2], EAX
end [ 'EAX' ];
fAutoFree.Insert( 0, Ptr2 );
fAutoFree.Insert( 0, Ptr1 );
{$ELSE DELPHI}
fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Data ) );
fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Code ) );
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[procedure TObj.RemoveFromAutoFree]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION}
procedure TObj.RemoveFromAutoFree(Obj: PObj);
var i: Integer;
begin
if fAutoFree <> nil then
begin
i := fAutoFree.IndexOf( Obj );
if i >= 0 then
begin
fAutoFree.DeleteRange( i and not 1, 2 );
if fAutoFree.Count = 0 then
Free_And_Nil( fAutoFree );
end;
end;
end;
{$ENDIF ASM_VERSION}
procedure TObj.RemoveFromAutoFreeEx(Proc: TObjectMethod);
var i: Integer;
begin
if fAutoFree <> nil then
begin
for i := 0 to fAutoFree.Count-2 do
if (fAutoFree.Items[ i ] = TMethod( Proc ).Data) and
(fAutoFree.Items[ i+1 ] = TMethod( Proc ).Code) then
begin
fAutoFree.Delete( i );
fAutoFree.Delete( i );
break;
end;
end;
end;
{$IFDEF USE_NAMES}
procedure TObj.SetName( NewOwnerObj: PObj; const NewName: String );
{$IFDEF UNIQUE_NAMES}
var i: Integer;
{$ENDIF}
begin
if (FOwnerObj <> nil) then
if FOwnerObj <> NewOwnerObj then
begin
FOwnerObj.fNamedObjList.Remove( @ Self );
end;
FOwnerObj := NewOwnerObj;
if NewOwnerObj = nil then
begin
if NewName = '' then
begin
fName := '';
Exit;
end;
// здесь тот случай, когда в приложении без Applet'а устанавливается
// имя для главной формы (наверное)
FOwnerObj := @ Self; // владельцем списка именованных объектов становится
// сам объект. Для вышеозначенного случая - главная форма держит себя и
// другие формы.
end;
if FOwnerObj.fNamedObjList = nil then
FOwnerObj.fNamedObjList := NewList;
{$IFDEF UNIQUE_NAMES}
for i := 0 to FOwnerObj.fNamedObjList.Count-1 do
begin
if PObj( FOwnerObj.fNamedObjList.Items[ i ] ).FName = NewName then
begin
NewName := '';
break;
end;
end;
{$ENDIF}
FName := NewName;
if FName = '' then
FOwnerObj.fNamedObjList.Remove( @ Self )
else
if FOwnerObj.fNamedObjList.IndexOf( @ Self ) < 0 then
FOwnerObj.fNamedObjList.Add( @ Self );
end;
function TObj.FindObj(const ObjName: string): PObj;
var i: Integer;
Obj: PObj;
begin
if fNamedObjList <> nil then
for i := 0 to fNamedObjList.Count-1 do
begin
Obj := fNamedObjList.Items[ i ];
if ObjName = Obj.FName then
begin
Result := Obj; Exit;
end;
end;
Result := nil;
end;
{$ENDIF}
{ TList }
{$IFDEF ASM_VERSION}
{$DEFINE ASM_TLIST}
{$IFDEF TLIST_FAST}
{$UNDEF ASM_TLIST}
{$ENDIF}
{$ENDIF}
{$IFDEF USE_CONSTRUCTORS}
procedure TList.Init;
begin
{$IFDEF _D2orD3}
inherited;
{$ENDIF}
fAddBy := 4;
{$IFDEF TLIST_FAST}
{$IFNDEF DFLT_TLIST_NOUSE_BLOCKS} // for debug only
fUseBlocks := TRUE;
{$ENDIF}
{$ENDIF}
end;
//[function NewList]
function NewList: PList;
begin
New( Result, Create );
//Result.fAddBy := 4;
end;
//[END NewList]
{$ELSE not_USE_CONSTRUCTORS}
//[function NewList]
function NewList: PList;
begin
{-}
New( Result, Create );
{+} {++}(* Result := PList.Create; *){--}
Result.fAddBy := 4;
{$IFDEF TLIST_FAST}
{$IFNDEF DFLT_TLIST_NOUSE_BLOCKS} // for debug only
Result.fUseBlocks := TRUE;
{$ENDIF}
{$ENDIF}
end;
//[END NewList]
{$ENDIF USE_CONSTRUCTORS}
//[procedure TList.Init]
{$IFDEF _D4orHigher}
function NewListInit( const AItems: array of Pointer ): PList;
var i: Integer;
begin
Result := NewList;
Result.Capacity := Length( AItems );
for i := 0 to High( AItems ) do
Result.Add( AItems[ i ] );
end;
{$ENDIF}
//[procedure HelpFastIncNum2Els]
{$IFDEF ASM_VERSION}
procedure HelpFastIncNum2Els( DataArray: Pointer; Value, Count: Integer );
asm
PUSH ESI
PUSH EDI
{$IFDEF F_P}
MOV ESI, [DataArray]
MOV EDX, [Value]
MOV ECX, [Count]
{$ELSE DELPHI}
MOV ESI, EAX
{$ENDIF F_P/DELPHI}
MOV EDI, ESI
CLD
@@1:
LODSD
ADD EAX, EDX
STOSD
LOOP @@1
POP EDI
POP ESI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
procedure HelpFastIncNum2Els( DataArray: Pointer; Value, Count: Integer );
begin
while Count > 0 do begin
Inc(PInteger(DataArray)^, Value);
Inc(PInteger(DataArray));
Dec(Count);
end;
end;
{$ENDIF ASM_VERSION}
//[END HelpFastIncNum2Els]
//[procedure FastIncNum2Elements]
procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer );
begin
HelpFastIncNum2Els( @List.fItems[ FromIdx ], Value, Count );
end;
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TList.Destroy;
begin
Clear;
inherited;
end;
{$ENDIF ASM_VERSION}
//[procedure TList.Release]
{$IFDEF ASM_TLIST}
{$ELSE ASM_VERSION} //Pascal
procedure TList.Release;
var I: Integer;
{$IFDEF TLIST_FAST}
BlockStart: PDWORD;
j, CountCurrent: Integer;
{$ENDIF}
begin
if @ Self = nil then Exit;
{$IFDEF TLIST_FAST}
if fUseBlocks and Assigned( fBlockList ) then
begin
for i := 0 to fBlockList.Count div 2 - 1 do
begin
BlockStart := fBlockList.fItems[ i*2 ];
CountCurrent := Integer( fBlockList.fItems[ i*2+1 ] );
for j := 0 to CountCurrent-1 do
begin
if BlockStart^ <> 0 then
FreeMem( Pointer( BlockStart^ ) );
inc( BlockStart );
end;
end;
end
else
{$ENDIF}
for I := 0 to fCount - 1 do
if fItems[ I ] <> nil then
FreeMem( fItems[ I ] );
Free;
end;
{$ENDIF ASM_VERSION}
//[procedure TList.ReleaseObjects]
procedure TList.ReleaseObjects;
var I: Integer;
{$IFDEF TLIST_FAST}
BlockStart: PDWORD;
j, CountCurrent: Integer;
{$ENDIF}
begin
if @ Self = nil then Exit;
{$IFDEF TLIST_FAST}
if fUseBlocks and Assigned( fBlockList ) then
begin
for i := 0 to fBlockList.Count div 2 - 1 do
begin
BlockStart := fBlockList.fItems[ i*2 ];
CountCurrent := Integer( fBlockList.fItems[ i*2+1 ] );
for j := 0 to CountCurrent-1 do
begin
if BlockStart^ <> 0 then
PObj( Pointer( BlockStart^ ) ).Free;
inc( BlockStart );
end;
end;
end
else
{$ENDIF}
for I := fCount-1 downto 0 do
PObj( fItems[ I ] ).Free;
Free;
end;
//[procedure TList.SetCapacity]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
//var NewItems: PPointerList;
procedure TList.SetCapacity( Value: Integer );
begin
{$IFDEF TLIST_FAST}
if fUseBlocks and (Assigned( fBlockList ) or (Value > 256)) then
begin
fCapacity := Value;
end
else
{$ENDIF}
begin
if Value < Count then
Value := Count;
if Value = fCapacity then Exit;
ReallocMem( fItems, Value * Sizeof( Pointer ) );
fCapacity := Value;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TList.Clear]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TList.Clear;
{$IFDEF TLIST_FAST}
var i: Integer;
{$ENDIF}
begin
if fItems <> nil then
FreeMem( fItems );
fItems := nil;
fCount := 0;
fCapacity := 0;
{$IFDEF TLIST_FAST}
if fBlockList <> nil then
for i := 0 to fBlockList.Count div 2 - 1 do
FreeMem(fBlockList.Items[ i*2 ]);
Free_And_Nil( fBlockList );
fLastKnownBlockIdx := 0;
fLastKnownCountBefore := 0;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[procedure TList.SetAddBy]
procedure TList.SetAddBy(Value: Integer);
begin
if Value < 1 then Value := 1;
fAddBy := Value;
end;
//[procedure TList.Add]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TList.Add( Value: Pointer );
{$IFDEF TLIST_FAST}
var LastBlockCount: Integer;
LastBlockStart: Pointer;
{$ENDIF}
begin
{$IFDEF TLIST_FAST}
if fUseBlocks and ((fCount >= 256) or Assigned( fBlockList )) then
begin
if fBlockList = nil then
begin
fBlockList := NewList;
fBlockList.fUseBlocks := FALSE;
fBlockList.Add( fItems );
fBlockList.Add( Pointer( fCount ) );
fItems := nil;
end;
if fBlockList.fCount = 0 then
begin
fBlockList.Add( nil );
fBlockList.Add( nil );
LastBlockCount := 0;
end
else
begin
LastBlockCount := Integer( fBlockList.fItems[ fBlockList.fCount-1 ] );
if LastBlockCount >= 256 then
begin
fBlockList.Add( nil );
fBlockList.Add( nil );
LastBlockCount := 0;
end;
end;
LastBlockStart := fBlockList.Items[ fBlockList.fCount-2 ];
if LastBlockStart = nil then
begin
GetMem( LastBlockStart, 256 * Sizeof( Pointer ) );
fBlockList.Items[ fBlockList.fCount-2 ] := LastBlockStart;
end;
fBlockList.Items[ fBlockList.fCount-1 ] := Pointer( LastBlockCount+1 );
PDWORD( Integer(LastBlockStart) + Sizeof(Pointer)*LastBlockCount )^ :=
DWORD( Value );
end
else
{$ENDIF}
begin
if fCapacity <= fCount then
begin
if fAddBy <= 0 then
Capacity := fCount + Min( 1000, fCount div 4 + 1 )
else
Capacity := fCount + fAddBy;
end;
fItems[ fCount ] := Value;
end;
Inc( fCount );
end;
{$ENDIF ASM_VERSION}
{$IFDEF _D4orHigher}
procedure TList.AddItems(const AItems: array of Pointer);
var i: Integer;
begin
Capacity := Count + Length( AItems );
for i := 0 to High( AItems ) do
Add( AItems[ i ] );
end;
{$ENDIF}
//[procedure TList.Delete]
procedure TList.Delete( Idx: Integer );
begin
DeleteRange( Idx, 1 );
end;
//[procedure TList.DeleteRange]
{$IFDEF ASM_TLIST}
{$ELSE ASM_VERSION} //Pascal
procedure TList.DeleteRange(Idx, Len: Integer);
{$IFDEF TLIST_FAST}
var i, DelFromBlock: Integer;
CountBefore, CountCurrent: Integer;
BlockStart: Pointer;
{$ENDIF}
begin
if Len <= 0 then Exit;
if Idx >= Count then Exit;
Assert( (Idx >= 0), 'TList.DeleteRange: index out of bounds' );
if DWORD( Idx + Len ) > DWORD( Count ) then
Len := Count - Idx;
{$IFDEF TLIST_FAST}
if fUseBlocks and Assigned( fBlockList ) then
begin
CountBefore := 0;
i := 0;
if (fLastKnownBlockIdx > 0) and
(Idx >= fLastKnownCountBefore) then
begin
i := fLastKnownBlockIdx;
CountBefore := fLastKnownCountBefore;
end;
while i < fBlockList.fCount div 2 do
begin
BlockStart := fBlockList.fItems[ i * 2 ];
CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
if (Idx >= CountBefore) and (Idx < CountBefore + CountCurrent) then
begin
DelFromBlock := CountBefore + CountCurrent - Idx;
if DelFromBlock > Len then
DelFromBlock := Len;
if DelFromBlock < CountCurrent then
begin
move( Pointer( Integer( BlockStart ) + (Idx - CountBefore + DelFromBlock) * Sizeof( Pointer ) )^,
Pointer( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^,
(CountCurrent - (Idx - CountBefore) - DelFromBlock) * Sizeof( Pointer ) );
dec( CountCurrent, DelFromBlock );
fBlockList.fItems[ i * 2 + 1 ] := Pointer( CountCurrent );
dec( fCount, DelFromBlock );
dec( Len, DelFromBlock );
if Len <= 0 then Exit;
end
else
begin // delete entire block
FreeMem( BlockStart );
fBlockList.DeleteRange( i * 2, 2 );
dec( fCount, CountCurrent );
dec( Len, CountCurrent );
if Len <= 0 then Exit;
CountCurrent := 0;
dec( i );
end;
end;
inc( i );
inc( CountBefore, CountCurrent );
end;
end
else
{$ENDIF}
begin
Move( fItems[ Idx + Len ], fItems[ Idx ], Sizeof( Pointer ) * (Count - Idx - Len) );
Dec( fCount, Len );
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TList.Remove]
procedure TList.Remove(Value: Pointer);
var I: Integer;
begin
I := IndexOf( Value );
if I >= 0 then
Delete( I );
end;
function TList.ItemAddress(Idx: Integer): Pointer;
{$IFDEF TLIST_FAST}
var i: Integer;
BlockStart: Pointer;
CountBefore, CountCurrent: Integer;
{$ENDIF}
begin
{$IFDEF TLIST_FAST}
if fUseBlocks and Assigned( fBlockList ) then
begin
CountBefore := 0;
i := 0;
if (fLastKnownBlockIdx > 0) and
(Idx >= fLastKnownCountBefore) then
begin
CountBefore := fLastKnownCountBefore;
i := fLastKnownBlockIdx;
end;
CountCurrent := CountBefore + Integer( fBlockList.fItems[ i*2+1 ] );
if Idx - CountCurrent > fCount - CountCurrent then
begin // поиск в обратном направлении может оказаться быстрее
CountBefore := fCount;
i := fBlockList.fCount div 2 - 1;
while TRUE do
begin
BlockStart := fBlockList.fItems[ i * 2 ];
CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
if (CountBefore - CountCurrent <= Idx) and (Idx < CountBefore) then
begin
Result := Pointer( Integer( BlockStart ) +
(Idx - (CountBefore - CountCurrent))*Sizeof( Pointer ) );
Exit;
end;
dec( CountBefore, CountCurrent );
dec( i );
end;
end;
while TRUE { i < fBlockList.Count div 2 } do
begin
BlockStart := fBlockList.fItems[ i * 2 ];
CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then
begin
Result := Pointer( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) );
Exit;
end;
inc( CountBefore, CountCurrent );
inc( i );
end;
end
else
{$ENDIF}
Result := Pointer( cardinal( fItems ) + cardinal(Idx) * Sizeof( Pointer ) );
end;
//[procedure TList.Put]
{$IFDEF ASM_VERSION}
procedure TList.Put( Idx: Integer; Value: Pointer );
asm
TEST EDX, EDX
JL @@exit
CMP EDX, [EAX].fCount
JGE @@exit
PUSH ESI
MOV ESI, ECX
{$IFDEF TLIST_FAST}
CMP [EAX].fUseBlocks, 0
JZ @@old
MOV ECX, [EAX].fBlockList
JECXZ @@old
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
XCHG EBX, EAX // EBX == @Self
XOR ECX, ECX // CountBefore := 0;
XOR EAX, EAX // i := 0;
CMP [EBX].fLastKnownBlockIdx, 0
JLE @@1
CMP EDX, [EBX].fLastKnownCountBefore
JL @@1
MOV ECX, [EBX].fLastKnownCountBefore
MOV EAX, [EBX].fLastKnownBlockIdx
@@1:
MOV ESI, [EBX].fBlockList
MOV ESI, [ESI].fItems
MOV EDI, [ESI+EAX*8] // EDI = BlockStart
MOV ESI, [ESI+EAX*8+4] // ESI = CountCurrent
CMP ECX, EDX
JG @@next
LEA EBP, [ECX+ESI]
CMP EDX, EBP
JGE @@next
MOV [EBX].fLastKnownBlockIdx, EAX
MOV [EBX].fLastKnownCountBefore, ECX
SUB EDX, ECX
LEA EAX, [EDI+EDX*4]
POP EBP
POP EDI
POP ESI
POP EBX
MOV [EAX], ESI
POP ESI
RET
@@next:
ADD ECX, ESI
INC EAX
JMP @@1
@@old:
{$ENDIF}
MOV EAX, [EAX].fItems
MOV [EAX+EDX*4], ESI
POP ESI
@@exit:
end;
{$ELSE not ASM_VERSION}
procedure TList.Put( Idx: Integer; Value: Pointer );
{$IFDEF TLIST_FAST}
var i: Integer;
BlockStart: Pointer;
CountBefore, CountCurrent: Integer;
{$ENDIF}
begin
if Idx < 0 then Exit;
if Idx >= Count then Exit;
{$IFDEF TLIST_FAST}
if fUseBlocks and Assigned( fBlockList ) then
begin
CountBefore := 0;
i := 0;
if (fLastKnownBlockIdx > 0) and
(Idx >= fLastKnownCountBefore) then
begin
i := fLastKnownBlockIdx;
CountBefore := fLastKnownCountBefore;
end;
while i < fBlockList.fCount div 2 do
begin
BlockStart := fBlockList.fItems[ i * 2 ];
CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then
begin
fLastKnownBlockIdx := i;
fLastKnownCountBefore := CountBefore;
PDWORD( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ :=
DWORD( Value );
Exit;
end;
inc( CountBefore, CountCurrent );
inc( i );
end;
end
else
{$ENDIF}
fItems[ Idx ] := Value;
end;
{$ENDIF ASM_VERSION}
//[function TList.Get]
{$IFDEF ASM_VERSION}
function TList.Get( Idx: Integer ): Pointer;
asm
TEST EDX, EDX
JL @@ret_nil
CMP EDX, [EAX].fCount
JGE @@ret_nil
{$IFDEF TLIST_FAST}
CMP [EAX].fUseBlocks, 0
JZ @@old
MOV ECX, [EAX].fBlockList
JECXZ @@old
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
XCHG EBX, EAX // EBX == @Self
XOR ECX, ECX // CountBefore := 0;
XOR EAX, EAX // i := 0;
CMP [EBX].fLastKnownBlockIdx, 0
JLE @@1
CMP EDX, [EBX].fLastKnownCountBefore
JL @@1
MOV ECX, [EBX].fLastKnownCountBefore
MOV EAX, [EBX].fLastKnownBlockIdx
@@1:
MOV ESI, [EBX].fBlockList
MOV ESI, [ESI].fItems
MOV EDI, [ESI+EAX*8] // EDI = BlockStart
MOV ESI, [ESI+EAX*8+4] // ESI = CountCurrent
CMP ECX, EDX
JG @@next
LEA EBP, [ECX+ESI]
CMP EDX, EBP
JGE @@next
MOV [EBX].fLastKnownBlockIdx, EAX
MOV [EBX].fLastKnownCountBefore, ECX
SUB EDX, ECX
MOV EAX, [EDI+EDX*4]
POP EBP
POP EDI
POP ESI
POP EBX
RET
@@next:
ADD ECX, ESI
INC EAX
JMP @@1
@@old:
{$ENDIF}
MOV EAX, [EAX].fItems
MOV EAX, [EAX+EDX*4]
RET
@@ret_nil:
XOR EAX, EAX
end;
{$ELSE not ASM_VERSION}
function TList.Get( Idx: Integer ): Pointer;
{$IFDEF TLIST_FAST}
var i: Integer;
BlockStart: Pointer;
CountBefore, CountCurrent: Integer;
{$ENDIF}
begin
Result := nil;
if Idx < 0 then Exit;
if Idx >= fCount then Exit;
{$IFDEF TLIST_FAST}
if fUseBlocks and Assigned( fBlockList ) then
begin
CountBefore := 0;
i := 0;
if (fLastKnownBlockIdx > 0) and
(Idx >= fLastKnownCountBefore) then
begin
i := fLastKnownBlockIdx;
CountBefore := fLastKnownCountBefore;
end;
while {i < fBlockList.fCount div 2} TRUE do
begin
BlockStart := fBlockList.fItems[ i * 2 ];
CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then
begin
fLastKnownBlockIdx := i;
fLastKnownCountBefore := CountBefore;
Result := Pointer( PDWORD( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ );
Exit;
end;
inc( CountBefore, CountCurrent );
inc( i );
end;
end
else
{$ENDIF}
Result := fItems[ Idx ];
end;
{$ENDIF ASM_VERSION}
//[function TList.IndexOf]
{$IFDEF ASM_TLIST}
{$ELSE ASM_VERSION} //Pascal
function TList.IndexOf( Value: Pointer ): Integer;
var I: Integer;
{$IFDEF TLIST_FAST}
BlockStart: PDWORD;
j: Integer;
CountBefore, CountCurrent: Integer;
{$ENDIF}
begin
{$IFDEF DEBUG}
TRY
{$ENDIF}
Result := -1;
{$IFDEF TLIST_FAST}
if fUseBlocks and Assigned( fBlockList ) then
begin
CountBefore := 0;
for I := 0 to fBlockList.fCount div 2 - 1 do
begin
BlockStart := fBlockList.fItems[ I * 2 ];
CountCurrent := Integer( fBlockList.fItems[ I * 2 + 1 ] );
for j := 0 to CountCurrent-1 do
begin
if BlockStart^ = DWORD( Value ) then
begin
Result := CountBefore + j;
Exit;
end;
inc( BlockStart );
end;
inc( CountBefore, CountCurrent );
end;
end
else
{$ENDIF}
begin
for I := 0 to fCount - 1 do
begin
if fItems[ I ] = Value then
begin
Result := I;
break;
end;
end;
end;
{$IFDEF DEBUG}
EXCEPT
asm
nop
end;
END;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[procedure TList.Insert]
{$IFDEF ASM_TLIST}
{$ELSE ASM_VERSION} //Pascal
procedure TList.Insert(Idx: Integer; Value: Pointer);
{$IFDEF TLIST_FAST}
var i: Integer;
CountBefore, CountCurrent: Integer;
BlockStart, NewBlock: Pointer;
{$ENDIF}
begin
Assert( (Idx >= 0) and (Idx <= FCount+1), 'List index out of bounds' );
{$IFDEF TLIST_FAST}
if fUseBlocks and (Assigned( fBlockList ) or (fCount >= 256)) then
begin
if not Assigned( fBlockList ) then
begin
fBlockList := NewList;
fBlockList.fUseBlocks := FALSE;
fBlockList.Add( fItems );
fBlockList.Add( Pointer( fCount ) );
fItems := nil;
end;
if fBlockList.fCount = 0 then
begin
GetMem( NewBlock, 256 * Sizeof( Pointer ) );
fBlockList.Add( NewBlock );
fBlockList.Add( nil );
end;
CountBefore := 0;
i := 0;
if (fLastKnownBlockIdx > 0) and
(Idx >= fLastKnownCountBefore) then
begin
i := fLastKnownBlockIdx;
CountBefore := fLastKnownCountBefore;
end;
while TRUE {i < fBlockList.fCount div 2} do
begin
CountCurrent := Integer( fBlockList.Items[ i * 2 + 1 ] );
if (Idx >= CountBefore) and
((Idx < CountBefore + CountCurrent) or
(Idx = CountBefore + CountCurrent) and
(CountCurrent < 256)) then // insert in block i
begin
BlockStart := fBlockList.fItems[ i * 2 ];
if BlockStart = nil then
begin
GetMem( BlockStart, 256 * Sizeof( Pointer ) );
fBlockList.fItems[ i * 2 ] := BlockStart;
end;
Idx := Idx - CountBefore;
if CountCurrent < 256 then
begin
if Idx < CountCurrent then
Move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^,
Pointer( Integer( BlockStart ) + (Idx+1) * Sizeof( Pointer ) )^,
(CountCurrent - Idx) * Sizeof( Pointer ) );
PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ :=
DWORD( Value );
fBlockList.fItems[ i * 2 + 1 ] := Pointer( CountCurrent + 1 );
end
else // new block is created since current block is full 256 items
begin
GetMem( NewBlock, 256 * Sizeof( Pointer ) );
fBlockList.Insert( (i+1)*2, Pointer( 256-Idx ) );
fBlockList.Insert( (i+1)*2, NewBlock );
move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^,
NewBlock^, (256 - Idx) * Sizeof( Pointer ) );
PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ :=
DWORD( Value );
fBlockList.fItems[ i * 2 + 1 ] := Pointer( Idx + 1 );
end;
fLastKnownBlockIdx := i;
fLastKnownCountBefore := CountBefore;
inc( fCount );
Exit;
end;
inc( CountBefore, CountCurrent );
inc( i );
if i >= fBlockList.fCount div 2 then
begin
fBlockList.Add( nil );
fBlockList.Add( nil );
end;
end;
end
else
{$ENDIF}
begin
Add( nil );
if fCount > Idx then
Move( FItems[ Idx ], FItems[ Idx + 1 ], (fCount - Idx - 1) * Sizeof( Pointer ) );
FItems[ Idx ] := Value;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TList.MoveItem]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TList.MoveItem(OldIdx, NewIdx: Integer);
var Item: Pointer;
begin
if OldIdx = NewIdx then Exit;
if NewIdx >= Count then Exit;
Item := Items[ OldIdx ];
Delete( OldIdx );
Insert( NewIdx, Item );
end;
{$ENDIF ASM_VERSION}
//[function TList.Last]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TList.Last: Pointer;
begin
if Count = 0 then
Result := nil
else
Result := Items[ Count-1 ];
end;
{$ENDIF ASM_VERSION}
//[procedure TList.Swap]
{$IFDEF ASM_TLIST}
{$ELSE ASM_VERSION} //Pascal
procedure TList.Swap(Idx1, Idx2: Integer);
var Tmp: DWORD;
AItem1, AItem2: PDWORD;
begin
{$IFDEF TLIST_FAST}
AItem1 := ItemAddress( Idx1 );
AItem2 := ItemAddress( Idx2 );
{$ELSE}
AItem1 := Pointer( cardinal( fItems ) + cardinal(Idx1) * Sizeof( Pointer ) );
AItem2 := Pointer( cardinal( fItems ) + cardinal(Idx2) * Sizeof( Pointer ) );
{$ENDIF}
Tmp := AItem1^;
AItem1^ := AItem2^;
AItem2^ := Tmp;
end;
{$ENDIF ASM_VERSION}
//[procedure TList.SetCount]
procedure TList.SetCount(const Value: Integer);
begin
if Value >= Count then exit;
fCount := Value;
end;
//[procedure TList.Assign]
procedure TList.Assign(SrcList: PList);
{$IFDEF TLIST_FAST}
var i, CountCurrent: Integer;
SrcBlock, DstBlock: Pointer;
{$ENDIF}
begin
Clear;
if SrcList.fCount > 0 then
begin
{$IFDEF TLIST_FAST}
if SrcList.fUseBlocks and Assigned( SrcList.fBlockList ) then
begin
fBlockList := NewList;
fBlockList.Assign( SrcList.fBlockList );
for i := 0 to fBlockList.Count div 2 - 1 do
begin
SrcBlock := SrcList.fBlockList.fItems[ i*2 ];
CountCurrent := Integer( fBlockList.fItems[ i*2+1 ] );
GetMem( DstBlock, 256 * Sizeof( Pointer ) );
fBlockList.fItems[ i*2 ] := DstBlock;
move( SrcBlock^, DstBlock^, CountCurrent );
end;
end
else
{$ENDIF}
begin
Capacity := SrcList.fCount;
Move( SrcList.FItems[ 0 ], FItems[ 0 ], Sizeof( Pointer ) * SrcList.fCount );
end;
end;
fCount := SrcList.fCount;
end;
{$IFDEF WIN_GDI}
{ -- Window procedure -- }
function CallCtlWndProc_1( Ctl: PControl; var Msg: TMsg ): Integer;
begin
Result := Ctl.WndProc( Msg );
end;
(*
function WndFunc_asm( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
: Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
const size_TMsg = sizeof( TMsg );
asm
ADD ESP, -size_TMsg
MOV EDX, ESP
PUSH ESI
PUSH EDI
MOV EDI, EDX
LEA ESI, [W]
MOVSD
MOVSD
MOVSD
MOVSD
MOV EDI, EDX
MOV EAX, [EDI]
TEST EAX, EAX
JZ @@self_is_nil
MOV ECX, [CreatingWindow]
JECXZ @@get_self_prop
MOV [ECX].TControl.fHandle, EAX
PUSH ECX
PUSH ECX
{$IFDEF USE_PROP}
PUSH Offset[ID_SELF]
PUSH EAX
CALL SetProp
{$ELSE}
PUSH GWL_USERDATA
PUSH EAX
CALL SetWindowLong
{$ENDIF}
XOR EAX, EAX
MOV [CreatingWindow], EAX
POP EAX // EAX = self_
JMP @@self_got
@@get_self_prop:
{$IFDEF USE_PROP}
PUSH Offset[ID_SELF]
PUSH EAX
CALL GetProp
{$ELSE}
PUSH GWL_USERDATA
PUSH EAX
CALL GetWindowLong
{$ENDIF}
TEST EAX, EAX
JNZ @@self_got
@@self_is_nil:
OR EAX, [ Applet ]
JNZ @@self_got
POP EDI
POP ESI
MOV ESP, EBP
POP EBP
JMP DefWindowProc
@@self_got:
MOV ESI, EAX
INC [ESI].TControl.fNestedMsgHandling
MOV EDX, EDI
CALL CallCtlWndProc_1
DEC [ESI].TControl.fNestedMsgHandling
JG @@1
CMP [ESI].TControl.fBeginDestroying, 0
JZ @@1
CMP [ESI].TObj.fRefCount, 0
JNZ @@1
CMP ESI, [Applet]
JZ @@1
XCHG EAX, ESI
CALL TObj.RefDec
XCHG ESI, EAX
@@1:
POP EDI
POP ESI
MOV ESP, EBP
end;
*)
{$UNDEF ASM_LOCAL}
{$IFDEF ASM_noVERSION}
{$IFNDEF _D2orD3}
{$DEFINE ASM_LOCAL}
{$ENDIF}
{$ENDIF}
{$IFDEF ASM_LOCAL} //!!//!!
//[FUNCTION CallCtlWndProc]
function CallCtlWndProc( Ctl: PControl; var Msg: TMsg ): Integer;
begin
Result := Ctl.WndProc( Msg );
end;
//[END CallCtlWndProc]
//[function WndFunc]
function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
: Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
const size_TMsg = sizeof( TMsg );
asm
ADD ESP, -size_TMsg
MOV EDX, ESP
PUSH ESI
PUSH EDI
MOV EDI, EDX
LEA ESI, [W]
MOVSD
MOVSD
MOVSD
MOVSD
MOV EDI, EDX
MOV EAX, [EDI]
TEST EAX, EAX
JZ @@self_is_nil
MOV ECX, [CreatingWindow]
JECXZ @@get_self_prop
MOV [ECX].TControl.fHandle, EAX
PUSH ECX
PUSH ECX
{$IFDEF USE_PROP}
PUSH Offset[ID_SELF]
PUSH EAX
CALL SetProp
{$ELSE}
PUSH GWL_USERDATA
PUSH EAX
CALL SetWindowLong
{$ENDIF}
XOR EAX, EAX
MOV [CreatingWindow], EAX
POP EAX // EAX = self_
JMP @@self_got
@@get_self_prop:
{$IFDEF USE_PROP}
PUSH Offset[ID_SELF]
PUSH EAX
CALL GetProp
{$ELSE}
PUSH GWL_USERDATA
PUSH EAX
CALL GetWindowLong
{$ENDIF}
TEST EAX, EAX
JNZ @@self_got
@@self_is_nil:
OR EAX, [ Applet ]
JNZ @@self_got
POP EDI
POP ESI
MOV ESP, EBP
POP EBP
JMP DefWindowProc
@@self_got:
MOV ESI, EAX
INC [ESI].TControl.fNestedMsgHandling
MOV EDX, EDI
CALL CallCtlWndProc
DEC [ESI].TControl.fNestedMsgHandling
JA @@1
CMP [ESI].TControl.fBeginDestroying, 0
JZ @@1
CMP [ESI].TObj.fRefCount, 0
JNZ @@1
CMP ESI, [Applet]
JZ @@1
XCHG EAX, ESI
CALL TObj.Free
XCHG ESI, EAX
@@1:
POP EDI
POP ESI
MOV ESP, EBP
end;
{$ELSE ASM_VERSION} //Pascal
function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
: Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
var M: TMsg;
self_: PControl;
begin
{if (Msg >= $BD33) and (Msg <= $BD33) then
begin
Result := WndFunc_asm( W, Msg, wParam, lParam );
Exit;
end;}
{$IFDEF INPACKAGE}
Log( '->WndFunc ' + Int2Hex( Msg, 4 ) + ' (' + Int2Str( Msg ) + ')' );
TRY
{$ENDIF INPACKAGE}
M.hwnd := W;
M.message := Msg;
M.wParam := wParam;
M.lParam := lParam;
{$IFDEF DEBUG_ENDSESSION}
if EndSession_Initiated then
begin
LogFileOutput( GetStartDir + 'es_debug.txt',
'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) +
' WParam: ' + Int2Str( wParam ) + '($' + Int2Hex( wParam, 8 ) + ')' +
' LParam: ' + Int2Str( lParam ) + '($' + Int2Hex( lParam, 8 ) + ')' );
end;
{$ENDIF}
self_ := nil;
if W <> 0 then
begin
if CreatingWindow <> nil then
begin
{$IFDEF INPACKAGE}
Log( '//// CreatingWindow <> nil' );
{$ENDIF INPACKAGE}
{$IFDEF DEBUG_CREATEWINDOW}
LogFileOutput( GetStartDir + 'Session.log',
'WndFunc: Creating window = ' + Int2Hex( Integer( CreatingWindow ), 4 ) +
' hwnd=' + Int2Str( M.hwnd ) +
' message=' + Int2Hex( M.message, 4 ) +
' wParam=' + Int2Str( M.wParam ) + '=$' + Int2Hex( M.wParam, 4 ) +
' lParam=' + Int2Str( M.lParam ) + '=$' + Int2Hex( M.lParam, 4 )
);
{$ENDIF DEBUG_CREATEWINDOW}
self_ := CreatingWindow;
CreatingWindow.fHandle := W;
{$IFDEF USE_PROP}
{$IFDEF INPACKAGE}
Log( '//// SetProp' );
{$ENDIF INPACKAGE}
SetProp( W, ID_SELF, THandle( CreatingWindow ) );
{$ELSE}
SetWindowLong( W, GWL_USERDATA, Integer( CreatingWindow ) );
{$ENDIF}
CreatingWindow := nil;
end
else
{$IFDEF USE_PROP}
self_ := Pointer( GetProp( W, ID_SELF ) );
{$ELSE}
self_ := Pointer( GetWindowLong( W, GWL_USERDATA ) );
{$ENDIF}
end;
if self_ <> nil then
begin
{$IFDEF INPACKAGE}
Log( '//// self_ <> nil, calling self_.WndProc' );
{$ENDIF INPACKAGE}
inc( self_.fNestedMsgHandling );
Result := self_.WndProc( M );
dec( self_.fNestedMsgHandling );
if (self_.RefCount = 0) and (self_.fNestedMsgHandling <= 0) and
self_.fBeginDestroying and (self_ <> Applet) then
self_.Free;
end
else
if Assigned( Applet ) then
Result := Applet.WndProc( M )
else
Result := DefWindowProc( W, Msg, wParam, lParam );
{$IFDEF DEBUG_ENDSESSION}
if EndSession_Initiated then
begin
LogFileOutput( GetStartDir + 'es_debug.txt',
'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) +
' Result: ' + Int2Str( Result ) + '($' + Int2Hex( Result, 8 ) + ')' );
end;
{$ENDIF}
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-WndFunc' );
END;
{$ENDIF INPACKAGE}
end;
//[END WndFunc]
{$ENDIF ASM_VERSION}
{$IFDEF USE_OnIdle}
var
IdleHandlers: PList;
ProcessIdle: procedure ( Sender: PObj ) = DummyObjProc;
//[procedure ProcessIdleProc]
procedure ProcessIdleProc( Sender: PObj );
var
i: integer;
m: TMethod;
begin
if AppletTerminated then exit; // YS +
i := 0;
with IdleHandlers{-}^{+} do
while i < Count do begin
m.Code:=Items[i];
Inc(i);
m.Data:=Items[i];
Inc(i);
TOnEvent(m)(Sender);
end;
end;
//[function FindIdleHandler]
function FindIdleHandler( const OnIdle: TOnEvent ): integer;
var
i: integer;
begin
i := 0;
if not AppletTerminated then //+ {Maxim Pushkar}
with TMethod(OnIdle), IdleHandlers{-}^{+} do
while i < Count do begin
if (Items[i] = Code) and (Items[i + 1] = Data) then
begin
Result := i;
exit;
end;
Inc(i, 2);
end;
Result := -1;
end;
//[END FindIdleHandler]
//[procedure RegisterIdleHandler]
procedure RegisterIdleHandler( const OnIdle: TOnEvent );
begin
if AppletTerminated then exit;
if IdleHandlers = nil then begin
IdleHandlers := NewList;
if Applet <> nil then
Applet.Add2AutoFree(IdleHandlers);
end;
with TMethod(OnIdle) do
begin
IdleHandlers.Add(Code);
IdleHandlers.Add(Data);
end;
ProcessIdle := @ProcessIdleProc;
end;
//[procedure UnRegisterIdleHandler]
procedure UnRegisterIdleHandler( const OnIdle: TOnEvent );
var
i: integer;
begin
i := FindIdleHandler(OnIdle);
if i <> -1 then
with IdleHandlers{-}^{+} do
begin
Delete(i);
Delete(i);
end;
end;
{$ENDIF USE_OnIdle}
{$IFDEF GDI}
//[procedure TerminateExecution]
{$IFDEF ASM_noVERSION}
procedure TerminateExecution( var AppletWnd: PControl );
asm
PUSH EBX
PUSH ESI
MOV BX, $0100
XCHG BX, word ptr [AppletRunning]
XOR ECX, ECX
XCHG ECX, [Applet]
JECXZ @@exit
PUSH EAX
XCHG EAX, ECX
MOV ESI, EAX
CALL TObj.RefInc
TEST BH, BH
JE @@closed
MOV EAX, ESI
CALL TControl.ProcessMessages
PUSH 0
PUSH 0
PUSH WM_CLOSE
PUSH ESI
CALL TControl.Perform
@@closed:
POP EAX
XOR ECX, ECX
MOV dword ptr [EAX], ECX
MOV EAX, ESI
CALL TObj.Free
XCHG EAX, ESI
CALL TObj.RefDec
@@exit:
POP ESI
POP EBX
end;
{$ELSE ASM_VERSION}
procedure TerminateExecution( var AppletWnd: PControl );
var App: PControl;
Appalreadyterminated: Boolean;
begin
Appalreadyterminated := AppletTerminated;
AppletTerminated := TRUE;
AppletRunning := FALSE;
App := Applet;
Applet := nil;
if (App <> nil) {and (App.RefCount >= 0)} then
begin
App.RefInc;
if not Appalreadyterminated then
begin
App.ProcessMessages;
App.Perform( WM_CLOSE, 0, 0 );
end;
AppletWnd := nil;
App.Free;
App.RefDec;
end;
end;
{$ENDIF ASM_VERSION}
//[PROCEDURE CallTControlCreateWindow]
procedure CallTControlCreateWindow( Ctl: PControl );
begin
{$IFDEF SAFE_CODE}
TRY
if Ctl = nil then Exit;
Ctl.CreateWindow;
EXCEPT
asm
nop
end;
END;
{$ELSE}
Ctl.CreateWindow;
{$ENDIF}
end;
//[END CallTControlCreateWindow]
{$ENDIF GDI}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
//[PROCEDURE Run]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure Run( var AppletWnd: PControl );
{$IFDEF PSEUDO_THREADS}
var n: Integer;
i: Integer;
T: PThread;
u: DWORD;
M: TMsg;
{$ENDIF}
begin
AppletRunning := True;
Applet := AppletWnd;
AppletWnd.CreateWindow; //virtual!!!
while not AppletTerminated do
begin
{$ifdef wince}
AppletWnd.WaitAndProcessMessages;
{$else}
{$IFDEF PSEUDO_THREADS}
if Assigned( MainThread ) then
begin
while not PeekMessage( M, 0, 0, 0, pm_noremove ) do
begin
u := GetTickCount;
n := 0;
for i := 1 to MainThread.AllThreads.Count-1 do
begin
T := MainThread.AllThreads.Items[ i ];
if not T.Suspended and not T.Terminated and (T.DoNotWakeUntil < u) then
begin
inc( n );
break;
end;
end;
if n = 0 then WaitMessage
else MainThread.NextThread;
end;
end
else
WaitMessage;
{$ELSE}
WaitMessage;
{$ENDIF}
AppletWnd.ProcessMessages;
{$endif wince}
{$IFDEF USE_OnIdle}
ProcessIdle( AppletWnd );
{$ENDIF}
end;
if AppletWnd <> nil then
TerminateExecution( AppletWnd );
end;
//[END Run]
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure Run( var AppletWnd: PControl );
begin
AppletRunning := True;
Applet := AppletWnd;
AppletWnd.VisualizyWindow; // for GTK, show all windows having Visible = TRUE, recursively
gtk_main( );
if AppletWnd <> nil then
//TerminateExecution( AppletWnd );
Free_And_Nil( AppletWnd );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
{$IFDEF GDI}
//[procedure AppletMinimize]
procedure AppletMinimize;
begin
if Applet = nil then Exit;
Applet.Perform( WM_SYSCOMMAND, SC_MINIMIZE, 0 );
end;
//[procedure AppletHide]
procedure AppletHide;
begin
if Applet = nil then Exit;
AppletMinimize;
Applet.Hide;
end;
//[procedure AppletRestore]
procedure AppletRestore;
begin
if Applet = nil then Exit;
Applet.Show;
Applet.Perform( WM_SYSCOMMAND, SC_RESTORE, 0 );
end;
//[function ScreenWidth]
function ScreenWidth: Integer;
begin
Result := GetSystemMetrics( SM_CXSCREEN );
end;
//[END ScreenWidth]
//[function ScreenHeight]
function ScreenHeight: Integer;
begin
Result := GetSystemMetrics( SM_CYSCREEN );
end;
//[END ScreenHeight]
{$ENDIF GDI}
//[WndProcXXX FORWARD DECLARATIONS]
{$IFDEF ASM_VERSION}
function WndProcAppAsm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
{$ELSE}
function WndProcAppPas( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
{$ENDIF ASM_VERSION}
function WndProcForm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
var fGlobalProcKeybd: function( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean =
WndProcDummy;
//[END OF WndProcXXX FORWARD DECLARATIONS]
{ -- Graphics support -- }
{$ENDIF WIN_GDI}
//[function _NewGraphicTool]
function _NewGraphicTool: PGraphicTool;
begin
{-}
New( Result, Create );
{+}
{++}(*Result := PGraphicTool.Create;*){--}
end;
//[END _NewGraphicTool]
{$IFDEF WIN_GDI}
//[FUNCTION SimpleGetCtlBrushHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION PAS_VERSION}
function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush;
begin
if (Sender.fParent <> nil) and (Sender.fColor = Sender.fParent.fColor) then
Result := SimpleGetCtlBrushHandle( Sender.fParent )
else
begin
{$IFDEF GDI}
if (Sender.fTmpBrush <> 0) and
(Color2RGB( Sender.fColor ) <> Sender.fTmpBrushColorRGB) then
begin
DeleteObject( Sender.fTmpBrush );
Sender.fTmpBrush := 0;
end;
if Sender.fTmpBrush = 0 then
begin
Sender.fTmpBrushColorRGB := Color2RGB( Sender.fColor );
Sender.fTmpBrush := CreateSolidBrush( Sender.fTmpBrushColorRGB );
end;
Result := Sender.fTmpBrush;
{$ELSE} Result := 0;
{$ENDIF GDI}
end;
end;
{$ENDIF ASM_VERSION}
//[END SimpleGetCtlBrushHandle]
//[function NormalGetCtlBrushHandle]
function NormalGetCtlBrushHandle( Sender: PControl ): HBrush;
begin
{$IFDEF GDI}
if (Sender.fParent <> nil) and (Sender.fParent.fColor <> Sender.fColor) then
Sender.Brush.fParentGDITool := Sender.fParent.Brush;
Result := Sender.Brush.Handle;
{$ELSE} Result := 0;
{$ENDIF GDI}
end;
//[END NormalGetCtlBrushHandle]
{++}(*
//[API CreateFontIndirect]
function CreateFontIndirect(const p1: TLogFont): HFONT; {$ifdef wince}cdecl{$else}stdcall{$endif};
external gdi32 name 'CreateFontIndirectA';
*){--}
//[MakeXXXHandle FORWARD DECLARATIONS]
function MakeFontHandle( Self_: PGraphicTool ): THandle; forward;
function MakeBrushHandle( Self_: PGraphicTool ): THandle; forward;
function MakePenHandle( Self_: PGraphicTool ): THandle; forward;
function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle; forward;
//[END OF MakeXXXHandle FORWARD DECLARATIONS]
{$ENDIF WIN_GDI}
//[FUNCTION NewBrush]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewBrush: PGraphicTool;
begin
{$IFDEF GDI}
Global_GetCtlBrushHandle := NormalGetCtlBrushHandle;
{$ENDIF GDI}
Result := _NewGraphicTool;
with Result {-}^{+} do
begin
fNewProc := @ NewBrush;
fType := gttBrush;
{$IFDEF GDI}
fMakeHandleProc := @ MakeBrushHandle;
{$ENDIF GDI}
Result.fData.Color := {$ifdef wince}clWindow{$else}clBtnFace{$endif};
Result.fData.Brush.Style := bsSolid;
end;
end;
{$ENDIF ASM_VERSION}
//[END NewBrush]
//[FUNCTION NewPen]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewPen: PGraphicTool;
begin
Result := _NewGraphicTool;
with Result{-}^{+} do
begin
fNewProc := @ NewPen;
fType := gttPen;
{$IFDEF GDI}
fMakeHandleProc := @ MakePenHandle;
{$ENDIF GDI}
fData.Pen.Mode := pmCopy;
end;
end;
{$ENDIF ASM_VERSION}
//[END NewPen]
var ApplyFont2Wnd_Proc: procedure( _Self: PControl ) = nil;
procedure DoApplyFont2Wnd( _Self: PControl ); forward;
const size_FontData = sizeof( Integer {fFontHeight} ) + sizeof( Integer {fFontWidth} ) +
sizeof( TFontPitch ) + sizeof( TFontStyle ) +
sizeof( Integer {fFontOrientation} ) +
sizeof( Integer {fFontWeight} ) + sizeof( TFontCharset ) +
sizeof( TFontQuality );
//[FUNCTION NewFont]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewFont: PGraphicTool;
begin
ApplyFont2Wnd_Proc := @ DoApplyFont2Wnd;
Result := _NewGraphicTool;
with Result {-}^{+} do
begin
fNewProc := @ NewFont;
fType := gttFont;
{$IFDEF GDI}
fMakeHandleProc := @ MakeFontHandle;
fData.Color := DefFontColor;
Move( DefFont, fData.Font, Sizeof( TGDIFont ) );
{$ENDIF GDI}
{$IFDEF GTK}
fData.Font.Weight := 400;
{$ENDIF GTK}
end;
end;
{$ENDIF ASM_VERSION}
//[END NewFont]
//[function Color2RGB]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION}
function Color2RGB( Color: TColor ): TColor;
begin
if Color < 0 then
Result := GetSysColor(Color and $7FFFFFFF) else
Result := Color;
end;
{$ENDIF ASM_VERSION}
//[END Color2RGB]
function RGB2BGR( Color: TColor ): TColor;
begin
Result := ((Color shr 16) or (Color shl 16) or Color and $00FF00)
and $FFFFFF;
end;
//[function ColorsMix]
{$IFDEF ASM_VERSION}
function ColorsMix( Color1, Color2: TColor ): TColor;
asm
PUSH EDX
CALL Color2Rgb
XCHG EAX, [ESP]
CALL Color2Rgb
POP EDX
AND EAX, 0FEFEFEh
AND EDX, 0FEFEFEh
SHR EAX, 1
SHR EDX, 1
ADD EAX, EDX
end;
{$ELSE ASM_VERSION} //Pascal
function ColorsMix( Color1, Color2: TColor ): TColor;
begin
Result := ((Color2RGB( Color1 ) and $FEFEFE) shr 1) +
((Color2RGB( Color2 ) and $FEFEFE) shr 1);
end;
{$ENDIF ASM_VERSION}
//[END ColorsMix]
{$IFDEF WIN_GDI}
//[FUNCTION Color2RGBQuad]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Color2RGBQuad( Color: TColor ): TRGBQuad;
var C: Integer;
begin
C := Color2RGB( Color );
C := ((C shr 16) and $FF)
or ((C shl 16) and $FF0000)
or (C and $FF00);
Result := TRGBQuad( C );
end;
{$ENDIF ASM_VERSION}
//[END Color2RGBQuad]
//[FUNCTION Color2Color16]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION}
function Color2Color16( Color: TColor ): WORD;
begin
Color := Color2RGB( Color );
Result := (Color shr 19) and $1F or
(Color shr 5) and $7E0 or
(Color shl 8) and $F800;
end;
{$ENDIF ASM_VERSION}
//[END Color2Color16]
//[FUNCTION Color2Color15]
function Color2Color15( Color: TColor ): WORD;
begin
Color := Color2RGB( Color );
Result := (Color shr 19) and $1F or
(Color shr 6) and $3E0 or
(Color shl 7) and $7C00;
end;
//[END Color2Color15]
{$ENDIF WIN_GDI}
{ TGraphicTool }
//[function TGraphicTool.Assign]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION}
function TGraphicTool.Assign(Value: PGraphicTool): PGraphicTool;
var _Self: PGraphicTool;
begin
Result := nil;
if Value = nil then
begin
{$IFDEF OLD_REFCOUNT}
if @Self <> nil then
DoDestroy;
{$ELSE}
Free;
{$ENDIF}
Exit;
end;
_Self := @Self;
if _Self = nil then
_Self := Value.fNewProc();
Result := _Self;
if _Self = Value then Exit; // to avoid infinite loop when assigning to itself
{$IFDEF GDI}
if _Self.fHandle <> 0 then
if Value.fHandle = _Self.fHandle then Exit;
{$ENDIF GDI}
_Self.Changed; // to destroy handle if allocated and release it from the canvas (if any uses it)
Assert( Value.fType = _Self.fType, 'Attempt to assign to different GDI tool type' );
Move( Value.fData, _Self.fData, Sizeof( fData ) );
_Self.Changed; // to inform owner control, that its tool (font, brush) changed
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[procedure TGraphicTool.AssignHandle]
procedure TGraphicTool.AssignHandle(NewHandle: Integer);
begin
if fHandle <> 0 then //
DeleteObject( fHandle ); //
fHandle := NewHandle;
GetObject( fHandle, Sizeof( TGDIFont ), @ fData.Font );
Changed;
end;
{$ENDIF WIN_GDI}
//[procedure TGraphicTool.Changed]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TGraphicTool.Changed;
{$IFDEF GDI} var H: THandle; {$ENDIF GDI}
begin
{$IFDEF GDI}
H := 0;
if fHandle <> 0 then
begin
H := fHandle;
fHandle := 0;
end;
////////////////////////////////
if Assigned( fOnChange ) then
fOnChange( @Self );
////////////////////////////////
if H <> 0 then
begin
DeleteObject( H );
{$IFDEF DEBUG_GDIOBJECTS}
case fType of
gttBrush: Dec( BrushCount );
gttFont: Dec( FontCount );
gttPen: Dec( PenCount );
end;
{$ENDIF}
end;
{$ENDIF GDI}
{$IFDEF GTK}
if Assigned( fPangoFontDesc ) then
begin
pango_font_description_free( fPangoFontDesc );
fPangoFontDesc := nil;
end;
if Assigned( fOnChange ) then
fOnChange( @Self );
{$ENDIF GTK}
end;
{$ENDIF ASM_VERSION}
//[destructor TGraphicTool.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TGraphicTool.Destroy;
begin
{$IFDEF GDI}
case fType of
gttBrush: if fData.Brush.Bitmap <> 0 then
DeleteObject( fData.Brush.Bitmap );
gttPen: if fData.Pen.BrushBitmap <> 0 then
DeleteObject( fData.Pen.BrushBitmap )
end;
if fHandle <> 0 then
begin
DeleteObject( fHandle );
{$IFDEF DEBUG_GDIOBJECTS}
case fType of
gttPen: Dec( PenCount );
gttBrush: Dec( BrushCount );
gttFont: Dec( FontCount );
end;
{$ENDIF}
//fHandle := 0; Why to do this? It is now destroying!
end;
{$ENDIF GDI}
inherited;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[function TGraphicTool.HandleAllocated]
function TGraphicTool.HandleAllocated: Boolean;
begin
Result := fHandle <> 0;
end;
//[function TGraphicTool.ReleaseHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION PAS_VERSION}
function TGraphicTool.ReleaseHandle: Integer;
begin
Changed;
Result := fHandle;
fHandle := 0;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[procedure TGraphicTool.SetInt]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TGraphicTool.SetInt( const Index: Integer; Value: Integer );
var Where: PInteger;
begin
Where := Pointer( cardinal( @ fData ) + cardinal(Index) );
if {$ifdef wince}unaligned{$endif}(Where^) = Value then Exit;
{$ifdef wince}unaligned({$endif}Where^{$ifdef wince}){$endif} := Value;
Changed;
end;
{$ENDIF ASM_VERSION}
//[function TGraphicTool.GetInt]
function TGraphicTool.GetInt(const Index: Integer): Integer;
var Where: PInteger;
begin
Where := Pointer( cardinal( @ fData ) + cardinal(Index) );
Result := Where^;
end;
{$IFDEF WIN_GDI}
{$ENDIF WIN_GDI}
//[procedure TGraphicTool.SetColor]
procedure TGraphicTool.SetColor( Value: TColor );
begin
SetInt( go_Color, Value );
fColorRGB := Color2RGB( Value );
end;
{$IFDEF WIN_GDI}
//[function TGraphicTool.IsFontTrueType]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
{$ifdef wince}
function TGraphicTool.IsFontTrueType: Boolean;
begin
Result:=True;
end;
{$else}
function TGraphicTool.IsFontTrueType: Boolean;
var OldFont: HFont;
DC: HDC;
begin
Result := False;
if GetHandle = 0 then Exit;
DC := GetDC( 0 );
OldFont := SelectObject( DC, fHandle );
if GetFontData( DC, 0, 0, nil, 0 ) <> GDI_ERROR then
Result := True;
SelectObject( DC, OldFont );
ReleaseDC( 0, DC );
end;
{$endif wince}
{$ENDIF ASM_VERSION}
//[function TGraphicTool.GetBrushBitmap]
function TGraphicTool.GetBrushBitmap: HBitmap;
begin
Result := fData.Brush.Bitmap; // for BCB only
end;
//[procedure TGraphicTool.SetBrushBitmap]
procedure TGraphicTool.SetBrushBitmap(const Value: HBitmap);
begin
if fData.Brush.Bitmap = Value then Exit;
if fData.Brush.Bitmap <> 0 then
begin
Changed; // !!!
DeleteObject( fData.Brush.Bitmap );
end;
fData.Brush.Bitmap := Value;
Changed;
end;
//[function TGraphicTool.GetBrushStyle]
function TGraphicTool.GetBrushStyle: TBrushStyle;
begin
Result := fData.Brush.Style; // for BCB only
end;
{$ENDIF WIN_GDI}
//[procedure TGraphicTool.SetBrushStyle]
procedure TGraphicTool.SetBrushStyle(const Value: TBrushStyle);
begin
if fData.Brush.Style = Value then Exit;
fData.Brush.Style := Value;
Changed;
end;
{$IFDEF WIN_GDI}
//[function TGraphicTool.GetFontCharset]
function TGraphicTool.GetFontCharset: TFontCharset;
begin
Result := fData.Font.CharSet; // for BCB only
end;
//[procedure TGraphicTool.SetFontCharset]
procedure TGraphicTool.SetFontCharset(const Value: TFontCharset);
begin
if fData.Font.Charset = Value then Exit;
fData.Font.Charset := Value;
Changed;
end;
//[function TGraphicTool.GetFontQuality]
function TGraphicTool.GetFontQuality: TFontQuality;
begin
Result := fData.Font.Quality; // for BCB only
end;
//[procedure TGraphicTool.SetFontQuality]
procedure TGraphicTool.SetFontQuality(const Value: TFontQuality);
begin
if fData.Font.Quality = Value then Exit;
fData.Font.Quality := Value;
Changed;
end;
{$ENDIF WIN_GDI}
//[function TGraphicTool.GetFontName]
function TGraphicTool.GetFontName: KOLString;
begin
Result := fData.Font.Name;
{$IFDEF GTK}
if Result = '' then
Result := 'Sans Serif';
{$ENDIF GTK}
end;
//[procedure TGraphicTool.SetFontName]
procedure TGraphicTool.SetFontName(const Value: KOLString);
begin
if fData.Font.Name = Value then Exit;
FillChar( fData.Font.Name[ 0 ], LF_FACESIZE, #0 );
{$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
( fData.Font.Name, PKOLChar( Value ), LF_FACESIZE );
Changed;
end;
{$IFDEF WIN_GDI}
//[procedure TextAreaEx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TextAreaEx( Sender: PCanvas; var Sz : TSize; var Pt : TPoint );
var Orient : Integer;
Pts : array[ 1..4 ] of TPoint;
MinX, MinY, I : Integer;
A : Double;
begin
if not Sender.Font.IsFontTrueType then Exit;
Orient := Sender.Font.FontOrientation;
Pt.x := 0; Pt.y := 0;
if Orient = 0 then
Exit;
A := Orient / 1800.0 * PI;
Pts[ 1 ] := Pt;
Pts[ 2 ].x := Round( Sz.cx * cos( A ) );
Pts[ 2 ].y := - Round( Sz.cx * sin( A ) );
Pts[ 4 ].x := - Round( Sz.cy * cos( A + PI / 2 ) );
Pts[ 4 ].y := Round( Sz.cy * sin( A + PI / 2 ) );
Pts[ 3 ].x := Pts[ 2 ].x + Pts[ 4 ].x;
Pts[ 3 ].y := Pts[ 2 ].y + Pts[ 4 ].y;
MinX := 0; MinY := 0;
for I := 2 to 4 do
begin
if Pts[ I ].x < MinX then
MinX := Pts[ I ].x;
if Pts[ I ].y < MinY then
MinY := Pts[ I ].y;
end;
Sz.cx := 0;
Sz.cy := 0;
for I := 1 to 4 do
begin
Pts[ I ].x := Pts[ I ].x - MinX;
Pts[ I ].y := Pts[ I ].y - MinY;
if Pts[ I ].x > Sz.cx then
Sz.cx := Pts[ I ].x;
if Pts[ I ].y > Sz.cy then
Sz.cy := Pts[ I ].y;
end;
Pt := Pts[ 1 ];
end;
{$ENDIF ASM_VERSION}
//[function TGraphicTool.GetFontOrientation]
function TGraphicTool.GetFontOrientation: Integer;
begin
Result := fData.Font.Orientation; // for BCB only
end;
//[procedure TGraphicTool.SetFontOrientation]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TGraphicTool.SetFontOrientation(Value: Integer);
begin
GlobalGraphics_UseFontOrient := True;
GlobalCanvas_OnTextArea := TextAreaEx;
Value := Value mod 3600; // -3599..+3599
SetInt( go_FontOrientation, Value );
SetInt( go_FontEscapement, Value );
end;
{$ENDIF ASM_VERSION}
//[function TGraphicTool.GetFontPitch]
function TGraphicTool.GetFontPitch: TFontPitch;
begin
Result := fData.Font.Pitch; // for BCB only
end;
//[procedure TGraphicTool.SetFontPitch]
procedure TGraphicTool.SetFontPitch(const Value: TFontPitch);
begin
if fData.Font.Pitch = Value then Exit;
fData.Font.Pitch := Value;
Changed;
end;
{$ENDIF WIN_GDI}
//[function TGraphicTool.GetFontStyle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TGraphicTool.GetFontStyle: TFontStyle;
type PFontStyle = ^TFontStyle;
begin
Result := [ ];
if fData.Font.Weight >= 700 then Result := [ fsBold ];
if fData.Font.Italic then Result := Result + [ fsItalic ];
if fData.Font.Underline then Result := Result + [ fsUnderline ];
if fData.Font.StrikeOut then Result := Result + [ fsStrikeOut ];
end;
{$ENDIF ASM_VERSION}
//[procedure TGraphicTool.SetFontStyle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TGraphicTool.SetFontStyle(const Value: TFontStyle);
begin
if FontStyle = Value then Exit;
if fsBold in Value then
begin
if fData.Font.Weight < 700 then
fData.Font.Weight := 700;
end
else
begin
if fData.Font.Weight >= 700 then
fData.Font.Weight := 0;
end;
fData.Font.Italic := fsItalic in Value;
fData.Font.Underline := fsUnderline in Value;
fData.Font.StrikeOut := fsStrikeOut in Value;
Changed;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[function TGraphicTool.GetPenMode]
function TGraphicTool.GetPenMode: TPenMode;
begin
Result := fData.Pen.Mode; // for BCB only
end;
//[procedure TGraphicTool.SetPenMode]
procedure TGraphicTool.SetPenMode(const Value: TPenMode);
begin
if fData.Pen.Mode = Value then Exit;
fData.Pen.Mode := Value;
Changed;
end;
//[function TGraphicTool.GetPenStyle]
function TGraphicTool.GetPenStyle: TPenStyle;
begin
Result := fData.Pen.Style; // for BCB only
end;
//[procedure TGraphicTool.SetPenStyle]
procedure TGraphicTool.SetPenStyle(const Value: TPenStyle);
begin
if fData.Pen.Style = Value then Exit;
fData.Pen.Style := Value;
Changed;
end;
//[function TGraphicTool.GetHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TGraphicTool.GetHandle: THandle;
begin
Result := fHandle;
if Result <> 0 then
begin
if Color2RGB( fData.Color ) <> fColorRGB then
begin
DeleteObject( ReleaseHandle );
Result := 0;
end;
end;
if Result = 0 then
begin
if Assigned( fParentGDITool ) then
begin
if CompareMem( @ fData, @ fParentGDITool.fData, Sizeof( fData ) ) then
begin
Result := fParentGDITool.Handle;
Exit;
end;
end;
fColorRGB := Color2RGB( fData.Color );
fMakeHandleProc( @Self );
Result := fHandle;
end;
end;
{$ENDIF ASM_VERSION}
//[FUNCTION MakeBrushHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function MakeBrushHandle( Self_: PGraphicTool ): THandle;
{$ifndef wince}
var
LogBrush: TLogBrush;
{$endif wince}
begin
if Self_.fHandle = 0 then
begin
{$ifdef wince}
Self_.fHandle := CreateSolidBrush(Color2RGB( Self_.fData.Color ));
{$else}
LogBrush.lbColor := Color2RGB( Self_.fData.Color );
if Self_.fData.Brush.Bitmap <> 0 then
begin
LogBrush.lbStyle := BS_PATTERN;
LogBrush.lbHatch := Self_.fData.Brush.Bitmap;
end
else
begin
LogBrush.lbHatch := 0;
case Self_.fData.Brush.Style of
bsSolid: LogBrush.lbStyle := BS_SOLID;
bsClear: LogBrush.lbStyle := BS_NULL;
else
LogBrush.lbStyle := BS_HATCHED;
LogBrush.lbHatch := Ord( Self_.fData.Brush.Style ) - Ord( bsHorizontal );
LogBrush.lbColor := Color2RGB( Self_.fData.Brush.LineColor );
end;
end;
Self_.fHandle := CreateBrushIndirect(LogBrush);
{$endif wince}
{$IFDEF DEBUG_GDIOBJECTS}
if Self_.fHandle <> 0 then
Inc( BrushCount )
else
ShowMessage( 'Could not create brush, error ' + Int2Str( GetLastError ) +
': ' + SysErrorMessage( GetLastError ) );
{$ENDIF}
end;
Result := Self_.fHandle;
end;
{$ENDIF ASM_VERSION}
//[END MakeBrushHandle]
{$UNDEF ASM_LOCAL}
{$IFNDEF UNICODE_CTRLS}
{$IFDEF ASM_VERSION}
{$IFNDEF AUTO_REPLACE_CLEARTYPE}
{$DEFINE ASM_LOCAL}
{$ENDIF AUTO_REPLACE_CLEARTYPE}
{$ENDIF ASM_VERSION}
{$ENDIF}
//[FUNCTION MakeFontHandle]
{$IFDEF ASM_LOCAL}
{$ELSE ASM_VERSION} //Pascal
function MakeFontHandle( Self_: PGraphicTool ): THandle;
{$IFDEF AUTO_REPLACE_CLEARTYPE}
var LF: TLogFont;
{$ENDIF}
begin
with Self_{-}^{+} do
begin
if fHandle = 0 then
begin
{$IFDEF AUTO_REPLACE_CLEARTYPE}
Move( fData.Font, LF, Sizeof( LF ) );
if WinVer < wvXP then
begin
if LF.lfQuality > ANTIALIASED_QUALITY then
LF.lfQuality := ANTIALIASED_QUALITY;
end;
fHandle := CreateFontIndirect( LF );
{$ELSE}
fHandle := CreateFontIndirect( PLogFont( @ fData.Font )^ );
{$ENDIF}
{$IFDEF DEBUG_GDIOBJECTS}
Inc( FontCount );
{$ENDIF}
end;
Result := fHandle;
end;
end;
{$ENDIF ASM_VERSION}
//[END MakeFontHandle]
//[FUNCTION MakePenHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function MakePenHandle( Self_: PGraphicTool ): THandle;
var
LogPen: TLogPen;
begin
with Self_{-}^{+} do
begin
//GlobalGraphics_OnObjectCreating( @Self );
if fHandle = 0 then
with LogPen do
begin
lopnStyle := Byte( fData.Pen.Style );
lopnWidth.X := fData.Pen.Width;
lopnColor := Color2RGB( fData.Color );
fHandle := CreatePenIndirect( LogPen );
{$IFDEF DEBUG_GDIOBJECTS}
Inc( PenCount );
{$ENDIF}
end;
//GlobalGraphics_OnObjectCreated( @Self );
Result := fHandle;
end;
end;
{$ENDIF ASM_VERSION}
//[END MakePenHandle]
//+
//[function GetGeometricPen]
function TGraphicTool.GetGeometricPen: Boolean;
begin
Result := fData.Pen.Geometric; // for BCB only
end;
//[procedure TGraphicTool.SetGeometricPen]
procedure TGraphicTool.SetGeometricPen(const Value: Boolean);
begin
if fData.Pen.Geometric = Value then Exit;
fData.Pen.Geometric := Value;
fMakeHandleProc := MakeGeometricPenHandle;
Changed;
end;
//[function TGraphicTool.GetPenEndCap]
function TGraphicTool.GetPenEndCap: TPenEndCap;
begin
Result := fData.Pen.EndCap; // for BCB only
end;
//[procedure TGraphicTool.SetPenEndCap]
procedure TGraphicTool.SetPenEndCap(const Value: TPenEndCap);
begin
if fData.Pen.EndCap = Value then Exit;
fData.Pen.EndCap := Value;
Changed;
end;
//[function TGraphicTool.GetPenJoin]
function TGraphicTool.GetPenJoin: TPenJoin;
begin
Result := fData.Pen.Join; // for BCB only
end;
//[procedure TGraphicTool.SetPenJoin]
procedure TGraphicTool.SetPenJoin(const Value: TPenJoin);
begin
if fData.Pen.Join = Value then Exit;
fData.Pen.Join := Value;
Changed;
end;
//[FUNCTION MakeGeometricPenHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle;
{$ifndef wince}
const
PenEndCapStyles: array[ TPenEndCap ] of Word =
(PS_ENDCAP_ROUND, PS_ENDCAP_SQUARE, PS_ENDCAP_FLAT);
PenJoinStyles: array[ TPenJoin ] of Word =
(PS_JOIN_ROUND, PS_JOIN_BEVEL, PS_JOIN_MITER );
var
LogBrush: TLogBrush;
{$endif wince}
begin
if Self_.fHandle = 0 then
{$ifdef wince}
Self_.fHandle := CreatePen(Byte( Self_.fData.Pen.Style ), Self_.fData.Pen.Width, Color2RGB( Self_.fData.Color ));
{$else}
with Self_{-}^{+}, LogBrush do
begin
lbColor := Color2RGB( fData.Color );
lbHatch := 0;
if fData.Pen.BrushBitmap <> 0 then
begin
lbStyle := BS_PATTERN;
lbHatch := fData.Pen.BrushBitmap;
end
else
case fData.Pen.BrushStyle of
bsSolid: lbStyle := BS_SOLID;
bsClear: lbStyle := BS_NULL;
else begin
lbStyle := BS_HATCHED;
case fData.Pen.BrushStyle of
bsHorizontal: lbHatch := HS_HORIZONTAL;
bsVertical: lbHatch := HS_VERTICAL;
bsFDiagonal: lbHatch := HS_FDIAGONAL;
bsBDiagonal: lbHatch := HS_BDIAGONAL;
bsCross: lbHatch := HS_CROSS;
bsDiagCross: lbHatch := HS_DIAGCROSS;
end;
end;
end;
Self_.fHandle := ExtCreatePen( PS_GEOMETRIC or Byte( Self_.fData.Pen.Style ) or
PenEndCapStyles[ Self_.fData.Pen.EndCap ] or
PenJoinStyles[ Self_.fData.Pen.Join ],
Self_.fData.Pen.Width, LogBrush, 0, nil );
{Assert( Self_.fHandle <> 0, 'Error ' + Int2Str( GetLastError ) +
': ' + SysErrorMessage( GetLastError ) );}
end;
{$endif wince}
{$IFDEF DEBUG_GDIOBJECTS}
Inc( PenCount );
{$ENDIF}
Result := Self_.fHandle;
end;
{$ENDIF ASM_VERSION}
//[END MakeGeometricPenHandle]
{$ENDIF WIN_GDI}
//[function TGraphicTool.GetFontWeight]
function TGraphicTool.GetFontWeight: Integer;
begin
Result := fData.Font.Weight; // for BCB only
end;
//[procedure TGraphicTool.SetFontWeight]
procedure TGraphicTool.SetFontWeight(const Value: Integer);
begin
if fData.Font.Weight = Value then Exit;
fData.Font.Weight := Value;
Changed;
end;
{$IFDEF WIN_GDI}
//[procedure TGraphicTool.SetLogFontStruct]
procedure TGraphicTool.SetLogFontStruct(const Value: TLogFont);
begin
if CompareMem(@fData.Font, @Value, SizeOf(TLogFont)) then Exit;
Move(Value, fData.Font, SizeOF(TLogFont));
Changed;
end;
//[function TGraphicTool.GetLogFontStruct]
function TGraphicTool.GetLogFontStruct: TLogFont;
begin
Move(fData.Font, Result, SizeOf(TLogFont));
end;
{$ENDIF WIN_GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TGraphicTool.GetPangoFontDesc: PPangoFontDescription;
var s: String;
i: Integer;
function IfThen( cond: Boolean; const s: String ): String;
begin
Result := '';
if cond then Result := s;
end;
{const Weights: array[0..9] of String = ( 'Ultralight',
'Ultralight', 'Ultralight',
'Light', 'Normal', 'Normal', 'Normal',
'Bold', 'Ultrabold', 'Heavy' );}
begin
if not Assigned( fPangoFontDesc ) then
begin
s := FontName; { + ' ' +
IfThen( FontWeight <> 400, Weights[ FontWeight div 100 ] + ' ' ) +
IfThen( fsItalic in FontStyle, 'Italic ' ) +
Int2Str( FontHeight )};
fPangoFontDesc := pango_font_description_from_string( PChar( s ) );
i := FontHeight;
if i > 0 then
pango_font_description_set_absolute_size( fPangoFontDesc, i * PANGO_SCALE );
//i := pango_font_description_get_size( fPangoFontDesc );
i := PANGO_STYLE_NORMAL;
if fsItalic in FontStyle then i := PANGO_STYLE_ITALIC;
pango_font_description_set_style( fPangoFontDesc, i );
pango_font_description_set_weight( fPangoFontDesc, FontWeight );
end;
Result := fPangoFontDesc;
end;
function Color2GDKColor( Color: TColor ): TGdkColor;
begin
Color := Color2RGB( Color );
Result.pixel := 0;
Result.red := (Color and $FF) shl 8;
Result.green := Color and $FF00;
Result.blue := (Color shr 8) and $FF00;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
{ TCanvas }
type
TStock = {$ifndef wince}packed{$endif} Record
StockPen: HPEN;
StockBrush: HBRUSH;
StockFont: HFONT;
end;
var
Stock: TStock;
//[destructor TCanvas.Destroy]
destructor TCanvas.Destroy;
begin
Handle := 0;
fPen.Free;
fBrush.Free;
fFont.Free;
inherited;
end;
//[function TCanvas.Assign]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TCanvas.Assign(SrcCanvas: PCanvas): Boolean;
begin
fFont := fFont.Assign( SrcCanvas.fFont );
fBrush := fBrush.Assign( SrcCanvas.fBrush );
fPen := fPen.Assign( SrcCanvas.fPen );
AssignChangeEvents;
Result := (fFont <> nil) or (fBrush <> nil) or (fPen <> nil);
if (SrcCanvas.PenPos.x <> PenPos.x) or (SrcCanvas.PenPos.y <> PenPos.y) then
begin
Result := True;
PenPos := SrcCanvas.PenPos;
end;
if SrcCanvas.ModeCopy <> ModeCopy then
begin
Result := True;
ModeCopy := SrcCanvas.ModeCopy;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.CreateBrush]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.CreateBrush;
begin
if assigned( fBrush ) then
begin
SelectObject( GetHandle, fBrush.Handle );
AssignChangeEvents;
if fBrush.fData.Brush.Style = bsSolid then
begin
SetBkColor( fHandle, Color2RGB( fBrush.fData.Color ) );
SetBkMode( fHandle, OPAQUE );
end
else
begin
{ Win95 doesn't draw brush hatches if bkcolor = brush color }
{ Since bkmode is transparent, nothing should use bkcolor anyway }
SetBkColor( fHandle, not Color2RGB( fBrush.fData.Color ) );
SetBkMode( fHandle, TRANSPARENT );
end;
end
else
if Assigned( fOwnerControl ) then
begin
SetBkColor( GetHandle, Color2RGB( PControl( fOwnerControl ).fColor ) );
SetBkMode( fHandle, OPAQUE );
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.CreateFont]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.CreateFont;
begin
if assigned( fFont ) then
begin
SelectObject( GetHandle, fFont.Handle );
SetTextColor( fHandle, Color2RGB( fFont.fData.Color ) );
AssignChangeEvents;
end
else
if Assigned( fOwnerControl ) then
begin
SetTextColor( fHandle, Color2RGB( PControl( fOwnerControl ).fTextColor ) );
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.CreatePen]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.CreatePen;
begin
if assigned( fPen ) then
begin
SelectObject( GetHandle, fPen.Handle );
SetROP2( fHandle, Ord( fPen.fData.Pen.Mode ) + 1 );
AssignChangeEvents;
end;
end;
{$ENDIF ASM_VERSION}
//[function TCanvas.GetPixels]
function TCanvas.GetPixels(X, Y: Integer): TColor;
begin
RequiredState( HandleValid );
Result := Windows.GetPixel(FHandle, X, Y);
end;
//[procedure TCanvas.SetPixels]
procedure TCanvas.SetPixels(X, Y: Integer; const Value: TColor);
begin
Changing;
RequiredState( HandleValid );
Windows.SetPixel(FHandle, X, Y, Color2RGB( Value ));
end;
{$ENDIF WIN_GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.SaveState;
begin
gdk_gc_get_values( fHandle, @ fSavedState );
end;
procedure TCanvas.RestoreState;
var mask: DWORD;
begin
mask := $1FFFF;
if fSavedState.font = nil then mask := mask and not GDK_GC_FONT;
if fSavedState.stipple = nil then mask := mask and not GDK_GC_STIPPLE;
gdk_gc_set_values( fHandle, @ fSavedState, mask );
DeselectHandles;
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TCanvas.DeselectHandles]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.DeselectHandles;
begin
if (fHandle <> 0) and
LongBool(fState and (PenValid or BrushValid or FontValid)) then
with Stock do
begin
if StockPen = 0 then
begin
StockPen := GetStockObject(BLACK_PEN);
StockBrush := GetStockObject(HOLLOW_BRUSH);
StockFont := GetStockObject(SYSTEM_FONT);
end;
SelectObject( fHandle, StockPen );
SelectObject( fHandle, StockBrush );
SelectObject( fHandle, StockFont );
fState := fState and not( PenValid or BrushValid or FontValid );
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.DeselectHandles;
begin
{$IFDEF GDI}
Free_And_Nil( fBrush );
Free_And_Nil( fPen );
Free_And_Nil( fFont );
{$ENDIF GDI}
if Assigned( fFont ) and Assigned( fFont.fPangoFontDesc ) then
begin
pango_font_description_free( fFont.fPangoFontDesc );
fFont.fPangoFontDesc := nil;
end;
fState := fState and not( PenValid or BrushValid or FontValid );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[function TCanvas.RequiredState]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TCanvas.RequiredState(ReqState: DWORD): HDC; {$ifdef wince}cdecl{$else}stdcall{$endif};
var
NeededState: Byte;
begin
if Boolean(ReqState and ChangingCanvas) then
Changing;
ReqState := ReqState and 15;
NeededState := Byte( ReqState ) and not fState;
Result := 0;
if Boolean(ReqState and HandleValid) then
begin
if GetHandle = 0 then Exit; // Important!
end;
if NeededState <> 0 then
begin
if Boolean( NeededState and FontValid ) then
CreateFont;
if Boolean( NeededState and PenValid ) then
begin
CreatePen;
if assigned( fPen ) then
if fPen.fData.Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then
NeededState := NeededState or BrushValid;
end;
if Boolean( NeededState and BrushValid ) then
CreateBrush;
fState := fState or NeededState;
end;
Result := fHandle;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
(*function TCanvas.RequiredState(ReqState: DWORD): HDC; {$ifdef wince}cdecl{$else}stdcall{$endif}; //todo:
var NeededState: Byte;
//var c: TGdkColor;
begin
{if Boolean(ReqState and ChangingCanvas) then
Changing;}
ReqState := ReqState and (BrushValid or FontValid or PenValid);
NeededState := Byte( ReqState ) and not fState;
//Result := nil;
{ if Boolean(ReqState and HandleValid) then
begin
if GetHandle = 0 then Exit; // Important!
end;}
if NeededState <> 0 then
begin
if Boolean( NeededState and PenValid ) then
begin
//CreatePen;
if not assigned( fPen ) then
fPen := NewPen;
if fPen.fData.Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then
NeededState := NeededState or BrushValid;
end;
if Boolean( NeededState and BrushValid ) then
begin
//CreateBrush;
if not Assigned( fBrush ) then
fBrush := NewBrush;
//c := Color2GDKColor( fBrush.Color );
//gdk_gc_set_rgb_fg_color( fHandle, @ c );
//todo: what with BrushBitmap and BrushStyle ?
end;
if Boolean( NeededState and FontValid ) then
begin
//CreateFont;
if not Assigned( fFont ) then
fFont := NewFont;
end;
fState := fState or NeededState;
end;
Result := fHandle;
end;*)
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.ForeBack(fg_color, bk_color: TColor); // install colors just before drawing
begin
fg_color := RGB2BGR( Color2RGB( fg_color ) );
bk_color := RGB2BGR( Color2RGB( bk_color ) );
gdk_rgb_gc_set_foreground( fHandle, fg_color );
gdk_rgb_gc_set_background( fHandle, bk_color );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[procedure TCanvas.SetHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.SetHandle(Value: HDC);
{$IFDEF F_P}
var Ptr1: Pointer;
{$ENDIF F_P}
begin
if fHandle = Value then Exit;
if fHandle <> 0 then
begin
DeselectHandles;
{$IFDEF GDI}
if not( assigned(fOwnerControl) and
(PControl(fOwnerControl).fPaintDC = fHandle) ) then
begin
{$IFDEF F_P}
Ptr1 := Self;
asm
MOV EAX, [Ptr1]
MOV EAX, [EAX].TCanvas.fOnGetHandle
MOV [Ptr1], EAX
end [ 'EAX' ];
if Ptr1 = @ TControl.DC2Canvas then
{$ELSE DELPHI}
//////////////////// SLAG
if TMethod(fOnGetHandle).Code =
@TControl.Dc2Canvas then
{$ENDIF F_P/DELPHI}
ReleaseDC(PControl(fOwnerControl).Handle, fHandle )
else
DeleteDC( fHandle );
////////////////////
end;
{$ENDIF GDI}
fHandle := 0;
fIsPaintDC := False;
fState := fState and not HandleValid;
end;
if Value <> 0 then
begin
fState := fState or HandleValid;
fHandle := Value;
SetPenPos( fPenPos );
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[procedure TCanvas.SetPenPos]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.SetPenPos(const Value: TPoint);
begin
fPenPos := Value;
{$IFDEF GDI}
MoveTo( Value.x, Value.y );
{$ENDIF GDI}
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[procedure TCanvas.Changing]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Changing;
begin
if Assigned( fOnChange ) then
fOnChange( @Self );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[procedure TCanvas.Arc]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
RequiredState( HandleValid or PenValid or ChangingCanvas );
{$ifndef wince}
Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
{$endif wince}
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
var C: TPoint;
angle1, angle2: Integer;
A1, A2: Double;
begin
////RequiredState( {HandleValid or} PenValid or ChangingCanvas );
C := MakePoint( (X1 + X2) div 2, (Y1 + Y2) div 2 );
{$IFDEF NOT_USE_EXCEPTION}
A1 := ArcTan2( Y3-C.Y, X3-C.X );
A2 := ArcTan2( Y4-C.Y, X4-C.X );
{$ELSE USE_EXCEPTION}
TRY
A1 := ArcTan2( Y3-C.Y, X3-C.X );
EXCEPT
A1 := 0;
END;
TRY
A2 := ArcTan2( Y4-C.Y, X4-C.X );
EXCEPT
A2 := 0;
END;
{$ENDIF NOT_USE_EXCEPTION}
angle1 := -Round(A1 * 180 * 64 / PI);
angle2 := -Round(A2 * 180 * 64 / PI);
if Brush.BrushStyle <> bsClear then
begin
ForeBack( Brush.Color, Brush.Color );
gdk_draw_arc( fDrawable, fHandle, 1, X1, Y1, X2-X1, Y2-Y1, angle1, angle2 );
end;
ForeBack( Pen.Color, Brush.Color );
gdk_draw_arc( fDrawable, fHandle, 0, X1, Y1, X2-X1, Y2-Y1, angle1, angle2 );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[procedure TCanvas.Chord]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
{$ifndef wince}
Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
{$endif wince}
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.CopyRect]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.CopyRect(const DstRect: TRect; SrcCanvas: PCanvas;
const SrcRect: TRect);
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
SrcCanvas.RequiredState( HandleValid or BrushValid );
StretchBlt( fHandle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
DstRect.Bottom - DstRect.Top, SrcCanvas.Handle, SrcRect.Left, SrcRect.Top,
SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, ModeCopy);
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.DrawFocusRect]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
begin
RequiredState( HandleValid or BrushValid or FontValid or ChangingCanvas );
Windows.DrawFocusRect(FHandle, Rect);
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.Ellipse]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[procedure TCanvas.FillRect]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
var Br: HBrush;
begin
RequiredState( HandleValid or BrushValid or ChangingCanvas );
if assigned( fBrush ) then
begin
Windows.FillRect(fHandle, Rect, fBrush.Handle);
end
else
if assigned( fOwnerControl ) then
begin
{$IFDEF GDI}
if assigned( PControl( fOwnerControl ).fBrush ) then
Windows.FillRect( fHandle, Rect, PControl( fOwnerControl ).fBrush.Handle )
else
begin
Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) );
Windows.FillRect(fHandle, Rect, Br );
DeleteObject( Br );
end;
{$ENDIF GDI}
end
else
begin
Windows.FillRect(fHandle, Rect, HBrush(COLOR_WINDOW + 1) );
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
begin
if (fBrush <> nil) and (fBrush.BrushStyle = bsClear) then Exit;
////RequiredState( {HandleValid or} BrushValid or ChangingCanvas );
ForeBack( Brush.Color, Brush.Color );
gdk_draw_rectangle( fDrawable, fHandle, 1, Rect.Left, Rect.Top,
Rect.Right-Rect.Left, Rect.Bottom-Rect.Top );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[procedure TCanvas.FillRgn]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.FillRgn(const Rgn: HRgn);
var Br : HBrush;
begin
RequiredState( HandleValid or BrushValid or ChangingCanvas );
if assigned( fBrush ) then
Windows.FillRgn(FHandle, Rgn, fBrush.Handle )
else
if assigned( fOwnerControl ) then
begin
{$IFDEF GDI}
if Assigned( PControl( fOwnerControl ).fBrush ) then
Windows.FillRgn( FHandle, Rgn, PControl( fOwnerControl ).fBrush.Handle )
else
begin
Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) );
Windows.FillRgn( fHandle, Rgn, Br );
DeleteObject( Br );
end;
{$ENDIF GDI}
end
else
begin
Br := CreateSolidBrush( DWORD(clWindow) );
Windows.FillRgn( fHandle, Rgn, Br );
DeleteObject( Br );
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.FloodFill]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
FillStyle: TFillStyle);
{$ifndef wince}
const
FillStyles: array[TFillStyle] of Word =
(FLOODFILLSURFACE, FLOODFILLBORDER);
{$endif wince}
begin
RequiredState( HandleValid or BrushValid or ChangingCanvas );
{$ifndef wince}
Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
{$endif wince}
end;
{$ENDIF ASM_VERSION}
{$ifdef wince}
procedure CeFrameRect(DC: HDC; const Rect: TRect; Color: TColor);
var
OldBrush, OldPen : HGDIOBJ;
begin
OldBrush:=SelectObject(DC, GetStockObject(NULL_BRUSH));
OldPen:=SelectObject(DC, Windows.CreatePen(PS_SOLID, 1, Color2RGB(Color)));
with Rect do
Windows.Rectangle(DC, Left, Top, Right, Bottom);
DeleteObject( SelectObject(DC, OldPen) );
SelectObject(DC, OldBrush);
end;
{$endif wince}
//[procedure TCanvas.FrameRect]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
var {$ifdef win32}SolidBr : HBrush;{$endif}
col : TColor;
begin
RequiredState( HandleValid or ChangingCanvas );
if assigned( fBrush ) then
col := fBrush.fData.Color
else
if assigned( fOwnerControl ) then
col := PControl(fOwnerControl).fColor
else
col := clWhite;
{$ifdef wince}
CeFrameRect(FHandle, Rect, col);
{$else}
SolidBr := CreateSolidBrush( Color2RGB(col) );
Windows.FrameRect(FHandle, Rect, SolidBr);
DeleteObject( SolidBr );
{$endif wince}
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[procedure TCanvas.LineTo]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.LineTo(X, Y: Integer);
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
Windows.LineTo( fHandle, X, Y );
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.LineTo(X, Y: Integer);
begin
//RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
////RequiredState( PenValid or BrushValid or ChangingCanvas );
ForeBack( Pen.Color, Brush.Color );
gdk_draw_line( fDrawable, fHandle, fPenPos.X, fPenPos.Y, X, Y );
fPenPos := MakePoint( X, Y );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TCanvas.MoveTo]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.MoveTo(X, Y: Integer);
begin
RequiredState( HandleValid );
Windows.MoveToEx( fHandle, X, Y, nil );
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.MoveTo(X, Y: Integer);
begin
fPenPos := MakePoint( X, Y );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TCanvas.ObjectChanged]
procedure TCanvas.ObjectChanged(Sender: PGraphicTool);
begin
DeselectHandles;
end;
{$IFDEF WIN_GDI}
//[procedure TCanvas.Pie]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
{$ifndef wince}
Windows.Pie( fHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
{$endif wince}
end;
{$ENDIF ASM_VERSION}
{++}(*
{$IFDEF F_P}
//[Windows API FUNCTIONS ADDITIONAL DECLARATIONS FOR Free Pascal]
function Windows_Polygon; external gdi32 name 'Polygon';
function Windows_Polyline; external gdi32 name 'Polyline';
function FillRect; external user32 name 'FillRect';
function OffsetRect; external user32 name 'OffsetRect';
function CreateAcceleratorTable; external user32 name 'CreateAcceleratorTableA';
function TrackPopupMenu; external user32 name 'TrackPopupMenu';
function AdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;
const NewState: TTokenPrivileges; BufferLength: DWORD;
var PreviousState: TTokenPrivileges; var ReturnLength: DWORD): BOOL; external advapi32 name 'AdjustTokenPrivileges';
function InflateRect; external user32 name 'InflateRect';
{$IFDEF F_P105ORBELOW}
function InvalidateRect; external user32 name 'InvalidateRect';
function ValidateRect; external user32 name 'ValidateRect';
{$ENDIF F_P105ORBELOW}
//[END OF Windows API FUNCTIONS ADDITIONAL DECLARATIONS FOR Free Pascal]
{$ENDIF}
*){--}
//[procedure TCanvas.Polygon]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Polygon(const Points: array of TPoint);
type
PPoints = ^TPoints;
TPoints = array[0..0] of TPoint;
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
{$IFDEF F_P} Windows_Polygon
{$ELSE DELPHI} Windows.Polygon
{$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.Polyline]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Polyline(const Points: array of TPoint);
type
PPoints = ^TPoints;
TPoints = array[0..0] of TPoint;
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
{$IFDEF F_P}Windows_Polyline
{$ELSE DELPHI}Windows.Polyline
{$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.Rectangle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
begin
RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );
Windows.Rectangle( fHandle, X1, Y1, X2, Y2);
end;
{$ENDIF ASM_VERSION}
//[procedure TCanvas.RoundRect]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
begin
RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );
Windows.RoundRect( fHandle, X1, Y1, X2, Y2, X3, Y3);
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[procedure TCanvas.TextArea]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.TextArea(const Text: KOLString; var Sz: TSize;
var P0: TPoint);
begin
Sz := TextExtent( Text );
P0.x := 0; P0.y := 0;
if Assigned( GlobalCanvas_OnTextArea ) then
GlobalCanvas_OnTextArea( @Self, Sz, P0 );
end;
{$ENDIF ASM_VERSION}
//[function TCanvas.TextExtent]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TCanvas.TextExtent(const Text: KOLString): TSize;
var DC : HDC;
ClearHandle : Boolean;
begin
ClearHandle := False;
RequiredState( HandleValid or FontValid );
DC := fHandle;
if DC = 0 then
begin
DC := CreateCompatibleDC( 0 );
ClearHandle := True;
SetHandle( DC );
If Not fIsPaintDC then
ClearHandle := True; //************ // Added By Gerasimov
end;
RequiredState( HandleValid or FontValid );
{Windows.}GetTextExtentPoint32( fHandle, PKOLChar(Text), Length(Text), Result);
{$ifdef wince}
Inc(Result.cx);
{$endif wince}
if ClearHandle then
SetHandle( 0 );
{ DC must be freed here automatically (never leaks):
if Canvas created on base of existing DC, no memDC created,
if Canvas has fHandle:HDC = 0, it is not fIsPaintDC always. }
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TCanvas.TextExtent(const Text: KOLString): TSize;
var layout: PPangoLayout;
context: PPangoContext;
begin
//RequiredState( HandleValid or FontValid );
if fOwnerControl <> nil then
begin
context := nil;
layout := gtk_widget_create_pango_layout(
PControl( fOwnerControl ).fEventboxHandle, nil );
end
else
begin //todo: seems not working in such way... What to do for memory bitmap?
context := pango_context_new;
//layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) );
layout := pango_layout_new( context );
end;
pango_layout_set_font_description( layout, Font.FontHandle );
pango_layout_set_text( layout, PChar( Text ), Length( Text ) );
pango_layout_get_size( layout, @ Result.cx, @ Result.cy );
g_object_unref( layout );
if context <> nil then g_object_unref( context );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[function TCanvas.TextHeight]
function TCanvas.TextHeight(const Text: KOLString): Integer;
begin
Result := TextExtent(Text).cY;
end;
//[procedure TCanvas.TextOut]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.TextOut(X, Y: Integer; const Text: KOLString); {$ifdef wince}cdecl{$else}stdcall{$endif};
{$ifdef wince}
var Options: Integer;
{$endif wince}
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
{$ifdef wince}
Options := 0;
if GetBkMode(FHandle) = OPAQUE then Options := ETO_OPAQUE;
Windows.ExtTextOut(FHandle, X, Y, Options, nil, PKOLChar(Text), Length(Text), nil);
{$else}
Windows.TextOut(FHandle, X, Y, PChar(Text), Length(Text));
{$endif wince}
//MoveTo(X + TextWidth(Text), Y); -- by suggestion of Alexey (Lecha2002)
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.TextOut(X, Y: Integer; const Text: KOLString); {$ifdef wince}cdecl{$else}stdcall{$endif};
var Options: Integer;
begin
Options := 0;
if Brush.BrushStyle <> bsClear then Options := ETO_OPAQUE;
ExtTextOut( X, Y, Options, MakeRect( 0,0,0,0 ), Text, [ ] );
end;
(*var context: PPangoContext;
layout: PPangoLayout;
w, h: Integer;
begin
RequiredState( {HandleValid or} FontValid or BrushValid or ChangingCanvas );
if fOwnerControl <> nil then
begin
context := nil;
layout := gtk_widget_create_pango_layout(
PControl( fOwnerControl ).fEventboxHandle, nil );
end
else
begin //todo: seems not working in such way... What to do for memory bitmap?
context := pango_context_new;
//layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) );
layout := pango_layout_new( context );
end;
pango_layout_set_font_description( layout, Font.FontHandle );
pango_layout_set_text( layout, PChar( Text ), Length( Text ) );
if Brush.BrushStyle <> bsClear then
begin
pango_layout_get_size( layout, @ w, @ h );
ForeBack( Brush.Color, Brush.Color );
gdk_draw_rectangle( fDrawable, fHandle, 1, X, Y, w div PANGO_SCALE, h div PANGO_SCALE );
end;
ForeBack( Font.Color, Brush.Color );
gdk_draw_layout( fDrawable, fHandle, X, Y, layout );
g_object_unref( layout );
if context <> nil then
g_object_unref( context );
end;*)
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TCanvas.TextRect]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: KOLString);
var
Options: Integer;
begin
//Changing;
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Options := ETO_CLIPPED;
if assigned( fBrush ) and (fBrush.fData.Brush.Style <> bsClear)
or not assigned( fBrush ) then Inc(Options, ETO_OPAQUE);
Windows.
{$IFDEF UNICODE_CTRLS}
ExtTextOutW
{$ELSE}
ExtTextOut
{$ENDIF}
( fHandle, X, Y, Options,
@Rect, PKOLChar(Text),
Length(Text), nil);
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: string);
var Options: Integer;
begin
Options := ETO_CLIPPED;
if Brush.BrushStyle <> bsClear then Options := Options or ETO_OPAQUE;
ExtTextOut( X, Y, Options, Rect, Text, [] );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TCanvas.ExtTextOut]
{$IFDEF GDI}
procedure TCanvas.ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: KOLString;
const Spacing: array of Integer );
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Windows.
{$IFDEF UNICODE_CTRLS}
ExtTextOutW
{$ELSE}
ExtTextOut
{$ENDIF}
(FHandle, X, Y, Options, @Rect, PKOLChar(Text), Length(Text), @Spacing[ 0 ]);
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TCanvas.ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: KOLString;
const Spacing: array of Integer );
var context: PPangoContext;
layout: PPangoLayout;
w, h: Integer;
pixmap: PGdkPixmap;
begin
////RequiredState( {HandleValid or} FontValid or BrushValid or ChangingCanvas );
w := Rect.Right - Rect.Left;
h := Rect.Bottom - Rect.Top;
if fOwnerControl <> nil then
begin
context := nil;
layout := gtk_widget_create_pango_layout(
PControl( fOwnerControl ).fEventboxHandle, nil );
end
else
begin //todo: seems not working in such way... What to do for memory bitmap?
context := pango_context_new;
//layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) );
layout := pango_layout_new( context );
end;
pango_layout_set_font_description( layout, Font.FontHandle );
pango_layout_set_text( layout, PChar( Text ), Length( Text ) );
if Options and ETO_CLIPPED = 0 then
begin
pango_layout_get_size( layout, @ w, @ h );
w := w div PANGO_SCALE;
h := h div PANGO_SCALE;
end;
pixmap := gdk_pixmap_new( PControl( fOwnerControl ).fEventboxHandle.window,
//todo: use MainForm
w, h, -1 );
if Options and ETO_OPAQUE <> 0 then
begin
ForeBack( Brush.Color, Brush.Color );
gdk_draw_rectangle( GDK_DRAWABLE( pixmap ), fHandle, 1, 0, 0, w, h );
end
else
begin
gdk_draw_drawable( GDK_DRAWABLE( pixmap ), fHandle, fDrawable,
Rect.Left, Rect.Top, 0, 0, w, h );
end;
ForeBack( Font.Color, Brush.Color );
gdk_draw_layout( GDK_DRAWABLE( pixmap ), fHandle, X, Y, layout );
g_object_unref( layout );
gdk_draw_drawable( fDrawable, fHandle, GDK_DRAWABLE( pixmap ),
0, 0, Rect.Left, Rect.Top, w, h );
g_object_unref( pixmap );
if context <> nil then
g_object_unref( context );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[procedure TCanvas.DrawText]
procedure TCanvas.DrawText(Text:KOLString; var Rect:TRect; Flags:DWord);
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Windows.
{$IFDEF UNICODE_CTRLS}
DrawTextW
{$ELSE}
DrawText
{$ENDIF}
(Handle,PKOLChar(Text),Length(Text),Rect,Flags);
end;
//[function TCanvas.ClipRect]
function TCanvas.ClipRect: TRect;
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
GetClipBox(Handle, Result);
end;
{$ENDIF WIN_GDI}
//[function TCanvas.TextWidth]
function TCanvas.TextWidth(const Text: KOLString): Integer;
begin
Result := TextExtent(Text).cX;
end;
//[function TCanvas.GetBrush]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TCanvas.GetBrush: PGraphicTool;
begin
if not assigned( fBrush ) then
begin
fBrush := NewBrush;
if assigned( fOwnerControl ) then
begin
fBrush.fData.Color := PControl(fOwnerControl).fColor;
if assigned( PControl(fOwnerControl).fBrush ) then
{fBrush := }fBrush.Assign( PControl(fOwnerControl).fBrush );
// both statements above needed
end;
//fBrush.OnChange := ObjectChanged;
AssignChangeEvents;
end;
Result := fBrush;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TCanvas.GetBrush: PGraphicTool;
begin
if not assigned( fBrush ) then
begin
fBrush := NewBrush;
if assigned( fOwnerControl ) then
begin
fBrush.fData.Color := PControl(fOwnerControl).fColor;
if assigned( PControl(fOwnerControl).fBrush ) then
{fBrush := }fBrush.Assign( PControl(fOwnerControl).fBrush );
// both statements above needed
end;
//fBrush.OnChange := ObjectChanged;
AssignChangeEvents;
end;
Result := fBrush;
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[function TCanvas.GetFont]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TCanvas.GetFont: PGraphicTool;
begin
if not assigned( fFont ) then
begin
fFont := NewFont;
if assigned( fOwnerControl ) then
begin
fFont.Color := PControl(fOwnerControl).fTextColor;
if assigned( PControl(fOwnerControl).fFont ) then
{fFont := }fFont.Assign( PControl(fOwnerControl).fFont );
end;
//fFont.OnChange := ObjectChanged;
AssignChangeEvents;
end;
Result := fFont;
end;
{$ENDIF ASM_VERSION}
//[function TCanvas.GetPen]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TCanvas.GetPen: PGraphicTool;
begin
if not assigned( fPen ) then
begin
fPen := NewPen;
AssignChangeEvents;
end;
Result := fPen;
end;
{$ENDIF ASM_VERSION}
//[function TCanvas.GetHandle]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TCanvas.GetHandle: HDC;
begin
if assigned( fOnGetHandle ) then
begin
Result := fOnGetHandle( @Self );
//fHandle := Result;
SetHandle( Result );
end
else
Result := fHandle;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TCanvas.GetHandle: HDC;
begin
if Assigned( fOnGetHandle ) then
fHandle := fOnGetHandle( @Self );
Result := fHandle;
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TCanvas.AssignChangeEvents]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.AssignChangeEvents;
begin
if assigned( fBrush ) then
fBrush.fOnChange := ObjectChanged;
if assigned( fPen ) then
fPen.fOnChange := ObjectChanged;
if assigned( fFont ) then
fFont.fOnChange := ObjectChanged;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
{$IFNDEF _FPC}
{$IFNDEF _D2}
//[procedure TCanvas.WDrawText]
procedure TCanvas.WDrawText(WText: WideString; var Rect: TRect;
Flags: DWord);
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Windows.DrawTextW(Handle,PWideChar(WText),Length(WText),Rect,Flags);
end;
//[procedure TCanvas.WExtTextOut]
procedure TCanvas.WExtTextOut(X, Y: Integer; Options: DWORD;
const Rect: TRect; const WText: WideString;
const Spacing: array of Integer);
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Windows.ExtTextOutW(FHandle, X, Y, Options, @Rect, PWideChar(WText), Length(WText), @Spacing[ 0 ]);
end;
//[procedure TCanvas.WTextOut]
procedure TCanvas.WTextOut(X, Y: Integer; const WText: WideString);
begin
{$ifdef wince}
TextOut(X, Y, WText);
{$else}
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Windows.TextOutW(FHandle, X, Y, PWideChar(WText), Length(WText));
MoveTo(X + WTextWidth(WText), Y);
{$endif wince}
end;
//[procedure TCanvas.WTextRect]
procedure TCanvas.WTextRect(const Rect: TRect; X, Y: Integer;
const WText: WideString);
var
Options: Integer;
begin
//Changing;
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Options := ETO_CLIPPED;
if assigned( fBrush ) and (fBrush.fData.Brush.Style <> bsClear)
or not assigned( fBrush ) then Inc(Options, ETO_OPAQUE);
Windows.ExtTextOutW( fHandle, X, Y, Options,
@Rect, PWideChar(WText),
Length(WText), nil);
end;
//[function TCanvas.WTextExtent]
function TCanvas.WTextExtent(const WText: WideString): TSize;
var DC : HDC;
ClearHandle : Boolean;
begin
ClearHandle := False;
RequiredState( HandleValid or FontValid );
DC := fHandle;
if DC = 0 then
begin
DC := CreateCompatibleDC( 0 );
ClearHandle := True;
SetHandle( DC );
end;
RequiredState( HandleValid or FontValid );
{Windows.}GetTextExtentPoint32W( fHandle, PWideChar(WText), Length(WText), Result);
if ClearHandle then
SetHandle( 0 );
end;
//[function TCanvas.WTextHeight]
function TCanvas.WTextHeight(const WText: WideString): Integer;
begin
Result := WTextExtent( WText ).cy;
end;
//[function TCanvas.WTextWidth]
function TCanvas.WTextWidth(const WText: WideString): Integer;
begin
Result := WTextExtent( WText ).cx;
end;
{$ENDIF _D2}
{$ENDIF _FPC}
{$ENDIF WIN_GDI}
{-}
//[function MakeInt64]
function MakeInt64( Lo, Hi: DWORD ): I64;
begin
Result.Lo := Lo;
Result.Hi := Hi;
end;
//[function Int2Int64]
{$IFDEF cpu86}
function Int2Int64( X: Integer ): I64;
asm
MOV [EDX], EAX
MOV ECX, EDX
CDQ
MOV [ECX+4], EDX
end;
{$ELSE cpu86} //Pascal
function Int2Int64( X: Integer ): I64;
begin
Int64(Result):=X;
end;
{$ENDIF cpu86}
//[procedure IncInt64]
{$IFDEF cpu86}
procedure IncInt64( var I64: I64; Delta: Integer );
asm
ADD [EAX], EDX
ADC dword ptr [EAX+4], 0
end;
{$ELSE cpu86} //Pascal
procedure IncInt64( var I64: I64; Delta: Integer );
begin
Inc(Int64(I64), Delta);
end;
{$ENDIF cpu86}
//[procedure DecInt64]
{$IFDEF cpu86}
procedure DecInt64( var I64: I64; Delta: Integer );
asm
SUB [EAX], EDX
SBB dword ptr [EDX], 0
end;
{$ELSE cpu86} //Pascal
procedure DecInt64( var I64: I64; Delta: Integer );
begin
Dec(Int64(I64), Delta);
end;
{$ENDIF cpu86}
//[function Add64]
{$IFDEF cpu86}
function Add64( const X, Y: I64 ): I64;
asm
PUSH ESI
XCHG ESI, EAX
LODSD
ADD EAX, [EDX]
MOV [ECX], EAX
LODSD
ADC EAX, [EDX+4]
MOV [ECX+4], EAX
POP ESI
end;
{$ELSE cpu86} //Pascal
function Add64( const X, Y: I64 ): I64;
begin
Int64(Result):=Int64(X)+Int64(Y);
end;
{$ENDIF cpu86}
//[function Sub64]
{$IFDEF cpu86}
function Sub64( const X, Y: I64 ): I64;
asm
PUSH ESI
XCHG ESI, EAX
LODSD
SUB EAX, [EDX]
MOV [ECX], EAX
LODSD
SBB EAX, [EDX+4]
MOV [ECX+4], EAX
POP ESI
end;
{$ELSE cpu86} //Pascal
function Sub64( const X, Y: I64 ): I64;
begin
Int64(Result):=Int64(X)-Int64(Y);
end;
{$ENDIF cpu86}
//[function Neg64]
{$IFDEF cpu86}
function Neg64( const X: I64 ): I64;
asm
MOV ECX, [EAX]
NEG ECX
MOV [EDX], ECX
MOV ECX, 0
SBB ECX, [EAX+4]
MOV [EDX+4], ECX
end;
{$ELSE cpu86} //Pascal
function Neg64( const X: I64 ): I64;
begin
Int64(Result):=-Int64(X);
end;
{$ENDIF cpu86}
{$IFDEF cpu86}
//[function Mul64EDX]
function Mul64EDX( const X: I64; M: Integer ): I64;
asm
PUSH ESI
PUSH EDI
XCHG ESI, EAX
MOV EDI, ECX
MOV ECX, EDX
LODSD
MUL ECX
STOSD
XCHG EDX, ECX
LODSD
MUL EDX
ADD EAX, ECX
STOSD
POP EDI
POP ESI
end;
//[FUNCTION Mul64i]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Mul64i( const X: I64; Mul: Integer ): I64;
var Minus: Boolean;
begin
Minus := FALSE;
if Mul < 0 then
begin
Minus := TRUE;
Mul := -Mul;
end;
Result := Mul64EDX( X, Mul );
if Minus then
Result := Neg64( Result );
end;
{$ENDIF ASM_VERSION}
{$ELSE cpu86}
function Mul64i( const X: I64; Mul: Integer ): I64;
begin
Int64(Result):=Int64(X)*Mul;
end;
{$ENDIF cpu86}
//[END Mul64i]
{$IFDEF cpu86}
//[function Div64EDX]
function Div64EDX( const X: I64; D: Integer ): I64;
asm
PUSH ESI
PUSH EDI
XCHG ESI, EAX
MOV EDI, ECX
MOV ECX, EDX
MOV EAX, [ESI+4]
CDQ
DIV ECX
MOV [EDI+4], EAX
LODSD
DIV ECX
STOSD
POP EDI
POP ESI
end;
//[FUNCTION Div64i]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Div64i( const X: I64; D: Integer ): I64;
var Minus: Boolean;
begin
Minus := FALSE;
if D < 0 then
begin
D := -D;
Minus := TRUE;
end;
Result := X;
if Sgn64( Result ) < 0 then
begin
Result := Neg64( Result );
Minus := not Minus;
end;
Result := Div64EDX( Result, D );
if Minus then
Result := Neg64( Result );
end;
{$ENDIF ASM_VERSION}
{$ELSE cpu86}
function Div64i( const X: I64; D: Integer ): I64;
begin
Int64(Result):=Int64(X) div D;
end;
{$ENDIF cpu86}
//[END Div64i]
//[function Mod64i]
function Mod64i( const X: I64; D: Integer ): Integer;
begin
Result := Sub64( X, Mul64i( Div64i( X, D ), D ) ).Lo;
end;
//[function Sgn64]
{$IFDEF cpu86}
function Sgn64( const X: I64 ): Integer;
asm
XOR EDX, EDX
CMP [EAX+4], EDX
XCHG EAX, EDX
JG @@ret_1
JL @@ret_neg
CMP [EDX], EAX
JZ @@exit
@@ret_1:
INC EAX
RET
@@ret_neg:
DEC EAX
@@exit:
end;
{$ELSE cpu86}
function Sgn64( const X: I64 ): Integer;
begin
if Int64(X) > 0 then
Result:=1
else
Result:=-1;
end;
{$ENDIF cpu86}
//[function Cmp64]
function Cmp64( const X, Y: I64 ): Integer;
begin
Result := Sgn64( Sub64( X, Y ) );
end;
//[function Int64_2Str]
function Int64_2Str( X: I64 ): String;
var M: Boolean;
Y: Integer;
Buf: array[ 0..31 ] of Char;
I: Integer;
begin
M := FALSE;
case Sgn64( X ) of
-1: begin M := TRUE; X := Neg64( X ); end;
0: begin Result := '0'; Exit; end;
end;
I := 31;
Buf[ 31 ] := #0;
while Sgn64( X ) > 0 do
begin
Dec( I );
Y := Mod64i( X, 10 );
Buf[ I ] := Char( Y + Integer( '0' ) );
X := Div64i( X, 10 );
end;
if M then
begin
Dec( I );
Buf[ I ] := '-';
end;
Result := PChar( @Buf[ I ] );
end;
function Int64_2Hex( X: I64; MinDigits: Integer ): String;
begin
if (MinDigits <= 8) and (X.Hi <> 0) then
Result := Int2Hex( X.Hi, 1 ) + Int2Hex( X.Lo, 8 )
else if X.Hi <> 0 then
Result := Int2Hex( X.Hi, MinDigits - 8 ) + Int2Hex( X.Lo, 8 )
else
Result := Int2Hex( X.Lo, MinDigits );
end;
//[function Str2Int64]
function Str2Int64( const S: String ): I64;
var I: Integer;
M: Boolean;
begin
Result.Lo := 0;
Result.Hi := 0;
I := 1;
if S = '' then Exit;
M := FALSE;
if S[ 1 ] = '-' then
begin
M := TRUE;
Inc( I );
end
else
if S[ 1 ] = '+' then
Inc( I );
while I <= Length( S ) do
begin
if not( S[ I ] in [ '0'..'9' ] ) then
break;
Result := Mul64i( Result, 10 );
IncInt64( Result, Integer( S[ I ] ) - Integer( '0' ) );
Inc( I );
end;
if M then
Result := Neg64( Result );
end;
//[function Int64_2Double]
{$IFDEF cpu86}
function Int64_2Double( const X: I64 ): Double;
asm
FILD qword ptr [EAX]
FSTP @Result
end;
{$ELSE cpu86}
function Int64_2Double( const X: I64 ): Double;
begin
Result:=Int64(X);
end;
{$ENDIF cpu86}
//[function Double2Int64]
{$IFDEF cpu86}
function Double2Int64( D: Double ): I64;
asm
FLD D
FISTP qword ptr [EAX]
end;
{$ELSE cpu86}
function Double2Int64( D: Double ): I64;
begin
Int64(Result):=Trunc(D);
end;
{$ENDIF cpu86}
{+}
function IsNan(const AValue: Double): Boolean;
{$IFDEF _D2orD3}
type PI64 = ^I64;
{$ENDIF}
begin
{-}
Result := (PI64(@AValue).Hi and $7FF00000 = $7FF00000) and
((PI64(@AValue).Hi and $000FFFFF <> 0) or (PI64(@AValue).Lo <> 0));
{+}{++}(*Result := AValue = NAN;*){--}
end;
function IsInfinity(const AValue: Double): Boolean;
{$IFDEF _D2orD3}
type PI64 = ^I64;
{$ENDIF}
begin
{-}
Result := (PI64(@AValue).Hi and $7FF00000 = $7FF00000) and
(PI64(@AValue).Hi and $000FFFFF = $00000000);
{+}{++}(*Result := AValue = Infinite;*){--}
end;
//[function IntPower]
function IntPower(Base: Extended; Exponent: Integer): Extended;
{$IFNDEF cpu86}
begin
{if Exponent = 0 then
begin
Result := 1.0;
Exit;
end;
if Exponent < 0 then
begin
Exponent := -Exponent;
Base := 1.0 / Base;
end;
Result := Base;
REPEAT
Result := Result * Base;
Dec( Exponent );
UNTIL Exponent <= 0;}
Result := 1.0;
if Exponent = 0 then exit;
if Exponent < 0 then begin
Exponent := -Exponent;
Base := 1.0 / Base;
end;
REPEAT
Result := Result * Base;
Dec( Exponent );
UNTIL Exponent=0;
end;
{$ELSE cpu86}
// This version of code by Galkov:
// Changes in comparison to Delphi standard:
// no Overflow exception if Exponent is very big negative value
// (just 0 in result in such case).
asm
fld1 { Result := 1 }
test eax,eax // check Exponent for 0, return 0 ** 0 = 1
jz @@3 // (though Mathematics says that this is not so...)
fld Base
jg @@2
fdivr ST,ST(1) { Base := 1 / Base }
neg eax
jmp @@2
@@1: fmul ST,ST { X := Base * Base }
@@2: shr eax,1
jnc @@1
fmul ST(1),ST { Result := Result * X }
jnz @@1
fstp st { pop X from FPU stack }
@@3: fwait
end;
{$ENDIF cpu86}
//[function Str2Double]
function Str2Double( const S: String ): Double;
var I: Integer;
M, Pt: Boolean;
D: Double;
Ex: Integer;
begin
Result := 0.0;
if S = '' then Exit;
M := FALSE;
I := 1;
if S[ 1 ] = '-' then
begin
M := TRUE;
Inc( I );
end;
Pt := FALSE;
D := 1.0;
while I <= Length( S ) do
begin
case S[ I ] of
'.': if not Pt then Pt := TRUE else break;
'0'..'9': if not Pt then
Result := Result * 10.0 + Integer( S[ I ] ) - Integer( '0' )
else
begin
D := D * 0.1;
Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D;
end;
'e', 'E': begin
Ex := Str2Int( CopyEnd( S, I + 1 ) );
Result := Result * IntPower( 10.0, Ex );
break;
end;
end;
Inc( I );
end;
if M then
Result := -Result;
end;
function Str2Extended( const S: String ): Extended;
var I: Integer;
M, Pt: Boolean;
D: Extended;
Ex: Integer;
begin
Result := 0.0;
if S = '' then Exit;
M := FALSE;
I := 1;
if S[ 1 ] = '-' then
begin
M := TRUE;
Inc( I );
end;
Pt := FALSE;
D := 1.0;
while I <= Length( S ) do
begin
case S[ I ] of
'.': if not Pt then Pt := TRUE else break;
'0'..'9': if not Pt then
Result := Result * 10.0 + Integer( S[ I ] ) - Integer( '0' )
else
begin
D := D * 0.1;
Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D;
end;
'e', 'E': begin
Ex := Str2Int( CopyEnd( S, I + 1 ) );
Result := Result * IntPower( 10.0, Ex );
break;
end;
end;
Inc( I );
end;
if M then
Result := -Result;
end;
//[function TruncD]
function TruncD( D: Double ): Double;
{$ifdef cpu86}
asm
FLD D
PUSH ECX
FNSTCW [ESP]
POP ECX
PUSH ECX
OR byte ptr [ESP+1], $0C
FLDCW [ESP]
PUSH ECX
FRNDINT
FSTP @Result
FLDCW [ESP]
POP ECX
POP ECX
end;
{$else cpu86}
begin
Result := Trunc( D );
end;
{$endif cpu86}
function IfThenElseBool( t, e: Boolean; Cond: Boolean ): Boolean;
begin
if cond then Result := t else Result := e;
end;
function IfThenElseInt( t, e: Integer; Cond: Boolean ): Integer;
begin
if cond then Result := t else Result := e;
end;
function IfThenElseStr( const t, e: String; Cond: Boolean ): String;
begin
if cond then Result := t else Result := e;
end;
{$IFDEF _D5orHigher}
function IfThenElse( t, e: Boolean; Cond: Boolean ): Boolean; overload;
begin
if cond then Result := t else Result := e;
end;
function IfThenElse( t, e: Integer; Cond: Boolean ): Integer; overload;
begin
if cond then Result := t else Result := e;
end;
function IfThenElse( t, e: String; Cond: Boolean ): String; overload;
begin
if cond then Result := t else Result := e;
end;
function IfThenElse( t, e: Double; Cond: Boolean ): Double; overload;
begin
if cond then Result := t else Result := e;
end;
{$ENDIF}
// Precision 15
//[function Extended2Str]
function Extended2Str( E: Extended ): String;
function UnpackFromBuf( const Buf: array of Byte; N: Integer ): String;
var I, J, K, L: Integer;
begin
SetLength( Result, 16 );
J := 1;
for I := 7 downto 0 do
begin
K := Buf[ I ] shr 4;
Result[ J ] := Char( Ord('0') + K );
Inc( J );
K := Buf[ I ] and $F;
Result[ J ] := Char( Ord('0') + K );
Inc( J );
end;
Assert( Result[ 1 ] = '0', 'error!' );
Delete( Result, 1, 1 );
if N <= 0 then
begin
while N < 0 do
begin
Result := '0' + Result;
Inc( N );
end;
Result := '0.' + Result;
end
else
if N < Length( Result ) then
begin
Result := Copy( Result, 1, N ) + '.' + CopyEnd( Result, N + 1 );
end
else
begin
while N > Length( Result ) do
begin
Result := Result + '0';
end;
Exit;
end;
L := Length( Result );
while L > 1 do
begin
if not (Result[ L ] in ['0','.']) then break;
Dec( L );
if Result[ L + 1 ] = '.' then break;
end;
if L < Length( Result ) then Delete( Result, L + 1, MaxInt );
end;
var
S: Boolean;
var F: Extended;
N: Integer;
Buf1: array[ 0..9 ] of Byte;
I10: Integer;
{$ifndef cpu86}
procedure e2bcd(e:Extended);
var
i:byte;
begin
e:=e+0.5;
for i := 0 to 9 do begin
e:=Trunc(e)/10;
Buf1[i]:=Trunc(frac(e)*10);
e:=Trunc(e)/10;
Buf1[i]:=(Trunc((frac(e)*10)) shl 4) or Buf1[i];
end;
end;
{$endif cpu86}
begin
Result := '0';
if E = 0 then Exit;
S := E < 0;
if S then E := -E;
N := 15;
F := 5E12;
I10 := 10;
while E < F do
begin
Dec( N );
E := E * I10;
end;
if N = 15 then
while E >= 1E13 do
begin
Inc( N );
E := E / I10;
end;
while TRUE do
begin
{$ifdef cpu86}
asm
FLD [E]
FBSTP [Buf1]
end;
{$else}
e2bcd(E);
{$endif cpu86}
if Buf1[ 7 ] <> 0 then break;
E := E * I10;
Dec( N );
end;
Result := UnpackFromBuf( Buf1, N );
if S then Result := '-' + Result;
end;
//[function Double2Str]
function Double2Str( D: Double ): String;
begin
Result := Extended2Str( D );
end;
//[function Double2StrEx]
function Double2StrEx( D: Double ): String;
var E, E1, E2: Double;
S: String;
begin
Result := Double2Str( D );
E := Str2Double( Result );
E1 := E - D;
if E1 < 0.0 then E1 := -E1;
if E1 < 1e-307 then Exit;
while TRUE do
begin
E := D - (E - D) * 0.3;
S := Double2Str( E );
if S = Result then break;
E := Str2Double( S );
E2 := E - D;
if E2 < 0.0 then E2 := -E2;
if E2 > E1 * 0.75 then break;
Result := S;
if E2 < E1 * 0.1 then break;
end;
end;
//[function GetBits]
function GetBits( N: DWORD; first, last: Byte ): DWord;
{$ifndef cpu86}
begin
Result := 0;
if last > 31 then last := 31;
if first > last then Exit;
Result := (N and not ($FFFFFFFF shl last)) shr first;
end;
{$else}
asm
XCHG EAX, EDX // (1) EDX=N, AL=first
{$IFDEF PARANOIA} DB $3C, 31 {$ELSE} CMP AL, 31 {$ENDIF} // first(AL) > 31 ?
JBE @@1 // (2) если да, то Result := 0;
@@0:
XOR EAX, EAX // (2)
RET // (1)
@@1:
XCHG EAX, ECX // (1) AL = last CL = first
SHR EDX, CL // (2) EDX = N shr first
SUB AL, CL // (2) AL = last - first
JL @@0 // (2) если last < first то Result := 0;
{$IFDEF PARANOIA} DB $3C, 32 {$ELSE} CMP AL, 32 {$ENDIF} // (2) last - first >= 32 ?
XCHG ECX, EAX // (1) CL = last - first
XCHG EAX, EDX // (1) EAX = N shr first
JAE @@exit // (2) если last - first > 31, то Result := EAX;
SBB EDX, EDX // (2) EDX = -1
DEC EDX // (1) EDX = 1111...10 = -2
SHL EDX, CL // (2) EDX = 111...100..0 (где n(0)=last-first+1)
NOT EDX // (2) EDX = маска 000..0111...1 (где n(1)=last-first+1)
AND EAX, EDX // (2)
@@exit:
// EAX = результат, (1 байт на команду RET)
end;
{$endif cpu86}
//[function GetBitsL]
function GetBitsL( N: DWORD; from, len: Byte ): DWord;
{$ifndef cpu86}
begin
Result := GetBits( N, from, from + len - 1 );
end;
{$else}
asm
ADD CL, DL
DEC CL
JMP GetBits
end;
{$endif cpu86}
//[FUNCTION MulDiv]
{$IFNDEF FPC}
function MulDiv( A, B, C: Integer ): Integer;
asm
IMUL EDX
IDIV ECX
end;
{$ENDIF}
//[END MulDiv]
//[FUNCTION Int2Hex]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal (mixed)
function Int2Hex( Value : DWord; Digits : Integer ) : String;
var Buf: array[ 0..8 ] of Char;
Dest : PChar;
function HexDigit( B : Byte ) : Char;
{$ifdef FPC}
const
HexDigitChr: array[ 0..15 ] of Char = ( '0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F' );
begin
Result := HexDigitChr[ B and $F ];
end;
{$else Delphi}
asm
{$IFDEF PARANOIA} DB $3C,9 {$ELSE} CMP AL,9 {$ENDIF}
JA @@1
{$IFDEF PARANOIA} DB $04, $30-$41+$0A {$ELSE} ADD AL,30h-41h+0Ah {$ENDIF}
@@1:
{$IFDEF PARANOIA} DB $04, $41-$0A {$ELSE} ADD AL,41h-0Ah {$ENDIF}
end;
{$endif FPC}
begin
Dest := @Buf[ 8 ];
Dest^ := #0;
repeat
Dec( Dest );
Dest^ := '0';
if Value <> 0 then
begin
Dest^ := HexDigit( Value and $F );
Value := Value shr 4;
end;
Dec( Digits );
until (Value = 0) and (Digits <= 0);
Result := Dest;
end;
{$ENDIF ASM_VERSION}
//[END Int2Hex]
//[FUNCTION Hex2Int]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Hex2Int( const Value : String) : Integer;
var I : Integer;
begin
Result := 0;
I := 1;
if Value = '' then Exit;
if Value[ 1 ] = '$' then Inc( I );
while I <= Length( Value ) do
begin
if Value[ I ] in [ '0'..'9' ] then
Result := (Result shl 4) or (Ord(Value[I]) - Ord('0'))
else
if Value[ I ] in [ 'A'..'F' ] then
Result := (Result shl 4) or (Ord(Value[I]) - Ord('A') + 10)
else
if Value[ I ] in [ 'a'..'f' ] then
Result := (Result shl 4) or (Ord(Value[I]) - Ord('a') + 10)
else
break;
Inc( I );
end;
end;
{$ENDIF ASM_VERSION}
//[END Hex2Int]
//[FUNCTION Octal2Int]
function Octal2Int( const Value: String ) : Integer;
var I: Integer;
begin
Result := 0;
for I := 1 to Length( Value ) do
begin
if Value[ I ] in [ '0'..'7' ] then
Result := Result * 8 + Ord( Value[ I ] ) - Ord( '0' )
else break;
end;
end;
//[END Octal2Int]
//[FUNCTION Binary2Int]
function Binary2Int( const Value: String ) : Integer;
var I: Integer;
begin
Result := 0;
for I := 1 to Length( Value ) do
begin
if Value[ I ] in [ '0'..'1' ] then
Result := Result * 2 + Ord( Value[ I ] ) - Ord( '0' )
else break;
end;
end;
//[END Binary2Int]
//[FUNCTION cHex2Int]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION}
function cHex2Int( const Value : String) : Integer;
begin
if StrEq( Copy( Value, 1, 2 ), '0x' ) then
Result := Hex2Int( CopyEnd( Value, 3 ) )
else Result := Hex2Int( Value );
end;
{$ENDIF ASM_VERSION}
//[END cHex2Int]
//[FUNCTION Int2Str]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Int2Str( Value : Integer ) : String;
var Buf : array[ 0..15 ] of Char;
Dst : PChar;
Minus : Boolean;
D: DWORD;
begin
Dst := @Buf[ 15 ];
Dst^ := #0;
Minus := False;
if Value < 0 then
begin
Value := -Value;
Minus := True;
end;
D := Value;
repeat
Dec( Dst );
Dst^ := Char( (D mod 10) + Byte( '0' ) );
D := D div 10;
until D = 0;
if Minus then
begin
Dec( Dst );
Dst^ := '-';
end;
Result := Dst;
end;
{$ENDIF ASM_VERSION}
//[END Int2Str]
procedure Int2PChar( s: PChar; Value: Integer );
var Buf : array[ 0..15 ] of Char;
Dst : PChar;
Minus : Boolean;
D: DWORD;
begin
Dst := @Buf[ 15 ];
Dst^ := #0;
Minus := False;
if Value < 0 then
begin
Value := -Value;
Minus := True;
end;
D := Value;
repeat
Dec( Dst );
Dst^ := Char( (D mod 10) + Byte( '0' ) );
D := D div 10;
until D = 0;
if Minus then
begin
Dec( Dst );
Dst^ := '-';
end;
StrCopy( s, Dst );
end;
//[function UInt2Str]
function UInt2Str( Value: DWORD ): String;
var Buf : array[ 0..15 ] of Char;
Dst : PChar;
D: DWORD;
begin
Dst := @Buf[ 15 ];
Dst^ := #0;
D := Value;
repeat
Dec( Dst );
Dst^ := Char( (D mod 10) + Byte( '0' ) );
D := D div 10;
until D = 0;
Result := Dst;
end;
//[function Int2StrEx]
function Int2StrEx( Value, MinWidth: Integer ): String;
begin
Result := Int2Str( Value );
while Length( Result ) < MinWidth do
Result := ' ' + Result;
end;
//[function Int2Rome]
function Int2Rome( Value: Integer ): String;
const RomeDigs = 'IVXLCDMT';
function RomeNum( N, FromIdx: Integer ): String;
begin
CASE N OF
1, 2, 3: Result := StrRepeat( RomeDigs[ FromIdx ], N );
4: Result := RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 1 ];
5, 6, 7, 8: Result := RomeDigs[ FromIdx + 1 ] + StrRepeat( RomeDigs[ FromIdx ],
N - 5 );
9: Result := RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 2 ]
else Result := '';
END;
end;
var I, J: Integer;
begin
Result := '';
if Value < 1 then Exit;
if Value > 8999 then Exit;
// maximum possible is TMMMCMXCIX, i.e. 8999
J := 1;
for I := 1 to 3 do
begin
Result := RomeNum( Value mod 10, J ) + Result;
Value := Value div 10;
if Value = 0 then Exit;
Inc( J, 2 );
end;
end;
//[FUNCTION Int2Ths]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Int2Ths( I : Integer ) : String;
var S : String;
begin
S := Int2Str( I );
Result := '';
while S <> '' do
begin
if Result <> '' then
Result := ThsSeparator + Result;
Result := CopyTail( S, 3 ) + Result;
S := Copy( S, 1, Length( S ) - 3 );
end;
if Copy( Result, 1, 2 ) = '-' + ThsSeparator then
Result := '-' + CopyEnd( Result, 3 );
end;
{$ENDIF ASM_VERSION}
//[END Int2Ths]
//[FUNCTION Int2Digs]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Int2Digs( Value, Digits : Integer ) : String;
var M : String;
begin
Result := Int2Str( Value );
M := '';
if Value < 0 then
begin
M := '-';
Result := CopyEnd( Result, 2 );
end;
if Digits >= 0 then
while Length( M + Result ) < Digits do
Result := '0' + Result
else
while Length( Result ) < -Digits do
Result := '0' + Result;
Result := M + Result;
end;
{$ENDIF ASM_VERSION}
//[END Int2Digs]
//[FUNCTION Num2Bytes]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Num2Bytes( Value : Double ) : String;
const Suffix = 'KMGT';
var V, I : Integer;
begin
Result := '';
I := 0;
while (Value >= 1024) and (I < 4) do
begin
Inc( I );
Value := Value / 1024.0;
end;
Result := Int2Str( Trunc( Value ) );
V := Trunc( (Value - Trunc( Value )) * 100 );
if V <> 0 then
begin
if (V mod 10) = 0 then
V := V div 10;
Result := Result + ',' + Int2Str( V );
end;
if I > 0 then
Result := Result + Suffix[ I ];
end;
{$ENDIF ASM_VERSION}
//[END Num2Bytes]
//[FUNCTION S2Int]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function S2Int( S: PChar ): Integer;
var M : Integer;
begin
Result := 0;
if S = '' then Exit;
M := 1;
if S^ = '-' then
begin
M := -1;
Inc( S );
end
else
if S^ = '+' then
Inc( S );
while S^ in [ '0'..'9' ] do
begin
Result := Result * 10 + Integer( S^ ) - Integer( '0' );
Inc( S );
end;
if M < 0 then
Result := -Result;
end;
{$ENDIF ASM_VERSION}
//[END S2Int]
//[FUNCTION Str2Int]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Str2Int(const Value : String) : Integer;
begin
Result := S2Int( PChar( Value ) );
end;
{$ENDIF ASM_VERSION}
//[END Str2Int]
//[function StrCopy]
{$ifdef cpu86}
function StrCopy( Dest, Source: PChar ): PChar; assembler;
asm
{$IFDEF F_P}
MOV EAX, [Dest]
MOV EDX, [Source]
{$ENDIF F_P}
PUSH EDI
PUSH ESI
MOV ESI,EAX
MOV EDI,EDX
OR ECX, -1
XOR AL,AL
REPNE SCASB
NOT ECX
MOV EDI,ESI
MOV ESI,EDX
MOV EDX,ECX
MOV EAX,EDI
SHR ECX,2
REP MOVSD
MOV ECX,EDX
AND ECX,3
REP MOVSB
POP ESI
POP EDI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$else}
function StrCopy( Dest, Source: PChar ): PChar;
var
counter : SizeInt;
Begin
counter := 0;
while Source[counter] <> #0 do
begin
Dest[counter] := char(Source[counter]);
Inc(counter);
end;
Dest[counter] := #0;
StrCopy := Dest;
end;
{$endif cpu86}
function StrCat( Dest, Source: PChar ): PChar;
begin
StrCopy( StrScan( Dest, #0 ), Source );
Result := Dest;
end;
//[function StrScan]
{$ifdef cpu86}
function StrScan(Str: PChar; Chr: Char): PChar; assembler;
asm
{$IFDEF F_P}
MOV EAX, [Str]
MOVZX EDX, [Chr]
{$ENDIF}
PUSH EDI
PUSH EAX
MOV EDI,Str
OR ECX, -1
XOR AL,AL
REPNE SCASB
NOT ECX
POP EDI
XCHG EAX, EDX
REPNE SCASB
XCHG EAX, EDI
POP EDI
JE @@1
XOR EAX, EAX
RET
@@1: DEC EAX
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$else}
function StrScan(Str: PChar; Chr: Char): PChar;
Begin
repeat
if Str^ = Chr then begin
Result := Str;
exit;
end;
Inc(Str);
until Str^ = #0;
StrScan := nil;
end;
{$endif cpu86}
//[function StrRScan]
{$ifdef cpu86}
function StrRScan(const Str: PChar; Chr: Char): PChar; assembler;
asm
{$IFDEF F_P}
MOV EAX, [Str]
MOVZX EDX, [Chr]
{$ENDIF F_P}
PUSH EDI
MOV EDI,Str
MOV ECX,0FFFFFFFFH
XOR AL,AL
REPNE SCASB
NOT ECX
STD
DEC EDI
MOV AL,Chr
REPNE SCASB
MOV EAX,0
JNE @@1
MOV EAX,EDI
INC EAX
@@1: CLD
POP EDI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$else}
function StrRScan(const Str: PChar; Chr: Char): PChar;
Var
count: longint;
index: longint;
Begin
count := Strlen(Str);
if Chr = #0 then
begin
StrRScan := @(Str[count]);
exit;
end;
Dec(count);
for index := count downto 0 do
begin
if Chr = Str[index] then
begin
StrRScan := @(Str[index]);
exit;
end;
end;
StrRScan := nil;
end;
{$endif cpu86}
//[function StrScanLen]
{$ifdef cpu86}
function StrScanLen(Str: PChar; Chr: Char; Len: Integer): PChar; assembler;
asm
{$IFDEF F_P}
MOV EAX, [Str]
MOVZX EDX, [Chr]
MOV ECX, [Len]
{$ENDIF F_P}
PUSH EDI
XCHG EDI, EAX
XCHG EAX, EDX
REPNE SCASB
XCHG EAX, EDI
POP EDI
{ -> EAX => to next character after found or to the end of Str,
ZF = 0 if character found. }
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$else}
function StrScanLen(Str: PChar; Chr: Char; Len: Integer): PChar;
Begin
Result:=Str;
while Len > 0 do begin
if Result^ = Chr then begin
Inc(Result);
break;
end;
Inc(Result);
Dec(Len);
end;
end;
{$endif cpu86}
//[FUNCTION TrimLeft]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TrimLeft(const S: KOLstring): KOLstring;
var
I, L: Integer;
begin
L := Length(S);
I := 1;
while (I <= L) and (S[I] <= ' ') do Inc(I);
Result := Copy(S, I, Maxint);
end;
{$ENDIF ASM_VERSION}
//[END TrimLeft]
//[FUNCTION TrimRight]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TrimRight(const S: KOLstring): KOLstring;
var
I: Integer;
begin
I := Length(S);
while (I > 0) and (S[I] <= ' ') do Dec(I);
Result := Copy(S, 1, I);
end;
{$ENDIF ASM_VERSION}
//[END TrimRight]
//[FUNCTION Trim]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function Trim( const S : KOLstring): KOLstring;
begin
Result := TrimLeft( TrimRight( S ) );
end;
{$ENDIF ASM_VERSION}
//[END Trim]
//[function RemoveSpaces]
function RemoveSpaces( const S: String ): String;
var I: Integer;
begin
Result := S;
for I := Length( S ) downto 1 do
if S[ I ] <= ' ' then Delete( Result, I, 1 );
end;
//[procedure Str2LowerCase]
{$ifdef cpu86}
procedure Str2LowerCase( S: PChar );
asm
{$IFDEF F_P}
MOV EAX, [S]
{$ENDIF}
XOR ECX, ECX
@@1:
MOV CL, byte ptr [EAX]
JECXZ @@exit
SUB CL, 'A'
CMP CL, 'Z'-'A'
JA @@2
ADD byte ptr [EAX], 32
@@2: INC EAX
JMP @@1
@@exit:
end {$IFDEF F_P} [ 'EAX', 'ECX' ] {$ENDIF};
{$else}
procedure Str2LowerCase( S: PChar );
begin
while S^ <> #0 do begin
if S^ in [ 'A'..'Z' ] then
Inc( S^, 32 );
Inc(S);
end;
end;
{$endif cpu86}
//[FUNCTION LowerCase]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function LowerCase(const S: string): string;
var I : Integer;
begin
Result := S;
for I := 1 to Length( S ) do
if Result[ I ] in [ 'A'..'Z' ] then
Inc( Result[ I ], 32 );
end;
{$ENDIF ASM_VERSION}
//[END LowerCase]
//[FUNCTION UpperCase]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function UpperCase(const S: string): string;
var I : Integer;
begin
Result := S;
for I := 1 to Length( S ) do
if Result[ I ] in [ 'a'..'z' ] then
Dec( Result[ I ], 32 );
end;
{$ENDIF ASM_VERSION}
//[END UpperCase]
{$IFDEF F_P}
//[function DummyStrFun]
function DummyStrFun( const S: String ): String;
begin
Result := S;
end;
{$ENDIF F_P}
//[FUNCTION CopyEnd]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString;
begin
Result := Copy( S, Idx, MaxInt );
end;
{$ENDIF ASM_VERSION}
//[END CopyEnd]
//[FUNCTION CopyTail]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function CopyTail( const S : KOLString; Len : Integer ) : KOLString;
var L : Integer;
begin
L := Length( S );
if L < Len then
Len := L;
Result := '';
if Len = 0 then Exit;
Result := Copy( S, L - Len + 1, Len );
end;
{$ENDIF ASM_VERSION}
//[END CopyTail]
//[PROCEDURE DeleteTail]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
procedure DeleteTail( var S : KOLString; Len : Integer );
var L : Integer;
begin
L := Length( S );
if Len > L then
Len := L;
Delete( S, L - Len + 1, Len );
end;
{$ENDIF ASM_VERSION}
//[END DeleteTail]
//[FUNCTION IndexOfChar]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function IndexOfChar( const S : String; Chr : Char ) : Integer;
var P, F : PChar;
begin
P := PChar( S );
F := StrScan( P, Chr );
Result := -1;
if F = nil then Exit;
Result := cardinal( F ) - cardinal( P ) + 1;
end;
{$ENDIF ASM_VERSION}
//[END IndexOfChar]
//[FUNCTION IndexOfCharsMin]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function IndexOfCharsMin( const S, Chars : String ) : Integer;
var I, J : Integer;
begin
Result := -1;
for I := 1 to Length( Chars ) do
begin
J := IndexOfChar( S, Chars[ I ] );
if J > 0 then
begin
if (Result < 0) or (J < Result) then
Result := J;
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END IndexOfCharsMin]
{$IFNDEF _FPC}
{$IFNDEF _D2}
//[function IndexOfWideCharsMin]
function IndexOfWideCharsMin( const S, Chars : WideString ) : Integer;
var I, J : Integer;
begin
Result := -1;
for I := 1 to Length( Chars ) do
begin
J := pos( Chars[ I ], S );
if J > 0 then
begin
if (Result < 0) or (J < Result) then
Result := J;
end;
end;
end;
{$ENDIF _D2}
{$ENDIF _FPC}
//[FUNCTION IndexOfStr]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function IndexOfStr( const S, Sub : String ) : Integer;
var I : Integer;
begin
Result := Length( S );
if Sub = '' then Exit;
Result := 0;
if S = '' then Exit;
if Length( Sub ) > Length( S ) then Exit;
Result := 1;
while Result + Length( Sub ) - 1 <= Length( S ) do
begin
I := IndexOfChar( CopyEnd( S, Result ), Sub[ 1 ] );
if I <= 0 then break;
Result := Result + I - 1;
if Result <= 0 then Exit;
if Copy( S, Result, Length( Sub ) ) = Sub then Exit;
Inc( Result );
end;
Result := -1;
end;
{$ENDIF ASM_VERSION}
//[END IndexOfStr]
//[FUNCTION Parse]
{$IFDEF ASM_UNICODE} //???
function Parse( var S : String; const Separators : String ) : String;
asm
PUSH EBX
PUSH EDI
MOV EBX, EAX
PUSH ECX
MOV EAX, [EBX]
CALL IndexOfCharsMin
INC EAX
JNE @@1
MOV EAX, [EBX]
CALL System.@LStrLen
INC EAX
INC EAX
@@1:
DEC EAX
MOV EDI, EAX
MOV ECX, EAX
DEC ECX
XOR EDX, EDX
INC EDX
MOV EAX, [EBX]
CALL System.@LStrCopy
MOV EAX, [EBX]
MOV EDX, EDI
INC EDX
MOV ECX, EBX
CALL CopyEnd
POP EDI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function Parse( var S : KOLString; const Separators : KOLString ) : KOLString;
var Pos : Integer;
begin
Pos := IndexOfCharsMin( S, Separators );
if Pos <= 0 then
Pos := Length( S ) + 1;
Result := S;
S := Copy( Result, Pos + 1, MaxInt );
Result := Copy( Result, 1, Pos - 1 );
end;
{$ENDIF ASM_VERSION}
//[END Parse]
{$IFNDEF _FPC}
{$IFNDEF _D2}
//[function WParse]
function WParse( var S : WideString; const Separators : WideString ) : WideString;
var Pos : Integer;
begin
Pos := IndexOfWideCharsMin( S, Separators );
if Pos <= 0 then
Pos := Length( S ) + 1;
Result := S;
S := Copy( Result, Pos + 1, MaxInt );
Result := Copy( Result, 1, Pos - 1 );
end;
{$ENDIF _D2}
{$ENDIF _FPC}
//[function ParsePascalString]
function ParsePascalString( var S : String; const Separators : String ) : String;
var Pos, Idx : Integer;
Hex, Spc : boolean;
procedure SkipSpaces;
begin
if not Spc then
while (Length( S ) >= Pos) and (S[ Pos ] = ' ') do
Inc( Pos );
end;
var Buf : String;
Ou, Val : Integer;
begin
Pos := 1;
Spc := IndexOfChar( Separators, ' ' ) >= 0;
SkipSpaces;
if Length( S ) < Pos then
begin
Result := S;
S := '';
exit;
end;
Buf := PChar( S );
Ou := 1;
if S[ Pos ] in [ '''', '#' ] then
begin
// skip here string constant expression
while Pos <= Length( S ) do
begin
if S[ Pos ] = '''' then
begin
Inc( Pos );
while Pos <= Length( S ) do
begin
if S[ Pos ] = '''' then
if (Pos = Length( S )) or (S[ Pos+1 ] <> '''') then
begin
Inc( Pos );
break;
end
else Inc( Pos );
Buf[ Ou ] := S[ Pos ];
Inc( Ou );
Inc( Pos );
end;
end
else
if S[ Pos ] = '#' then
begin
Inc( Pos ); Hex := False; Val := 0;
if (Pos < Length( S )) and (S[ Pos ] = '$') then
begin
Inc( Pos ); Hex := True;
end;
Dec( Pos );
while Pos < Length( S ) do
begin
Inc( Pos );
if (S[ Pos ] in [ '0'..'9' ]) or
Hex and (S[ Pos ] in [ 'a'..'f', 'A'..'F' ]) then
begin
if Hex then
Val := Val * 16
else
Val := Val * 10;
if S[ Pos ] <= '9' then
Val := Val + Integer( S[ Pos ] ) - Integer( '0' )
else
if S[ Pos ] <= 'F' then
Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'A' )
else
Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'a' );
continue;
end;
Inc( Pos ); break;
end;
Buf[ Ou ] := Char( Val );
Inc( Ou );
end
else break;
SkipSpaces;
if S[ Pos ] <> '+' then break;
SkipSpaces;
end;
end;
Idx := IndexOfCharsMin( CopyEnd( S, Pos ), Separators );
if Idx <= 0 then
begin
Result := Copy( Buf, 1, Ou - 1 ) + CopyEnd( S, Pos );
S := '';
end
else
begin
Result := Copy( Buf, 1, Ou - 1 ) + Copy( S, Pos, Idx - 1 );
S := CopyEnd( S, Pos + Idx );
end;
end;
//[function String2PascalStrExpr]
function String2PascalStrExpr( const S : String ) : String;
var I, Strt : Integer;
function String2DoubleQuotas( const S : String ) : String;
var I, J : Integer;
begin
if IndexOfChar( S, '''' ) <= 0 then
Result := S
else
begin
J := 0;
for I := 1 to Length( S ) do
if S[ I ] = '''' then Inc( J );
SetLength( Result, Length( S ) + J );
J := 1;
for I := 1 to Length( S ) do
begin
Result[ J ] := S[ I ];
Inc( J );
if S[ I ] = '''' then
begin
Result[ J ] := '''';
Inc( J );
end;
end;
end;
end;
begin
Result := '';
if S = '' then
begin
Result := '''''';
exit;
end;
Strt := 1;
for I := 1 to Length( S ) + 1 do
begin
if (I > Length( S )) or (S[ I ] < ' ') or (S[ I ] >= #$7F) then
begin
if (I > Strt) and (I > 1) then
begin
if Result <> '' then
Result := Result + '+';
Result := Result + '''' + String2DoubleQuotas( Copy( S, Strt, I - Strt ) ) + '''';
end;
if I > Length( S ) then break;
if Result <> '' then
Result := Result + '+'
else
Result := Result + '''''+';
Result := Result + '#' + Int2Str( Integer( S[ I ] ) );
Strt := I + 1;
end;
end;
end;
//[function CompareMem]
{$ifdef cpu86}
function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
asm
{$IFDEF F_P}
MOV EAX, [P1]
MOV EDX, [P2]
MOV ECX, [Length]
{$ENDIF}
PUSH ESI
PUSH EDI
MOV ESI,P1
MOV EDI,P2
MOV EDX,ECX
XOR EAX,EAX
AND EDX,3
SHR ECX,1
SHR ECX,1
REPE CMPSD
JNE @@2
MOV ECX,EDX
REPE CMPSB
JNE @@2
@@1: INC EAX
@@2: POP EDI
POP ESI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$else}
function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;
var
i: Integer;
begin
Result:=True;
I:=0;
If (P1)<>(P2) then
While Result and (i 0 then
begin
GetMem( Result, Size );
FillChar( Result^, Size, 0 );
end;
end;
{$ENDIF ASM_VERSION}
//[END AllocMem]
//[procedure DisposeMem]
procedure DisposeMem( var Addr : Pointer );
begin
if Addr <> nil then
FreeMem( Addr );
Addr := nil;
end;
{$IFDEF WIN}
//[function AnsiUpperCase]
function AnsiUpperCase(const S: string): string;
{$ifdef wince}
begin
Result:=WAnsiUpperCase(S);
end;
{$else}
var Len: Integer;
begin
Len := Length(S);
SetString(Result, PChar(S), Len);
if Len > 0 then CharUpperBuffA(Pointer(Result), Len);
end;
{$endif wince}
//[function AnsiLowerCase]
function AnsiLowerCase(const S: string): string;
{$ifdef wince}
begin
Result:=WAnsiLowerCase(S);
end;
{$else}
var
Len: Integer;
begin
Len := Length(S);
SetString(Result, PChar(S), Len);
if Len > 0 then CharLowerBuffA(Pointer(Result), Len);
end;
{$endif wince}
{$ENDIF WIN}
{$IFNDEF _D2}
{$IFNDEF _FPC}
//[function WAnsiUpperCase]
{$IFDEF WIN}
function WAnsiUpperCase(const S: WideString): WideString;
var Len: Integer;
begin
Result := S;
Len := Length(S);
if Len > 0 then CharUpperBuffW(Pointer(Result), Len);
end;
{$ENDIF WIN}
//[function WAnsiLowerCase]
{$IFDEF WIN}
function WAnsiLowerCase(const S: WideString): WideString;
var Len: Integer;
begin
Result := S;
Len := Length(S);
if Len > 0 then CharLowerBuffW(Pointer(Result), Len);
end;
{$ENDIF WIN}
{$IFDEF WIN}
function WStrComp(const S1, S2: WideString): Integer;
var i: Integer;
begin
for i := 1 to min( Length( S1 ), Length( S2 ) ) do
begin
Result := Ord( S1[ i ] ) - Ord( S2[ i ] );
if Result <> 0 then Exit;
end;
Result := Length( S1 ) - Length( S2 );
end;
function _WStrComp(S1, S2: PWideChar): Integer;
var Buf0: array[ 0..0 ] of WideChar;
begin
Buf0[ 0 ] := #0;
if S1 = nil then S1 := @ Buf0[ 0 ];
if S2 = nil then S2 := @ Buf0[ 0 ];
while TRUE do
begin
Result := Ord( S1^ ) - Ord( S2^ );
if Result <> 0 then Exit;
if S1^ = #0 then Exit;
end;
end;
function WStrScan(Str: PWideChar; Chr: WideChar): PWideChar;
begin
while (Str^ <> Chr) and (Str^ <> #0) do inc( Str );
Result := Str;
end;
function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar;
begin
Result := Str;
while Result^ <> #0 do inc( Result );
while (DWORD( Result ) >= DWORD( Str )) and
(Result^ <> Chr) do dec( Result );
if (DWORD( Result ) < DWORD( Str )) then
Result := nil;
end;
{$ENDIF WIN}
{$ENDIF _FPC}
{$ENDIF _D2}
//[function AnsiCompareStr]
{$IFDEF WIN}
function AnsiCompareStr(const S1, S2: KOLString): Integer;
begin
Result := CompareString(LOCALE_USER_DEFAULT, 0, PKOLChar(S1), -1, PKOLChar(S2), -1 ) - 2;
end;
{$ENDIF WIN}
//[function _AnsiCompareStr]
{$IFDEF WIN}
function _AnsiCompareStr(S1, S2: PKOLChar): Integer;
begin
Result := CompareString( LOCALE_USER_DEFAULT, 0, S1, -1,
S2, -1) - 2;
end;
{$ENDIF WIN}
//[function AnsiCompareStrNoCase]
{$IFDEF WIN}
function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer;
begin
Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PKOLChar(S1), -1,
PKOLChar(S2), -1 ) - 2;
end;
{$ENDIF WIN}
//[function _AnsiCompareStrNoCase]
{$IFDEF WIN}
function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer;
begin
Result := CompareString( LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1,
S2, -1) - 2;
end;
{$ENDIF WIN}
//[function AnsiCompareText]
function AnsiCompareText( const S1, S2: String ): Integer;
begin
Result := AnsiCompareStrNoCase( S1, S2 );
end;
//[function StrLCopy]
{$IFDEF ASM_VERSION}
function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler;
asm
{$IFDEF F_P}
MOV EAX, [Dest]
MOV EDX, [Source]
MOV ECX, [MaxLen]
{$ENDIF F_P}
PUSH EDI
PUSH ESI
PUSH EBX
MOV ESI,EAX
MOV EDI,EDX
MOV EBX,ECX
XOR AL,AL
TEST ECX,ECX
JZ @@1
REPNE SCASB
JNE @@1
INC ECX
@@1: SUB EBX,ECX
MOV EDI,ESI
MOV ESI,EDX
MOV EDX,EDI
MOV ECX,EBX
SHR ECX,2
REP MOVSD
MOV ECX,EBX
AND ECX,3
REP MOVSB
STOSB
MOV EAX,EDX
POP EBX
POP ESI
POP EDI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;
var
counter: cardinal;
Begin
counter := 0;
{ To be compatible with BP, on a null string, put two nulls }
If Source[0] = #0 then
Begin
Dest[0]:=Source[0];
Inc(counter);
end;
while (Source[counter] <> #0) and (counter < MaxLen) do
Begin
Dest[counter] := char(Source[counter]);
Inc(counter);
end;
{ terminate the string }
Dest[counter] := #0;
StrLCopy := Dest;
end;
{$ENDIF ASM_VERSION}
//[FUNCTION StrPCopy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function StrPCopy(Dest: PChar; const Source: string): PChar;
begin
Result := StrLCopy(Dest, PChar(Source), Length(Source));
end;
{$ENDIF ASM_VERSION}
//[END StrPCopy]
//[FUNCTION StrEq]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function StrEq( const S1, S2 : String ) : Boolean;
begin
Result := (Length( S1 ) = Length( S2 )) and
(LowerCase( S1 ) = LowerCase( S2 ));
end;
{$ENDIF ASM_VERSION}
//[END StrEq]
//[FUNCTION AnsiEq]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function AnsiEq( const S1, S2 : String ) : Boolean;
begin
Result := AnsiCompareStrNoCase( S1, S2 ) = 0;
end;
{$ENDIF ASM_VERSION}
//[END AnsiEq]
{$IFNDEF _D2}
{$IFNDEF _FPC}
//[function WAnsiEq]
function WAnsiEq( const S1, S2 : WideString ) : Boolean;
begin
Result := WAnsiLowerCase( S1 )=WAnsiLowerCase( S2 );
end;
{$ENDIF _FPC}
{$ENDIF _D2}
//[FUNCTION StrIn]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function StrIn(const S: String; const A: array of String): Boolean;
var I : Integer;
begin
for I := Low( A ) to High( A ) do
if StrEq( S, A[ I ] ) then
begin
Result := True;
Exit;
end;
Result := False;
end;
{$ENDIF ASM_VERSION}
//[END StrIn]
{$IFNDEF _D2}
{$IFNDEF _FPC}
//[function WStrIn]
function WStrIn( const S : WideString; const A : array of WideString ) : Boolean;
var I : Integer;
begin
for I := Low( A ) to High( A ) do
if WAnsiEq( S, A[ I ] ) then
begin
Result := True;
Exit;
end;
Result := False;
end;
{$ENDIF _FPC}
{$ENDIF _D2}
function CharIn( C: KOLChar; const A: TSetofChar ): Boolean;
begin
Result := (DWord( C ) <= 255) and (Char( C ) in A);
end;
//[function StrIs]
function StrIs( const S : String; const A : array of String; var Idx: Integer ) : Boolean;
var I : Integer;
begin
Idx := -1;
for I := Low( A ) to High( A ) do
if StrEq( S, A[ I ] ) then
begin
Idx := I;
Result := True;
Exit;
end;
Result := False;
end;
//[function IntIn]
function IntIn( Value: Integer; const List: array of Integer ): Boolean;
var I: Integer;
begin
Result := FALSE;
for I := 0 to High( List ) do
begin
if Value = List[ I ] then
begin
Result := TRUE;
break;
end;
end;
end;
//[FUNCTION _StrSatisfy]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function _StrSatisfy( S, Mask : PKOLChar ) : Boolean;
label next_char;
begin
next_char:
Result := True;
if (S^ = #0) and (Mask^ = #0) then exit;
if (Mask^ = '*') and (Mask[1] = #0) then exit;
if S^ = #0 then
begin
while Mask^ = '*' do
Inc( Mask );
Result := Mask^ = #0;
exit;
end;
Result := False;
if Mask^ = #0 then exit;
if Mask^ = '?' then
begin
Inc( S ); Inc( Mask ); goto next_char;
end;
if Mask^ = '*' then
begin
Inc( Mask );
while S^ <> #0 do
begin
Result := _StrSatisfy( S, Mask );
if Result then exit;
Inc( S );
end;
exit; // (Result = False)
end;
Result := S^ = Mask^;
Inc( S ); Inc( Mask );
if Result then goto next_char;
end;
{$ENDIF ASM_VERSION}
//[END _StrSatisfy]
//[FUNCTION StrSatisfy]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function StrSatisfy( const S, Mask: KOLString ): Boolean;
begin
Result := _StrSatisfy( PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase
{$ELSE} AnsiLowerCase {$ENDIF} ( S ) ),
PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase
{$ELSE} AnsiLowerCase {$ENDIF} ( Mask ) ) );
end;
{$ENDIF ASM_VERSION}
//[END StrSatisfy]
//[FUNCTION _2StrSatisfy]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} // Pascal
function _2StrSatisfy( S, Mask: PKOLChar ): Boolean;
begin
Result := StrSatisfy( S, Mask );
end;
{$ENDIF ASM_VERSION}
//[END _2StrSatisfy]
//[function StrReplace]
function StrReplace( var S: String; const From, ReplTo: String ): Boolean;
var I: Integer;
begin
I := pos( From, S );
if I > 0 then
begin
S := Copy( S, 1, I - 1 ) + ReplTo + CopyEnd( S, I + Length( From ) );
Result := TRUE;
end
else Result := FALSE;
end;
function KOLStrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean;
var I: Integer;
begin
I := pos( From, S );
if I > 0 then
begin
S := Copy( S, 1, I - 1 ) + ReplTo + CopyEnd( S, I + Length( From ) );
Result := TRUE;
end
else Result := FALSE;
end;
{-}
{$IFDEF _FPC}
//[procedure SetLengthW]
procedure SetLengthW( var W: WideString; NewLength: Integer );
begin
while Length( W ) < NewLength do
W := W + ' ' + W;
if Length( W ) > NewLength then
Delete( W, NewLength + 1, Length( W ) - NewLength );
end;
//[function CopyW]
function CopyW( const W: WideString; From, Count: Integer ): WideString;
begin
Result := '';
if Count <= 0 then Exit;
SetLengthW( Result, Count );
Move( W[ From ], Result[ 1 ], Count * Sizeof( WideChar ) );
end;
//[function posW]
function posW( const S1, S2: String ): Integer;
var I, L1: Integer;
begin
L1 := Length( S1 );
for I := 1 to Length( S2 )-L1+1 do
begin
if Copy( S2, I, L1 ) = S1 then
begin
Result := I;
Exit;
end;
end;
Result := 0;
end;
{$ENDIF _FPC}
{$IFNDEF _FPC}
{$IFNDEF _D2}
//[function WStrReplace]
function WStrReplace( var S: WideString; const From, ReplTo: WideString ): Boolean;
var I: Integer;
begin
I := pos( From, S );
if I > 0 then
begin
S := Copy( S, 1, I - 1 ) + ReplTo + Copy( S, I + Length( From ), MaxInt );
Result := TRUE;
end
else Result := FALSE;
end;
//[function WStrRepeat]
function WStrRepeat( const S: WideString; Count: Integer ): WideString;
var I, L: Integer;
begin
L := Length( S );
SetLength( Result, L * Count );
for I := 0 to Count-1 do
Move( S[ 1 ], Result[ 1 + I * L ], L * Sizeof( WideChar ) );
end;
{$ENDIF _D2}
{$ENDIF _FPC}
{+}
//[function StrRepeat]
function StrRepeat( const S: String; Count: Integer ): String;
var I, L: Integer;
begin
L := Length( S );
SetLength( Result, L * Count );
for I := 0 to Count-1 do
Move( S[ 1 ], Result[ 1 + I * L ], L );
end;
//[PROCEDURE NormalizeUnixText]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure NormalizeUnixText( var S: String );
var I: Integer;
begin
if S <> '' then
begin
if S[ 1 ] = #10 then
S[ 1 ] := #13;
for I := 2 to Length(S) do
if (S[I]=#10) and (S[I-1]<>#13) then
S[I] := #13;
end;
end;
{$ENDIF ASM_VERSION}
//[END NormalizeUnixText]
var Koi8_to_Ansi: array[ Char ] of Char;
procedure Koi8ToAnsi( s: PChar );
const KOI8_Rus: array[ #$C0..#$FF ] of Char = (
#254,
#224, #225, #246, #228, #229, #244, #227, #245, #232, #233, #234, #235, #235, #237, #238, #239,
#255, #240, #241, #242, #243, #230, #226, #252, #251, #231, #248, #253, #249, #247, #250,
#222,
#192, #193, #214, #196, #197, #212, #195, #213, #200, #201, #202, #203, #204, #205, #206, #207,
#223, #208, #209, #210, #211, #198, #194, #220, #219, #199, #216, #221, #217, #215, #218
);
var c: Char;
begin
if Koi8_to_Ansi[ #0 ] = #0 then
begin
for c := #1 to #255 do
begin
Koi8_to_Ansi[ c ] := c;
if (c >= #$C0) and (c <= #$FF) then
Koi8_to_Ansi[ c ] := KOI8_Rus[ c ];
end;
Koi8_to_Ansi[ #0 ] := #1;
end;
while s^ <> #0 do
begin
s^ := Koi8_to_Ansi[ s^ ];
inc( s );
end;
end;
//[function StrComp]
{$IFDEF ASM_VERSION}
function StrComp(const Str1, Str2: PChar): Integer; assembler;
asm
{$IFDEF F_P}
MOV EAX, [Str1]
MOV EDX, [Str2]
{$ENDIF F_P}
PUSH EDI
PUSH ESI
MOV EDI,EDX
XCHG ESI,EAX
OR ECX, -1
XOR EAX,EAX
REPNE SCASB
NOT ECX
MOV EDI,EDX
XOR EDX,EDX
REPE CMPSB
MOV AL,[ESI-1]
MOV DL,[EDI-1]
SUB EAX,EDX
POP ESI
POP EDI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
function StrComp(const Str1, Str2 : PChar): Integer;
var
counter: Integer;
Begin
counter := 0;
While str1[counter] = str2[counter] do
Begin
if (str2[counter] = #0) or (str1[counter] = #0) then
break;
Inc(counter);
end;
StrComp := ord(str1[counter]) - ord(str2[counter]);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}
function StrComp_NoCase(const Str1, Str2: PChar): Integer;
asm
{$IFDEF F_P}
MOV EAX, [Str1]
MOV EDX, [Str2]
{$ENDIF F_P}
PUSH EDI
PUSH ESI
MOV EDI,EDX
XCHG ESI,EAX
OR ECX, -1
XOR EAX,EAX
REPNE SCASB
NOT ECX
MOV EDI,EDX
@@0:
XOR EDX,EDX
REPE CMPSB
MOV AL,[ESI-1]
MOV AH, AL
SUB AH, 'a'
CMP AH, 25
JA @@1
SUB AL, $20
@@1:
MOV DL,[EDI-1]
MOV AH, DL
SUB AH, 'a'
CMP AH, 25
JA @@2
SUB DL, $20
@@2:
MOV AH, 0
SUB EAX,EDX
JNZ @@exit
CMP DL, 0
JNZ @@0
@@exit:
POP ESI
POP EDI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
function StrComp_NoCase(const Str1, Str2: PChar): Integer;
var
counter: Integer;
Begin
counter := 0;
While UpCase(str1[counter]) = UpCase(str2[counter]) do
Begin
if (str2[counter] = #0) or (str1[counter] = #0) then
break;
Inc(counter);
end;
Result := ord(UpCase(str1[counter])) - ord(UpCase(str2[counter]));
end;
{$ENDIF ASM_VERSION}
//[function StrLComp_NoCase]
{$IFDEF ASM_VERSION}
function StrLComp_NoCase(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
asm
{$IFDEF F_P}
MOV EAX, [Str1]
MOV EDX, [Str2]
MOV ECX, [MaxLen]
{$ENDIF F_P}
PUSH EDI
PUSH ESI
PUSH EBX
MOV EDI,EDX
MOV ESI,EAX
MOV EBX,ECX
XOR EAX,EAX
OR ECX,ECX
JE @@exit
REPNE SCASB
SUB EBX,ECX
MOV ECX,EBX
MOV EDI,EDX
@@0:
XOR EDX,EDX
REPE CMPSB
MOV AL,[ESI-1]
MOV AH, AL
SUB AH, 'a'
CMP AH, 25
JA @@1
SUB AL, $20
@@1:
MOV DL,[EDI-1]
MOV AH, DL
SUB AH, 'a'
CMP AH, 25
JA @@2
SUB DL, $20
@@2:
MOV AH, 0
SUB EAX,EDX
JECXZ @@exit
JZ @@0
@@exit:
POP EBX
POP ESI
POP EDI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
function StrLComp_NoCase(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
var
counter: cardinal;
c1, c2: char;
Begin
counter := 0;
if MaxLen = 0 then
begin
Result := 0;
exit;
end;
Repeat
c1 := UpCase(str1[counter]);
c2 := UpCase(str2[counter]);
if (c1 = #0) or (c2 = #0) then break;
Inc(counter);
Until (c1 <> c2) or (counter >= MaxLen);
Result := ord(c1) - ord(c2);
end;
{$ENDIF ASM_VERSION}
//[function StrLComp]
{$IFDEF ASM_VERSION}
function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; assembler;
asm
{$IFDEF F_P}
MOV EAX, [Str1]
MOV EDX, [Str2]
MOV ECX, [MaxLen]
{$ENDIF F_P}
PUSH EDI
PUSH ESI
PUSH EBX
MOV EDI,EDX
MOV ESI,EAX
MOV EBX,ECX
XOR EAX,EAX
OR ECX,ECX
JE @@1
REPNE SCASB
SUB EBX,ECX
MOV ECX,EBX
MOV EDI,EDX
XOR EDX,EDX
REPE CMPSB
MOV AL,[ESI-1]
MOV DL,[EDI-1]
SUB EAX,EDX
@@1: POP EBX
POP ESI
POP EDI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
var
counter: cardinal;
c1, c2: char;
Begin
counter := 0;
if MaxLen = 0 then
begin
StrLComp := 0;
exit;
end;
Repeat
c1 := str1[counter];
c2 := str2[counter];
if (c1 = #0) or (c2 = #0) then break;
Inc(counter);
Until (c1 <> c2) or (counter >= MaxLen);
StrLComp := ord(c1) - ord(c2);
end;
{$ENDIF ASM_VERSION}
//[function StrLen]
{$IFDEF ASM_VERSION}
function StrLen(const Str: PChar): Cardinal; assembler;
asm
{$IFDEF F_P}
MOV EAX, [Str]
{$ENDIF F_P}
XCHG EAX, EDI
XCHG EDX, EAX
OR ECX, -1
XOR EAX, EAX
CMP EAX, EDI
JE @@exit0
REPNE SCASB
DEC EAX
DEC EAX
SUB EAX,ECX
@@exit0:
MOV EDI,EDX
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
function StrLen(const Str: PChar): Cardinal;
var i : Cardinal;
begin
i:=0;
while Str[i]<>#0 do inc(i);
Result:=i;
end;
{$ENDIF ASM_VERSION}
//[FUNCTION __DelimiterLast]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar;
var
P, F : PKOLChar;
begin
P := Str;
Result := P + {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( Str );
while Delimiters^ <> #0 do
begin
F := {$IFDEF UNICODE_CTRLS} WStrRScan {$ELSE} StrRScan {$ENDIF}
( P, Delimiters^ );
if F <> nil then
if (Result^ = #0) or (cardinal(F) > cardinal(Result)) then
Result := F;
Inc( Delimiters );
end;
end;
{$ENDIF ASM_VERSION}
//[END __DelimiterLast]
{$IFDEF _D3orHigher}
function W__DelimiterLast( Str, Delimiters: PWideChar ): PWideChar;
var
P, F : PWideChar;
begin
P := Str;
Result := P + WStrLen( Str );
while Delimiters^ <> #0 do
begin
F := WStrRScan( P, Delimiters^ );
if F <> nil then
if (Result^ = #0) or (cardinal(F) > cardinal(Result)) then
Result := F;
Inc( Delimiters );
end;
end;
{$ENDIF _D3orHigher}
//[function SkipSpaces]
function SkipSpaces( P: PKOLChar ): PKOLChar;
begin
while True do
begin
while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
end;
Result := P;
end;
//[function SkipParam]
function SkipParam(P: PKOLChar): PKOLChar;
begin
P := SkipSpaces( P );
while P[0] > ' ' do
if P[0] = '"' then
begin
Inc(P);
while (P[0] <> #0) and (P[0] <> '"') do
Inc(P);
if P[0] <> #0 then Inc(P);
end
else
Inc(P);
Result := P;
end;
{$IFDEF WIN}
//[FUNCTION ParamStr]
function ParamStr( Idx: Integer ): KOLString;
var
P, P1: PKOLChar;
Buffer: array[ 0..260 ] of KOLChar;
begin
if Idx = 0 then
SetString( Result, Buffer, GetModuleFileName( 0, Buffer, Sizeof( Buffer ) ) )
else
begin
P := GetCommandLine;
{$ifdef wince}
Dec(Idx);
{$endif}
repeat
P := SkipSpaces( P );
P1 := P;
P := SkipParam(P);
if Idx = 0 then Break;
Dec(Idx);
until (Idx < 0) or (P = P1);
Result := Copy( P1, 1, P - P1 );
if Length( Result ) >= 2 then
if (Result[ 1 ] = '"') and (Result[ Length( Result ) ] = '"') then
Result := Copy( Result, 2, Length( Result ) - 2 );
end;
end;
//[END ParamStr]
//[FUNCTION ParamCount]
function ParamCount: Integer;
var
S: string;
begin
Result := 0;
while True do
begin
S := ParamStr(Result + 1);
if S = '' then Break;
Inc(Result);
end;
end;
//[END ParamCount]
{$ENDIF WIN}
//[FUNCTION DelimiterLast]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function DelimiterLast( const Str, Delimiters: KOLString ): Integer;
var PStr: PKOLChar;
begin
PStr := PKOLChar( Str );
Result := cardinal( __DelimiterLast( PStr, PKOLChar( Delimiters ) ) )
- cardinal( PStr )
+ {$IFDEF UNICODE_CTRLS} 2 {$ELSE} 1 {$ENDIF}; // {Viman}
{$IFDEF UNICODE_CTRLS} Result := Result div SizeOf( WideChar ) {$ENDIF};
end;
{$ENDIF ASM_VERSION}
//[END DelimiterLast]
// Thanks to Marco Bobba - Marisa Bo for this code
//[function StrIsStartingFrom]
{$IFDEF ASM_UNICODE}
function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
asm
{$IFDEF F_P}
MOV EAX, [Str]
MOV EDX, [Pattern]
{$ENDIF F_P}
XOR ECX, ECX
@@1:
MOV CL, [EDX] // pattern[ i ]
INC EDX
MOV CH, [EAX] // str[ i ]
INC EAX
JECXZ @@2 // str = pattern; CL = #0, CH = #0
CMP CL, CH
JE @@1
@@2:
TEST CL, CL
SETZ AL
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE}
function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
begin
Result := FALSE;
while Pattern^ <> #0 do
begin
if Str^ <> Pattern^ then Exit;
inc( Str );
inc( Pattern );
end;
Result := TRUE;
end;
{$ENDIF ASM_UNICODE}
{$IFDEF ASM_VERSION}
function StrIsStartingFromNoCase( Str, Pattern: PChar ): Boolean;
asm
{$IFDEF F_P}
MOV EAX, [Str]
MOV EDX, [Pattern]
{$ENDIF F_P}
XOR ECX, ECX
@@1:
MOV CL, [EDX] // pattern[ i ]
INC EDX
MOV CH, [EAX] // str[ i ]
INC EAX
JECXZ @@2 // str = pattern; CL = #0, CH = #0
CMP CL, 'a'
JB @@cl_ok
CMP CL, 'z'
JA @@cl_ok
SUB CL, 32
@@cl_ok:
CMP CH, 'a'
JB @@ch_ok
CMP CH, 'z'
JA @@ch_ok
SUB CH, 32
@@ch_ok:
CMP CL, CH
JE @@1
@@2:
TEST CL, CL
SETZ AL
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE ASM_VERSION} //Pascal
function StrIsStartingFromNoCase( Str, Pattern: PChar ): Boolean;
begin
Result := FALSE;
while Pattern^ <> #0 do
begin
if UpCase(Str^) <> UpCase(Pattern^) then Exit;
inc( Str );
inc( Pattern );
end;
Result := TRUE;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN}
{$IFNDEF _FPC}
//[FUNCTION Format]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function Format( const fmt: KOLString; params: array of const ): KOLString;
var Buffer: array[ 0..2047 ] of KOLChar;
ElsArray, El: ^pointer;
I : Integer;
begin
ElsArray := nil;
if High( params ) >= 0 then
GetMem( ElsArray, (High( params ) + 1) * sizeof( Pointer ) );
El := ElsArray;
for I := 0 to High( params ) do
begin
El^ := params[ I ].VPointer;
Inc( El );
end;
wvsprintf( @Buffer[0], PKOLChar( fmt ), PChar( ElsArray ) );
Result := Buffer;
if ElsArray <> nil then
FreeMem( ElsArray );
end;
{$ENDIF ASM_VERSION}
//[END Format]
{$ENDIF WIN}
//[function LStrFromPWCharLen]
function LStrFromPWCharLen(Source: PWideChar; Length: Integer): String;
var
DestLen: Integer;
Buffer: array[0..2047] of Char;
begin
if Length <= 0 then
begin
Result := '';
Exit;
end;
if Length < SizeOf(Buffer) div 2 then
begin
DestLen := WideCharToMultiByte(0, 0, Source, Length,
Buffer, SizeOf(Buffer), nil, nil);
if DestLen > 0 then
begin
Result := Buffer;
Exit;
end;
end;
DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil);
// _LStrFromPCharLen(Dest, nil, DestLen);
SetLength( Result, DestLen );
WideCharToMultiByte(0, 0, Source, Length, Pointer(Result), DestLen, nil, nil);
end;
//[function LStrFromPWChar]
{$IFDEF ASM_VERSION}
function LStrFromPWChar(Source: PWideChar): String;
{* from Delphi5 - because D2 does not contain it. }
asm
PUSH EDX
XOR EDX,EDX
TEST EAX,EAX
JE @@5
PUSH EAX
@@0: CMP DX,[EAX+0]
JE @@4
CMP DX,[EAX+2]
JE @@3
CMP DX,[EAX+4]
JE @@2
CMP DX,[EAX+6]
JE @@1
ADD EAX,8
JMP @@0
@@1: ADD EAX,2
@@2: ADD EAX,2
@@3: ADD EAX,2
@@4: XCHG EDX,EAX
POP EAX
SUB EDX,EAX
SHR EDX,1
@@5: POP ECX
JMP LStrFromPWCharLen
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE ASM_VERSION}
function LStrFromPWChar(Source: PWideChar): String;
begin
Result:=Source;
end;
{$ENDIF ASM_VERSION}
{$ENDIF _FPC}
/////////////////////////////////////////////////////////////////////////
//
//
// F I L E S
//
//
/////////////////////////////////////////////////////////////////////////
//[FILES]
{
This part of the unit modified by Tim Slusher and Vladimir Kladov.
}
{* Set of utility methods to work with files
and reqistry.
When programming KOL, which is Windows API-oriented, You should
avoid alien (for Windows) embedded Pascal files handling, and
use API-calls which implemented very well. This set of functions
is intended to make this easier.
Also TDirList object implementation present here and some registry
access functions, which allow to make code more elegant.
}
{$UNDEF ASM_LOCAL}
{$IFDEF ASM_VERSION}
{$DEFINE ASM_LOCAL}
{$ENDIF ASM_VERSION}
//[FUNCTION FileCreate]
{$IFDEF WIN}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle;
var Attr: DWORD;
begin
Attr := (OpenFlags shr 16) and $1FFF;
if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL;
Result := CreateFile( PKOLChar(FileName), OpenFlags and $F0000000,
OpenFlags and $F, nil, (OpenFlags shr 8) and $F,
Attr, 0 );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
//[END FileCreate]
{$IFDEF _D3orHigher}
function WFileCreate(const FileName: WideString; OpenFlags: DWord): THandle;
var Attr: DWORD;
begin
Attr := (OpenFlags shr 16) and $1FFF;
if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL;
Result := CreateFileW( PWideChar(FileName), OpenFlags and $F0000000,
OpenFlags and $F, nil, (OpenFlags shr 8) and $F,
Attr, 0 );
end;
{$ENDIF _D3orHigher}
//[FUNCTION FileClose]
{$IFDEF WIN}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function FileClose(Handle: THandle): boolean;
begin
Result := CloseHandle(Handle);
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
//[END FileClose]
{$UNDEF ASM_LOCAL}
{$IFDEF ASM_UNICODE}
{$DEFINE ASM_LOCAL}
{$ENDIF}
{$IFDEF FILE_EXISTS_EX}
{$UNDEF ASM_LOCAL}
{$ENDIF}
//[FUNCTION FileExists]
{$IFDEF WIN}
{$IFDEF ASM_LOCAL}
{$ELSE ASM_VERSION} //Pascal
function FileExists( const FileName : KOLString ) : Boolean;
{$IFDEF FILE_EXISTS_EX}
var FD: TFindFileData;
//F: DWORD;
LFT: TFileTime;
Hi, Lo: Word;
{$ELSE}
var Code: Integer;
{$ENDIF}
begin
{$IFDEF FILE_EXISTS_EX}
Result := FALSE;
if not Find_First( Filename, FD ) then Exit;
Find_Close( FD );
if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then Exit;
FileTimeToLocalFileTime( FD.ftLastWriteTime, LFT );
if FileTimeToDosDateTime( LFT, Hi, Lo ) then Result := TRUE;
{$ELSE}
Code := GetFileAttributes(PKOLChar(FileName));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
//[END FileExists]
{$IFDEF _D3orHigher}
function WFileExists( const FileName: WideString ) : Boolean;
{$IFDEF notimplemented_FILE_EXISTS_EX}
var FD: TFindFileData;
//F: DWORD;
LFT: TFileTime;
Hi, Lo: Word;
{$ELSE}
var Code: Integer;
{$ENDIF}
begin
{$IFDEF notimplemented_FILE_EXISTS_EX}
Result := FALSE;
if not WFind_First( Filename, FD ) then Exit;
WFind_Close( FD );
if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then Exit;
FileTimeToLocalFileTime( FD.ftLastWriteTime, LFT );
if FileTimeToDosDateTime( LFT, Hi, Lo ) then Result := TRUE;
{$ELSE}
Code := GetFileAttributesW(PWideChar(FileName));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);
{$ENDIF}
end;
{$ENDIF _D3orHigher}
//[FUNCTION FileSeek]
{$IFDEF WIN}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function FileSeek(Handle: THandle; MoveTo: integer; MoveMethod: TMoveMethod): DWord;
begin
Result := SetFilePointer(Handle, MoveTo, nil, Ord( MoveMethod ) );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
//[END FileSeek]
{$IFDEF _D4orHigher}
{$IFDEF WIN}
function FileFarSeek(Handle: THandle; MoveTo: Int64; MoveMethod: TMoveMethod): DWord;
begin
Result := SetFilePointer(Handle, MoveTo, nil, Ord( MoveMethod ) );
end;
{$ENDIF WIN}
{$ENDIF _D4orHigher}
//[FUNCTION FileRead]
{$IFDEF WIN}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;
begin
if not ReadFile(Handle, Buffer, Count, Result, nil) then
Result := 0;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
//[END FileRead]
//[FUNCTION File2Str]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function File2Str(Handle: THandle): String;
var Pos, Size: DWORD;
begin
Result := '';
if Handle = 0 then Exit;
Pos := FileSeek( Handle, 0, spCurrent );
Size := GetFileSize( Handle, nil );
SetString( Result, nil, Size - Pos + 1 );
FileRead( Handle, Result[ 1 ], Size - Pos );
Result[ Size - Pos + 1 ] := #0;
end;
{$ENDIF ASM_VERSION}
//[END File2Str]
{$IFNDEF _D2}
function File2WStr(Handle: THandle): WideString;
var Pos, Size: DWORD;
begin
Result := '';
if Handle = 0 then Exit;
Pos := FileSeek( Handle, 0, spCurrent );
Size := GetFileSize( Handle, nil );
SetString( Result, nil, (Size - Pos + 1)*Sizeof( WideChar ) );
FileRead( Handle, Result[ 1 ], Size - Pos );
Result[ Size - Pos + 1 ] := #0;
end;
{$ENDIF _D2}
//[FUNCTION FileWrite]
{$IFDEF WIN}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord;
begin
if not WriteFile(Handle, Buffer, Count, Result, nil) then
Result := 0;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
//[END FileWrite]
//[FUNCTION FileEOF]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function FileEOF( Handle: THandle ) : Boolean;
var Siz, Pos : DWord;
begin
Siz := GetFileSize( Handle, nil );
Pos := FileSeek( Handle, 0, spCurrent );
Result := Pos >= Siz;
end;
{$ENDIF ASM_VERSION}
//[END FileEOF]
//[FUNCTION FileFullPath]
{$IFDEF WIN}
{$IFDEF ASM_noVERSION_UNICODE}
function FileFullPath( const FileName: String ) : String;
const
BkSlash: String = '\';
szTShFileInfo = sizeof( TShFileInfo );
asm
PUSH EBX
PUSH ESI
MOV EBX, EDX
PUSH EAX
XCHG EAX, EDX
CALL System.@LStrClr
POP EDX
PUSH 0
MOV EAX, ESP
CALL System.@LStrAsg
MOV ESI, ESP
@@loo: CMP dword ptr [ESI], 0
JZ @@fin
MOV EAX, ESI
MOV EDX, [BkSlash]
PUSH 0
MOV ECX, ESP
CALL Parse
CMP dword ptr [EBX], 0
JE @@1
MOV EAX, EBX
MOV EDX, [BkSlash]
CALL System.@LStrCat
JMP @@2
@@1:
POP EAX
PUSH EAX
CALL System.@LStrLen
CMP EAX, 2
JNE @@2
POP EAX
PUSH EAX
CMP byte ptr [EAX+1], ':'
JNE @@2
MOV EAX, EBX
POP EDX
PUSH EDX
CALL System.@LStrAsg
JMP @@3
@@2:
PUSH 0
MOV EAX, ESP
MOV EDX, [EBX]
CALL System.@LStrAsg
MOV EAX, ESP
MOV EDX, [ESP+4]
CALL System.@LStrCat
POP EAX
PUSH EAX
SUB ESP, szTShFileInfo
MOV EDX, ESP
PUSH SHGFI_DISPLAYNAME
PUSH szTShFileInfo
PUSH EDX
PUSH 0
PUSH EAX
CALL ShGetFileInfo
LEA EDX, [ESP].TShFileInfo.szDisplayName
CMP byte ptr [EDX], 0
JE @@clr_stk
LEA EAX, [ESP+szTShFileInfo+4]
CALL System.@LStrFromPChar
@@clr_stk:
ADD ESP, szTShFileInfo
CALL RemoveStr
POP EDX
PUSH EDX
MOV EAX, EBX
CALL System.@LStrCat
@@3: CALL RemoveStr
JMP @@loo
@@fin: CALL RemoveStr
POP ESI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function FileFullPath( const FileName: KOLString ) : KOLString;
var SFI: TShFileInfo;
Src, S: KOLString;
begin
Result := '';
Src := FileName;
while Src <> '' do
begin
S := Parse( Src, '\' );
if Result <> '' then
Result := Result + '\';
if (Result = '') and (Length( S ) = 2) and (S[ 2 ] = ':') then
Result := S
else
begin
{$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
( PKOLChar( Result + S ), 0, SFI, Sizeof( SFI ), SHGFI_DISPLAYNAME );
if SFI.szDisplayName[ 0 ] <> #0 then
S := SFI.szDisplayName;
Result := Result + S;
end;
end;
if ExtractFileExt( Result ) = '' then
// case when flag 'Hide extensions for registered file types' is set on
// in the Explorer:
Result := Result + ExtractFileExt( FileName );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
//[END FileFullPath]
{$IFDEF WIN}
//[function FileShortPath]
function FileShortPath( const FileName: KOLString ): KOLString;
{$ifdef wince}
begin
Result:=FileName;
end;
{$else wince}
var Buf: array[ 0..MAX_PATH ] of KOLChar;
begin
GetShortPathName( PKOLChar( FileName ), Buf, Sizeof( Buf ) );
Result := Buf;
end;
{$endif wince}
//[function FileIconSystemIdx]
function FileIconSystemIdx( const Path: KOLString ): Integer;
var SFI: TShFileInfo;
begin
SFI.iIcon := 0; // Bartov
{$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
( PKOLChar( Path ), 0, SFI, sizeof( SFI ), SHGFI_SMALLICON or SHGFI_SYSICONINDEX );
Result := SFI.iIcon;
end;
//[function FileIconSysIdxOffline]
function FileIconSysIdxOffline( const Path: KOLString ): Integer;
var SFI: TShFileInfo;
begin
SFI.iIcon := 0; // Bartov
{$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
( PKOLChar( Path ), FILE_ATTRIBUTE_NORMAL, SFI, sizeof( SFI ),
SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES );
Result := SFI.iIcon;
end;
{$ENDIF WIN}
//[procedure LogFileOutput]
procedure LogFileOutput( const filepath, str: String );
var F: THandle;
Tmp: String;
begin
F := FileCreate( filepath, ofOpenWrite or ofOpenAlways or ofShareDenyWrite );
if F = INVALID_HANDLE_VALUE then Exit;
FileSeek( F, 0, spEnd );
Tmp := str + {$IFDEF LIN} #10 {$ELSE} #13#10 {$ENDIF};
FileWrite( F, PChar( Tmp )^, Length( Tmp ) );
FileClose( F );
end;
//[function StrLoadFromFile]
function StrLoadFromFile( const Filename: KOLString ): String;
var F: THandle;
begin
{$IFDEF WIN32}
if StrEq( Filename, 'CON' ) then
Result := File2Str(GetStdHandle(STD_INPUT_HANDLE))
else
{$ENDIF WIN32}
begin
Result := '';
F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );
if F = INVALID_HANDLE_VALUE then Exit;
Result := File2Str( F );
FileClose( F ); {Dark Knight}
end;
end;
//[function StrSaveToFile]
function StrSaveToFile( const Filename: KOLString; const Str: String ): Boolean;
begin
Result := Mem2File( PKOLChar( Filename ), PChar( Str ), Length( Str ) )
= Length( Str );
end;
{$IFNDEF _D2}
function WStrLoadFromFile( const Filename: KOLString ): WideString;
var F: THandle;
begin
{$IFDEF WIN32}
if StrEq( Filename, 'CON' ) then
Result := File2WStr(GetStdHandle(STD_INPUT_HANDLE))
else
{$ENDIF WIN32}
begin
Result := '';
F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );
if F = INVALID_HANDLE_VALUE then Exit;
Result := File2Str( F );
FileClose( F ); {Dark Knight}
end;
end;
function WStrSaveToFile( const Filename: KOLString; const Str: WideString ): Boolean;
begin
Result := Mem2File( PKOLChar( Filename ), PWideChar( Str ), Length( Str ) )
= Length( Str );
end;
{$ENDIF _D2}
//[function Mem2File]
function Mem2File( Filename: PKOLChar; Mem: Pointer; Len: Integer ): Integer;
var F: THandle;
begin
Result := 0;
F := FileCreate( Filename, ofOpenWrite or ofCreateAlways );
if F = INVALID_HANDLE_VALUE then Exit;
Result := FileWrite( F, Mem^, Len );
FileClose( F );
end;
//[function File2Mem]
function File2Mem( Filename: PKOLChar; Mem: Pointer; MaxLen: Integer ): Integer;
var F: THandle;
begin
Result := 0;
F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );
if F = INVALID_HANDLE_VALUE then Exit;
Result := FileRead( F, Mem^, MaxLen );
FileClose( F );
end;
{$IFDEF WIN}
function Find_First( const FilePathName: KOLString; var F: TFindFileData ): Boolean;
begin
F.FindHandle := FindFirstFile( PKOLChar( FilePathName ),
{$IFDEF UNICODE_CTRLS} PWin32FindDataW {$ELSE} PWin32FindData {$ENDIF}
( @ F )^ );
Result := F.FindHandle <> INVALID_HANDLE_VALUE;
end;
function Find_Next( var F: TFindFileData ): Boolean;
begin
Result := FindNextFile( F.FindHandle,
{$IFDEF UNICODE_CTRLS} PWin32FindDataW {$ELSE} PWin32FindData {$ENDIF}
( @ F )^ );
end;
procedure Find_Close( var F: TFindFileData );
begin
Windows.FindClose( F.FindHandle );
end;
{$ENDIF WIN}
//[FUNCTION FileSize]
{$IFDEF WIN}
function FileSize( const Path: KOLString ) : {$IFDEF _D2orD3} Integer {$ELSE} Int64 {$ENDIF};
var FD : TFindFileData;
begin
Result := 0;
if not Find_First( Path, FD ) then exit;
{$IFDEF _D2orD3}
Result := FD.nFileSizeLow;
{$ELSE}
I64( Result ).Lo := FD.nFileSizeLow;
I64( Result ).Hi := FD.nFileSizeHigh;
{$ENDIF}
Find_Close( FD );
end;
{$ENDIF WIN}
//[END FileSize]
//[procedure FileTime]
procedure FileTime( const Path: KOLString;
CreateTime, LastAccessTime, LastModifyTime: PFileTime );
var FD : TFindFileData;
begin
if not Find_First( Path, FD ) then exit;
if CreateTime <> nil then
CreateTime^ := FD.ftCreationTime;
if LastAccessTime <> nil then
LastAccessTime^ := FD.ftLastAccessTime;
if LastModifyTime <> nil then
LastModifyTime^ := FD.ftLastWriteTime;
Find_Close( FD );
end;
//[function GetUniqueFilename]
function GetUniqueFilename( PathName: KOLstring ) : KOLString;
var Path, Nam, Ext : KOLString;
I, J, K : Integer;
begin
Result := PathName;
Path := ExtractFilePath( PathName );
if not DirectoryExists( Path ) then Exit;
Nam := ExtractFileNameWOext( PathName );
if Nam = '' then
begin
Path := ExcludeTrailingPathDelimiter( Path );
PathName := Path;
Result := Path;
end;
Nam := ExtractFileNameWOext( PathName );
Ext := ExtractFileExt( PathName );
I := Length( Nam );
for J := I downto 1 do
if not ((Nam[ J ] >= '0') and (Nam[ J ] <= '9')) then
begin
I := J;
break;
end;
K := Str2Int( CopyEnd( Nam, I + 1 ) );
while FileExists( Result ) do
begin
Inc( K );
Result := Path + Copy( Nam, 1, I ) + Int2Str( K ) + Ext;
end;
end;
{$IFDEF WIN}
//[FUNCTION CompareSystemTime]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function CompareSystemTime(const D1, D2 : TSystemTime) : Integer;
var R: Integer;
procedure CompareFields(const F1, F2 : Integer);
begin
if R <> 0 then Exit;
if F1 = F2 then Exit;
if F1 < F2 then
R := -1
else
R := 1;
end;
begin
R := 0;
CompareFields( D1.wYear, D2.wYear );
CompareFields( D1.wMonth, D2.wMonth );
CompareFields( D1.wDay, D2.wDay );
CompareFields( D1.wHour, D2.wHour );
CompareFields( D1.wMinute, D2.wMinute );
CompareFields( D1.wSecond, D2.wSecond );
CompareFields( D1.wMilliseconds, D2.wMilliseconds );
Result := R;
end;
{$ENDIF ASM_VERSION}
//[END CompareSystemTime]
//[function FileTimeCompare]
function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;
var ST1, ST2 : TSystemTime;
begin
FileTimeToSystemTime( FT1, ST1 );
FileTimeToSystemTime( FT2, ST2 );
Result := CompareSystemTime( ST1, ST2 );
end;
{$ENDIF WIN}
{$IFDEF WIN}
//[FUNCTION DirectoryExists]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function DirectoryExists(const Name: KOLString): Boolean;
var
Code: Integer;
{$ifndef wince}
e: DWORD;
{$endif wince}
begin
{$ifndef wince}
e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
{$endif wince}
Code := GetFileAttributes(PKOLChar(Name));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
{$ifndef wince}
SetErrorMode( e );
{$endif wince}
end;
{$ENDIF ASM_VERSION}
//[END DirectoryExists]
function DiskPresent( const DrivePath: KOLString ): Boolean;
{$ifndef wince}
var e: DWORD;
restore: Boolean;
{$endif wince}
begin
{$ifndef wince}
e := 0;
Restore := FALSE;
if (Copy( DrivePath, 1, 2 ) = '\\') then
else
CASE GetDriveType( PKOLChar( DrivePath ) ) OF
DRIVE_REMOVABLE, DRIVE_CDROM, DRIVE_RAMDISK:
begin
e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
Restore := TRUE;
end;
END;
{$endif wince}
Result := DirectoryExists( DrivePath );
{$ifndef wince}
if Restore then
SetErrorMode( e );
{$endif wince}
end;
{$IFDEF _D3orHigher}
function WDirectoryExists(const Name: WideString): Boolean;
var
Code: Integer;
begin
Code := GetFileAttributesW(PWideChar(Name));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;
{$ENDIF _D3orHigher}
{$ENDIF WIN}
//[function CheckDirectoryContent]
function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean; const Mask: String ): Boolean;
var FD: TFindFileData;
begin
if not DirectoryExists( Name ) then
Result := TRUE
else
begin
if not Find_First( IncludeTrailingPathDelimiter( Name ) + Mask, FD ) then
Result := TRUE
else
begin
Result := TRUE;
repeat
if not {$IFDEF UNICODE_CTRLS}WStrIn{$ELSE}StrIn{$ENDIF}( FD.cFileName, ['.','..'] ) then
begin
if SubDirsOnly and LongBool(FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)
or not SubDirsOnly then
begin
Result := FALSE;
break;
end;
end;
until not Find_Next( FD );
Find_Close( FD );
end;
end;
end;
//[function DirectoryEmpty]
function DirectoryEmpty(const Name: KOLString): Boolean;
begin
Result := CheckDirectoryContent( Name, FALSE, '*.*' );
end;
//[function DirectoryHasSubdirs]
function DirectoryHasSubdirs( const Path: KOLString ): Boolean;
begin
Result := not CheckDirectoryContent( Path, TRUE, '*.*' );
end;
//[FUNCTION GetStartDir]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
{$IFDEF WIN}
{$UNDEF LINUX_USE_HOME_STARTFDIR}
{$ENDIF}
function GetStartDir : KOLString;
{$IFNDEF LINUX_USE_HOME_STARTFDIR}
var Buffer:array[0..MAX_PATH] of KOLChar;
I : Integer;
{$ENDIF}
begin
{$IFDEF LINUX_USE_HOME_STARTFDIR}
Result := getenv( 'HOME' );
{$ELSE}
I := GetModuleFileName( 0, Buffer, MAX_PATH );
for I := I downto 0 do
if Buffer[ I ] = {$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF} then
begin
Buffer[ I + 1 ] := #0;
break;
end;
Result := Buffer;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END GetStartDir]
//[FUNCTION ExePath]
function ExePath: KOLString;
var Buffer: array[ 0..MAX_PATH+1 ] of KOLChar;
begin
Buffer[ MAX_PATH+1 ] := #0;
GetModuleFileName( hInstance, Buffer, MAX_PATH+1 );
Result := Buffer;
end;
{-}
//[function DirectorySize]
function DirectorySize( const Path: KOLString ): I64;
var DirList: PDirList;
I: Integer;
begin
Result := MakeInt64( 0, 0 );
DirList := NewDirList( Path, {$IFDEF LIN} '*' {$ELSE} '*.*' {$ENDIF}, 0 );
for I := 0 to DirList.Count-1 do
begin
if LongBool( DirList.Items[ I ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY ) then
Result := Add64( Result, DirectorySize( DirList.Path + DirList.Names[ I ] ) )
else
Result := Add64( Result, MakeInt64( DirList.Items[ I ].nFileSizeLow,
DirList.Items[ I ].nFileSizeHigh ) );
end;
DirList.Free;
end;
{+}
{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
//[function GetFileList]
function GetFileList(const dir: string): PStrList;
var
Srch: TFindFileData;
succ: boolean;
begin
result := nil;
succ := Find_First(dir, Srch);
while succ do begin
if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin
if Result = nil then begin
Result := NewStrList;
end;
Result.Add(Srch.cFileName);
end;
succ := Find_Next(Srch);
end;
Find_Close(Srch);
end;
{$ENDIF WIN}
//[function ExcludeTrailingChar]
function ExcludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
begin
Result := S;
if Result <> '' then
if Result[ Length( Result ) ] = C then
Delete( Result, Length( Result ), 1 );
end;
//[function IncludeTrailingChar]
{$IFDEF ASM_UNICODE}
function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
asm
push edx
push ecx
xchg ecx, eax
xchg edx, ecx
call System.@LStrAsg
pop eax
pop edx
mov ecx, [eax]
jecxz @@1
add ecx, [ecx-4]
dec ecx
cmp byte ptr [ecx], dl
jz @@exit
@@1:
push eax
push 0
mov eax, esp
call System.@LStrFromChar
mov edx, [esp]
mov eax, [esp+4]
call System.@LStrCat
call RemoveStr
pop eax
@@exit:
end;
{$ELSE PASCAL}
function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
begin
Result := S;
if (Result = '') or (Result[ Length( Result ) ] <> C) then
Result := Result + C;
end;
{$ENDIF ASM_VERSION}
//---------------------------------------------------------
// Following functions/procedures are created by Edward Aretino:
// IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter,
// ForceDirectories, CreateDir, ChangeFileExt
//---------------------------------------------------------
//[function IncludeTrailingPathDelimiter]
function IncludeTrailingPathDelimiter(const S: KOLstring): KOLstring;
begin
Result := IncludeTrailingChar( S, {$IFDEF UNIX} '/' {$ELSE} '\' {$ENDIF} );
end;
//[function ExcludeTrailingPathDelimiter]
function ExcludeTrailingPathDelimiter(const S: KOLstring): KOLstring;
begin
Result := ExcludeTrailingChar( S, {$IFDEF UNIX} '/' {$ELSE} '\' {$ENDIF} );
end;
function ExtractFileDrive( const Path: KOLString ) : KOLString;
var i, j: Integer;
begin
Result := Path;
if Result = '' then Exit;
if pos( ':', Result ) > 1 then
Result := Parse( Result, ':' ) + ':\'
else
if Length( Result ) > 2 then
begin
j := 0;
for i := 3 to Length( Result ) do
if Result[ i ] = '\' then
begin
inc( j );
if j = 2 then
begin
Result := Copy( Result, 1, i );
break;
end;
end;
Result := IncludeTrailingPathDelimiter( Result );
end
else
if Length( Result ) = 1 then
Result := Result + ':\';
end;
//[FUNCTION ExtractFilePath]
{$IFDEF ASM_LStrFromPCharLen} // LStrFromPCharLen - there are no in D2
function ExtractFilePath( const Path : String ) : String;
asm
PUSH EDX
MOV EDX, [DirDelimiters]
CALL EAX2PChar
PUSH EAX
CALL __DelimiterLast
XCHG EDX, EAX
XOR ECX, ECX
POP EAX
CMP byte ptr [EDX], CL
JZ @@ret_0
SUB EDX, EAX
INC EDX
XCHG EDX, EAX
XCHG ECX, EAX
@@ret_0:
POP EAX
CALL System.@LStrFromPCharLen
end;
{$ELSE} //Pascal
function ExtractFilePath( const Path : KOLString ) : KOLString;
//var I : Integer;
var P, P0: PKOLChar;
begin
P0 := PKOLChar( Path );
P := __DelimiterLast( P0, ':\/' );
if P^ = #0 then
Result := ''
else
Result := Copy( Path, 1, P - P0 + 1 );
end;
{$ENDIF ASM_VERSION}
{$IFDEF _D3orHigher}
function WExtractFilePath( const Path: WideString ) : WideString;
var P, P0: PWideChar;
begin
P0 := PWideChar( Path );
P := W__DelimiterLast( P0, ':\/' );
if P^ = #0 then
Result := ''
else
Result := Copy( Path, 1, P - P0 + 1 );
end;
{$ENDIF}
{$IFDEF ASM_VERSION}
{$IFNDEF _D2}
{$DEFINE ASM_LStrFromPCharLen}
{$ENDIF}
{$ENDIF ASM_VERSION}
{$IFDEF ASM_LStrFromPCharLen}
{$DEFINE ASM_DIRDelimiters}
{$ENDIF}
{$IFDEF ASM_VERSION}
{$DEFINE ASM_DIRDelimiters}
{$ENDIF ASM_VERSION}
{$IFDEF ASM_DIRDelimiters}
const
DirDelimiters: PChar = ':\/';
{$ENDIF}
function IsNetworkPath( const Path: KOLString ): Boolean;
begin
Result := (Length( Path ) >= 2) and (Path[1] = '\') and (Path[2] = '\');
end;
//[FUNCTION ExtractFileName]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function ExtractFileName( const Path : KOLString ) : KOLString;
var P: PKOLChar;
begin
P := __DelimiterLast( PKOLChar( Path ), ':\/' );
if P^ = #0 then
Result := Path
else
Result := P + 1;
end;
{$ENDIF ASM_VERSION}
//[END ExtractFileName]
//[function ExtractFileNameWOext]
{$IFDEF ASM_UNICODE}
function ExtractFileNameWOext( const Path : KOLString ) : KOLString;
asm
push ebx
push edx
push eax
call ExtractFileName
pop edx // Path - не нужен больше
mov eax, [esp] // eax = Result = ExtractFileName(Path)
mov eax, [eax]
push 0
mov edx, esp
call ExtractFileExt
mov eax, [esp]
call System.@LStrLen
xchg ebx, eax // ebx = Length(ExtractFileExt(Result))
call RemoveStr // ExtractFileExt - больше не нужен
mov eax, [esp]
mov eax, [eax]
call System.@LStrLen // eax = Length(Result)
sub eax, ebx
xchg ecx, eax
xor edx, edx
inc edx
mov eax, [esp]
mov eax, [eax]
call System.@LStrCopy
pop ebx
end;
{$ELSE PASCAL}
function ExtractFileNameWOext( const Path : KOLString ) : KOLString;
begin
Result := ExtractFileName( Path );
Result := Copy( Result, 1, Length( Result ) - Length( ExtractFileExt( Result ) ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
const
ExtDelimeters: PChar = '.';
//[function ExtractFileExt]
function ExtractFileExt( const Path : KOLString ) : KOLString;
asm
PUSH EDX
MOV EDX, [ExtDelimeters]
CALL EAX2PChar
CALL __DelimiterLast
@@1: XCHG EDX, EAX
POP EAX
CALL System.@LStrFromPChar
end;
{$ELSE ASM_VERSION} //Pascal
function ExtractFileExt( const Path : KOLString ) : KOLString;
var P: PKOLChar;
begin
P := __DelimiterLast( PKOLChar( Path ), '.' );
Result := P;
end;
{$ENDIF ASM_VERSION}
//[END ExtractFilePath]
//[function ReplaceExt]
{$IFDEF ASM_UNICODE}
function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
asm
push ecx // result
push edx // NewExt
push eax // Path
push 0
mov edx, esp
call ExtractFilePath
pop eax
xchg [esp], eax // eax=Path, Path in stack replaced with ExtractFilePath(Path)
push 0
mov edx, esp
call ExtractFileNameWOext
// now stack conatins: result,NewExt,ExtractFilePath(Path),ExtractFileNameWOext(Path)<-ESP
mov eax, [esp+12]
mov edx, esp
push dword ptr [edx+4] // ExtractFilePath(Path)
push dword ptr [edx] // ExtractFileNameWOext(Path)
push dword ptr [edx+8] // NewExt
mov edx, 3
call System.@LStrCatN
call RemoveStr
call RemoveStr
pop ecx
pop ecx
end;
{$ELSE PASCAL}
function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
begin
Result := ExtractFilePath( Path ) + ExtractFileNameWOext( Path ) +
NewExt;
end;
{$ENDIF}
//[function ForceDirectories]
function ForceDirectories(Dir: KOLString): Boolean;
begin
Result := Length(Dir) > 0; {Centronix}
If not Result then Exit;
Dir := ExcludeTrailingPathDelimiter(Dir);
If (Length(Dir) < 3) or DirectoryExists(Dir) or
(ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
end;
//[function CreateDir]
function CreateDir(const Dir: KOLString): Boolean;
begin
Result := {$IFDEF WIN} {Windows.}CreateDirectory(PKOLChar(Dir), nil)
{$ELSE LIN} Libc.__mkdir(PChar(Dir), S_IRWXU or S_IRWXG or S_IRWXO) = 0
{$ENDIF};
end;
//[function ChangeFileExt]
function ChangeFileExt(FileName: KOLString; const Extension: KOLstring): KOLstring;
var
FileExt: KOLString;
begin
FileExt := ExtractFileExt(FileName);
DeleteTail(FileName, Length(FileExt));
Result := FileName+ Extension;
end;
//[function ReplaceFileExt]
function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString;
begin
Result := ExtractFilePath( Path ) +
ExtractFileNameWOext( ExtractFileName( Path ) ) +
NewExt;
end;
{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
//[function ExtractShortPathName]
function ExtractShortPathName( const Path: KOLString ): KOLString;
{$ifdef wince}
begin
Result:=Path;
{$else}
var
Buffer: array[0..MAX_PATH - 1] of KOLChar;
begin
SetString(Result, Buffer,
GetShortPathName(PKOLChar(Path), Buffer, SizeOf(Buffer) div Sizeof(KOLChar)));
{$endif wince}
end;
{$IFDEF GDI}
//[function FilePathShortened]
function FilePathShortened( const Path: KOLString; MaxLen: Integer ): KOLString;
begin
Result := FilePathShortenPixels( Path, 0, MaxLen );
end;
//[function PixelsLength]
function PixelsLength( DC: HDC; const Text: KOLString ): Integer;
var Sz: TSize;
begin
if DC = 0 then
Result := Length( Text )
else
begin
{Windows.}GetTextExtentPoint32( DC, PKOLChar( Text ), Length( Text ), Sz );
Result := Sz.cx;
end;
end;
//[function FilePathShortenPixels]
function FilePathShortenPixels( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
var L0, L1: Integer;
Prev: KOLString;
begin
Result := Path;
L0 := PixelsLength( DC, Result );
while L0 > MaxPixels do
begin
Prev := Result;
L1 := pos( '\...\', Result );
if L1 <= 0 then
Result := ExcludeTrailingPathDelimiter( ExtractFilePath( Result ) )
else
Result := Copy( Result, 1, L1 - 1 );
if Result <> '' then
Result := IncludeTrailingPathDelimiter( ExtractFilePath( Result ) ) + '...\' + ExtractFileName( Path );
if (Result = '') or (Result = Prev) then
begin
L1 := Length( ExtractFilePath( Result ) );
while (PixelsLength( DC, Result ) > MaxPixels) and (L1 > 1) do
begin
Dec( L1 );
Result := Copy( Result, 1, L1 ) + '...\' + ExtractFileName( Result );
end;
if PixelsLength( DC, Result ) > MaxPixels then
begin
L1 := MaxPixels + 1;
while ((MaxPixels > 0) and (L1 > 1) or (MaxPixels = 0) and (L1 > 0)) and
(PixelsLength( DC, Result ) > MaxPixels) do
begin
Dec( L1 );
Result := Copy( ExtractFileName( Path ), 1, L1 ) + '...';
end;
end;
break;
end;
L0 := PixelsLength( DC, Result );
end;
end;
{$ENDIF GDI}
//[procedure CutFirstDirectory]
procedure CutFirstDirectory(var S: KOLString);
var
Root: Boolean;
P: Integer;
begin
if S = '\' then
S := ''
else
begin
if S[1] = '\' then
begin
Root := True;
Delete(S, 1, 1);
end
else
Root := False;
if S[1] = '.' then
Delete(S, 1, 4);
P := pos('\',S);
if P <> 0 then
begin
Delete(S, 1, P);
S := '...\' + S;
end
else
S := '';
if Root then
S := '\' + S;
end;
end;
{$IFDEF GDI}
//[function MinimizeName]
function MinimizeName( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
var
Drive, Dir, Name: KOLString;
begin
Result := Path;
Dir := ExtractFilePath(Result);
Name := ExtractFileName(Result);
if (Length(Dir) >= 2) and (Dir[2] = ':') then
begin
Drive := Copy(Dir, 1, 2);
Delete(Dir, 1, 2);
end
else
Drive := '';
while ((Dir <> '') or (Drive <> '')) and (PixelsLength(DC, Result) > MaxPixels) do
begin
if Dir = '\...\' then
begin
Drive := '';
Dir := '...\';
end
else if Dir = '' then
Drive := ''
else
CutFirstDirectory(Dir);
Result := Drive + Dir + Name;
end;
end;
{$ENDIF GDI}
//[function GetSystemDir]
function GetSystemDir: KOLString;
{$ifdef wince}
begin
Result:=GetWindowsDir;
{$else}
var Buf: array[ 0..MAX_PATH ] of KOLChar;
begin
GetSystemDirectory( @ Buf[ 0 ], MAX_PATH + 1 );
Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
{$endif wince}
end;
//*
//[function GetWindowsDir]
function GetWindowsDir : KOLstring;
{$ifdef wince}
var
wPath : array[0..MAX_PATH] of WideChar;
begin
if SHGetSpecialFolderPath(0, wPath, $0024{CSIDL_WINDOWS}, False) then
Result:=IncludeTrailingPathDelimiter(wPath)
else
Result:='';
{$else}
var Buf : array[ 0..MAX_PATH ] of KOLChar;
begin
GetWindowsDirectory( @Buf[ 0 ], MAX_PATH + 1 );
Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
{$endif wince}
end;
{$ENDIF WIN} //^^^^^^^^^^^
//[function GetWorkDir]
{$IFDEF WIN}
function GetWorkDir : KOLstring;
{$ifdef wince}
begin
Result:='\';
{$else}
var Buf: array[ 0..MAX_PATH ] of Char;
begin
GetCurrentDirectory( MAX_PATH + 1, @ Buf[ 0 ] );
Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
{$endif wince}
end;
{$ENDIF WIN}
//[function GetTempDir]
{$IFDEF ASM_UNICODE}
function GetTempDir : KOLstring;
asm
push eax
sub esp, 264
push esp
push 261
call GetTempPath
mov edx, esp
mov eax, [esp+264]
call System.@LStrFromPChar
add esp, 264
pop edx
mov eax, [edx]
call IncludeTrailingPathDelimiter
end;
{$ELSE PASCAL}
function GetTempDir : KOLstring;
{$IFDEF WIN} var Buf : array[ 0..MAX_PATH ] of KOLChar; {$ENDIF WIN}
begin
{$IFDEF LIN} Result := '/tmp/'; {$ELSE WIN}
GetTempPath( MAX_PATH + 1, @Buf[ 0 ] );
Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
{$ENDIF WIN}
end;
{$ENDIF}
{$IFDEF WIN}
//[function CreateTempFile]
{$IFDEF ASM_UNICODE}
function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
asm
push ecx
call EAX2PCHAR
call EDX2PCHAR
sub esp, 264
push esp
push 0
push edx
push eax
call GetTempFileName
mov eax, [esp+264]
mov edx, esp
call System.@LStrFromPChar
add esp, 268
end;
{$ELSE PASCAL}
function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
var Buf: array[ 0..MAX_PATH ] of KOLChar;
begin
GetTempFileName( PKOLChar( DirPath ), PKOLChar( Prefix ), 0, Buf );
Result := Buf;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
//[function GetFileListStr]
function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLstring): KOLstring;
{* List of files in string, separating each path from others with FileOpSeparator.
E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}
var
Srch: TFindFileData;
succ: boolean;
dir:KOLstring;
begin
result := '';
if (FPath<>'') then FPath := IncludeTrailingPathDelimiter( FPath );
if (FMask<>'') and (FMask[1]={$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF}) then
FMask := CopyEnd(FMask,2);
dir:=FPath+FMask;
succ := Find_First(dir, Srch);
while succ do begin
if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin
if Result<>''then Result:=Result+FileOpSeparator;
Result:=Result+FPath+Srch.cFileName;
end;
succ := Find_Next(Srch);
end;
Find_Close(Srch);
end;
//[function DeleteFiles]
function DeleteFiles( const DirPath: KOLString ): Boolean;
var Files, Name: KOLString;
begin
Files := GetFileListStr( ExtractFilePath( DirPath ), ExtractFileName( DirPath ) );
Result := TRUE;
while Files <> '' do
begin
Name := Parse( Files, FileOpSeparator );
Result := Result and DeleteFile( PKOLChar( Name ) );
end;
end;
{$IFDEF WIN_GDI} //>>>>>>>>>>>>
//[function DeleteFile2Recycle]
function DeleteFile2Recycle( const Filename : KOLString ) : Boolean;
begin
Result := DoFileOp( Filename, '', FO_DELETE, FOF_ALLOWUNDO or
FOF_NOCONFIRMATION or FOF_SIMPLEPROGRESS, 'Deleting...' );
end;
//[function CopyMoveFiles]
function CopyMoveFiles( const FromList, ToList: KOLString; Move: Boolean ): Boolean;
begin
Result := DoFileOp(FromList, ToList, FO_COPY - Integer( Move ),
FOF_ALLOWUNDO, nil); //|\\ FO_COPY = 2, FO_MOVE = 1
end;
{-}
//[function DiskFreeSpace]
function DiskFreeSpace( const Path: KOLString ): I64;
var
FBA, TNB: I64;
{$ifdef wince}
begin
GetDiskFreeSpaceEx( PKOLChar( Path ), @ FBA, @ TNB, @Result )
{$else}
type TGetDFSEx = function( Path: PKOLChar; CallerFreeBytes, TotalBytes, FreeBytes: Pointer )
: Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
var GetDFSEx: TGetDFSEx;
Kern32: THandle;
V: TOSVersionInfo;
Ex: Boolean;
SpC, BpS, NFC, TNC: DWORD;
begin
GetDFSEx := nil;
V.dwOSVersionInfoSize := Sizeof( V );
GetVersionEx
( POSVersionInfo( @ V )^ ); // bug in Windows.pas !
Ex := FALSE;
if V.dwPlatformId = VER_PLATFORM_WIN32_NT then
begin
Ex := V.dwMajorVersion >= 4;
end
else
if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
begin
Ex := V.dwMajorVersion > 4;
if not Ex then
if V.dwMajorVersion = 4 then
begin
Ex := V.dwMinorVersion > 0;
if not Ex then
Ex := LoWord( V.dwBuildNumber ) >= $1111;
end;
end;
if Ex then
begin
Kern32 := GetModuleHandle( 'kernel32' );
GetDFSEx := GetProcAddress( Kern32, 'GetDiskFreeSpaceExA' );
end;
if Assigned( GetDFSEx ) then
GetDFSEx( PKOLChar( Path ), @ FBA, @ TNB, @Result )
else
begin
GetDiskFreeSpace( PKOLChar( Path ), SpC, BpS, NFC, TNC );
Result := Mul64i( MakeInt64( SpC * BpS, 0 ), NFC );
end;
{$endif wince}
end;
{+}
//[END FILES]
//[function DoFileOp]
function DoFileOp( const FromList, ToList: KOLString; FileOp: UINT; Flags: Word;
Title: PKOLChar): Boolean;
var FOS : {$IFDEF UNICODE_CTRLS}TSHFileOpStructW{$ELSE}TSHFileOpStruct{$ENDIF};
Buf : PKOLChar;
L : Integer;
begin
L := Length( FromList );
Buf := AllocMem( L+2 );
Move( FromList[ 1 ], Buf^, L );
for L := L downto 0 do
if Buf[ L ] = FileOpSeparator then Buf[ L ] := #0;
FillChar( FOS, Sizeof( FOS ), #0 );
if Applet <> nil then
FOS.Wnd := Applet.Handle;
FOS.wFunc := FileOp;
FOS.lpszProgressTitle := Title;
FOS.pFrom := Buf;
FOS.pTo := PKOLChar( ToList + #0 );
FOS.fFlags := Flags;
FOS.fAnyOperationsAborted := True;
Result := {$IFDEF UNICODE_CTRLS}SHFileOperationW{$ELSE}SHFileOperationA{$ENDIF}( FOS ) = 0;
if Result then
Result := not FOS.fAnyOperationsAborted;
FreeMem( Buf );
end;
{$ENDIF WIN_GDI}
{$IFDEF WIN}
//[function DirIconSysIdxOffline]
function DirIconSysIdxOffline( const Path: KOLString ): Integer;
var SFI: TShFileInfo;
begin
SFI.iIcon := 0; // Bartov
{$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
( PKOLChar( Path ), FILE_ATTRIBUTE_DIRECTORY, SFI, sizeof( SFI ),
SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES );
Result := SFI.iIcon;
end;
{$ENDIF WIN}
{ TDirList }
//[function NewDirList]
function NewDirList( const DirPath, Filter: KOLString; Attr: DWORD ): PDirList;
begin
{-}
New( Result, Create );
{+}{++}(*Result := PDirList.Create;*){--}
Result.ScanDirectory( DirPath, Filter, Attr );
end;
//[END NewDirList]
//[function NewDirListEx]
function NewDirListEx( const DirPath, Filters: KOLString; Attr: DWORD ): PDirList;
begin
{-}
New( Result, Create );
{+}{++}(*Result := PDirList.Create;*){--}
Result.ScanDirectoryEx( DirPath, Filters, Attr );
end;
//[END NewDirListEx]
//[procedure TDirList.Clear]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TDirList.Clear;
begin
if FList <> nil then
FList.Release;
FList := nil;
end;
{$ENDIF ASM_VERSION}
//[destructor TDirList.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TDirList.Destroy;
begin
Clear;
FPath := '';
inherited;
end;
{$ENDIF ASM_VERSION}
//[FUNCTION FindFilter]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function FindFilter(const Filter: KOLString): KOLString;
begin
Result := Filter;
if Result = '' then Result := '*.*';
end;
{$ENDIF ASM_VERSION}
//[END FindFilter]
//+
//[function TDirList.Get]
function TDirList.Get(Idx: Integer): PFindFileData;
begin
Result := FList.fItems[ Idx ];
end;
//[function TDirList.GetCount]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TDirList.GetCount: Integer;
begin
Result := 0;
if FList = nil then Exit;
Result := FList.Count;
end;
{$ENDIF ASM_VERSION}
//[function TDirList.GetNames]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TDirList.GetNames(Idx: Integer): KOLString;
begin
Result := PKOLChar(@PFindFileData(fList.fItems[ Idx ]).cFileName[0]);
end;
{$ENDIF ASM_VERSION}
//[function TDirList.GetIsDirectory]
function TDirList.GetIsDirectory(Idx: Integer): Boolean;
begin
Result := LongBool( Items[ Idx ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY );
end;
{$IFDEF ASM_noVERSION}
//[function TDirList.SatisfyFilter]
function TDirList.SatisfyFilter(FileName: PChar; FileAttr,
FindAttr: DWord): Boolean;
asm
PUSH EBX
PUSH ESI
PUSH EDI
XCHG EBX, EAX // EBX = @ Self
MOV EAX, [FindAttr]
MOV EDI, EDX // EDI = FileName
MOV EDX, EAX
AND EDX, ECX
CMP EDX, EAX
JE @@1
TEST AL, FILE_ATTRIBUTE_NORMAL
JZ @@ret_false
@@1:
CMP word ptr [EDI], '.'
JE @@1_1
CMP word ptr [EDI], '..'
JNE @@1_1
CMP byte ptr [EDI+2], 0
JNE @@1_1
@@1_0:
MOV ECX, [FindAttr]
TEST CL, FILE_ATTRIBUTE_NORMAL
JZ @@1_1
CMP ECX, FILE_ATTRIBUTE_NORMAL
JE @@1_1
TEST AL, FILE_ATTRIBUTE_DIRECTORY
JZ @@1_1
TEST CL, FILE_ATTRIBUTE_DIRECTORY
JNZ @@ret_true
@@1_1:
MOV ECX, [EBX].fFilters
JECXZ @@ret_false //?
MOV ESI, [ECX].TStrList.fList
MOV ESI, [ESI].TList.fItems
MOV ECX, [ECX].TStrList.fCount
JECXZ @@ret_false
@@2:
LODSD
TEST EAX, EAX
JZ @@nx_filter
PUSHAD
MOV EDX, [EAX]
CMP DX, $002E
JE @@F_d_dd
AND EDX, $FFFFFF
CMP EDX, $002E2E
JE @@F_d_dd
MOV EDX, [EDI]
CMP DX, $002E
JE @@4
AND EDX, $FFFFFF
CMP EDX, $002E2E
JE @@4
JMP @@chk_anti
@@F_d_dd:
MOV EDX, EDI
PUSH EAX
CALL StrComp
TEST EAX, EAX
POP EAX
JZ @@popad_ret_true
@@chk_anti:
XCHG EDX, EAX // EDX = filter[ i ]
MOV EAX, EDI // EAX = FileName
CMP byte ptr [EDX], '^'
JNE @@3
INC EDX
CALL _2StrSatisfy
TEST AL, AL
JZ @@4
POPAD
JMP @@ret_false
@@3: CALL _2StrSatisfy
TEST AL, AL
JZ @@4
@@popad_ret_true:
POPAD
@@ret_true:
MOV AL, 1
JMP @@exit
@@4: POPAD
@@nx_filter:
LOOP @@2
@@ret_false:
XOR EAX, EAX
@@exit:
POP EDI
POP ESI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TDirList.SatisfyFilter(FileName: PKOLChar; FileAttr,
FindAttr: DWord): Boolean;
{$IFDEF F_P}
const Dot: String = '.';
{$ENDIF F_P}
var I: Integer;
F: PKOLChar;
HasOnlyNegFilters: Boolean;
begin
Result := (((FileAttr and FindAttr) = FindAttr) or
LongBool(FindAttr and FILE_ATTRIBUTE_NORMAL));
if not Result then Exit;
if (FileName <> {$IFDEF UNICODE_CTRLS} WideString( '.' )
{$ELSE} {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
{$ENDIF UNICODE_CTRLS} ) and
(FileName <> '..') then
if LongBool( FindAttr and FILE_ATTRIBUTE_NORMAL ) and
(FindAttr <> FILE_ATTRIBUTE_NORMAL) then
if LongBool( FindAttr and FILE_ATTRIBUTE_DIRECTORY ) and
LongBool( FileAttr and FILE_ATTRIBUTE_DIRECTORY ) then Exit;
HasOnlyNegFilters := TRUE;
for I := 0 to fFilters.Count - 1 do
begin
F := PKOLChar(fFilters.fList.fItems[ I ]);
if F = '' then continue;
if (F = {$IFDEF UNICODE_CTRLS} WideString( '.' ) {$ELSE}
{$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
{$ENDIF UNICODE_CTRLS} ) or (F = '..') then
begin
if FileName = F then
Exit;
end
else
if (Filename = {$IFDEF UNICODE_CTRLS} WideString( '.' ) {$ELSE}
{$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
{$ENDIF UNICODE_CTRLS} ) or (FileName = '..') then
continue;
if F[ 0 ] = '^' then
begin
if StrSatisfy( FileName, PChar(@F[ 1 ]) ) then
begin
Result := False;
Exit;
end;
end
else
begin
HasOnlyNegFilters := FALSE;
if StrSatisfy( FileName, F ) then
begin
Result := True;
Exit;
end;
end;
end;
Result := HasOnlyNegFilters and
(FileName <> {$IFDEF UNICODE_CTRLS} WideString( '.' ) {$ELSE}
{$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
{$ENDIF UNICODE_CTRLS} ) and (FileName <> '..');
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_nononoVERSION}
//[procedure TDirList.ScanDirectory]
procedure TDirList.ScanDirectory(const DirPath, Filter: KOLString;
Attr: DWord);
const sz_win32finddata = sizeof(TWin32FindData);
asm
PUSH EBX
PUSH EDI
MOV EBX, EAX
PUSHAD
CALL Clear
CALL NewList
MOV [EBX].fList, EAX
POPAD
PUSHAD
LEA EAX, [EBX].fPath
CALL System.@LStrAsg
POPAD
MOV EAX, [EBX].fPath
TEST EAX, EAX
JE @@exit
PUSHAD
LEA EDX, [EBX].fPath
MOV EAX, [EDX]
CALL IncludeTrailingPathDelimiter
MOV EAX, [EBX].fFilters
TEST EAX, EAX
JNZ @@1
CALL NewStrList
MOV [EBX].fFilters, EAX
POPAD
PUSHAD
PUSH ECX
XCHG EAX, ECX
MOV EDX, offset[@@star_d_star]
CALL StrComp
TEST AL, AL
POP EDX
JNZ @@asg_Filter
MOV EDX, offset[@@star]
@@asg_Filter:
MOV EAX, [EBX].fFilters
CALL TStrList.Add
JMP @@1
@@star_d_star:
DB '*.*', 0
DD -1, 1
@@star: DB '*', 0
@@1:
POPAD
ADD ESP, -sz_win32finddata
XOR EDX, EDX
PUSH EDX
PUSH EDX
XCHG EAX, ECX
MOV EDX, ESP
CALL FindFilter
LEA EAX, [ESP+4]
MOV EDX, [EBX].fPath
POP ECX
PUSH ECX
CALL System.@LStrCat3
CALL RemoveStr
POP EAX
MOV EDX, ESP
PUSH EAX
PUSH EDX
PUSH EAX
CALL FindFirstFile
MOV EDI, EAX
INC EAX
MOV EAX, ESP
PUSHFD
CALL System.@LStrClr
POPFD
POP ECX
JZ @@fin
@@loop:
MOV ECX, [ESP].TWin32FindData.dwFileAttributes
PUSH [Attr]
LEA EDX, [ESP+4].TWin32FindData.cFileName
MOV EAX, EBX
CALL SatisfyFilter
TEST AL, AL
JZ @@next
MOV ECX, [EBX].fOnItem.TMethod.Code
JECXZ @@accept
MOV EAX, [EBX].fOnItem.TMethod.Data
MOV ECX, ESP
PUSH 1
MOV EDX, ESP
PUSH EDX
MOV EDX, EBX
CALL dword ptr [EBX].fOnItem.TMethod.Code
POP ECX
JECXZ @@next
LOOP @@fin
@@accept:
MOV EAX, sz_win32finddata
PUSH EAX
CALL System.@GetMem
PUSH EAX
XCHG EDX, EAX
MOV EAX, [EBX].fList
CALL TList.Add
POP EDX
POP ECX
MOV EAX, ESP
CALL System.Move
@@next:
PUSH ESP
PUSH EDI
CALL FindNextFile
TEST EAX, EAX
JNZ @@loop
PUSH EDI
CALL FindClose
@@fin:
ADD ESP, sz_win32finddata
@@exit:
XOR EAX, EAX
XCHG EAX, [EBX].fFilters
CALL TObj.Free
POP EDI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
procedure TDirList.ScanDirectory(const DirPath, Filter: KOLString;
Attr: DWord);
var FindData : TFindFileData;
E : PFindFileData;
Action: TDirItemAction;
{$ifndef wince}
{$IFDEF UNICODE_CTRLS}
IsUnicode: AnsiString;
{$ENDIF}
{$endif wince}
begin
Clear;
FList := NewList;
FPath := DirPath;
if FPath = '' then Exit;
FPath := IncludeTrailingPathDelimiter( FPath );
if fFilters = nil then
begin
fFilters := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
if Filter = '*.*' then
fFilters.Add( '*' )
else
fFilters.Add( Filter );
end;
if not Find_First( PKOLChar( FPath + FindFilter( Filter ) ), FindData ) then
Exit;
while True do
begin
{$ifndef wince}
{$IFDEF UNICODE_CTRLS} //+MtsVN in 2.58 / 14Apr2007
IsUnicode := FindData.cFileName;
if (IsUnicode <> '.') and (IsUnicode <> '..') then
begin
if pos('?', IsUnicode) > 0 then
CopyMemory( @FindData.cFileName, @FindData.cAlternateFileName,
SizeOf(FindData.cAlternateFileName));
end;
{$ENDIF}
{$endif wince}
if SatisfyFilter( PKOLChar(@FindData.cFileName[0]),
FindData.dwFileAttributes, Attr ) then
begin
Action := diAccept;
if Assigned( OnItem ) then
OnItem( @Self, FindData, Action );
CASE Action OF
diSkip: ;
diAccept:
begin
GetMem( E, Sizeof( FindData ) );
E^ := FindData;
FList.Add( E );
end;
diCancel: break;
END;
end;
if not Find_Next( FindData ) then break;
end;
Find_Close( FindData );
fFilters.Free;
fFilters := nil;
end;
{$ENDIF ASM_VERSION}
//[procedure TDirList.ScanDirectoryEx]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
procedure TDirList.ScanDirectoryEx(const DirPath, Filters: KOLString;
Attr: DWord);
var F, FF: KOLString;
begin
FF := Filters;
Free_And_Nil( fFilters );
fFilters := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
repeat
F := Trim( Parse( FF, ';' ) );
if F <> '' then
fFilters.Add( F );
until FF = '';
ScanDirectory( DirPath, '', Attr );
end;
{$ENDIF ASM_VERSION}
type
PSortDirData = ^TSortDirData;
TSortDirData = {$ifndef wince}packed{$endif} Record
FoldersFirst, CaseSensitive : Boolean;
Rules : array[ 0..11 ] of TSortDirRules;
Dir : PDirList;
end;
//[FUNCTION CompareDirItems]
{$IFDEF ASM_noVERSION}
function CompareDirItems( const Data : PSortDirData; const e1, e2 : DWORD ) : Integer;
asm
PUSH EBX
PUSH ESI
PUSH EDI
XCHG EBX, EAX
MOV EAX, [EBX].TSortDirData.Dir
MOV EAX, [EAX].TDirList.fList
MOV EAX, [EAX].TList.fItems
MOV ESI, [EAX+EDX*4]
MOV EDI, [EAX+ECX*4]
MOV DL, byte ptr[ESI].TWin32FindData.dwFileAttributes
MOV DH, byte ptr[EDI].TWin32FindData.dwFileAttributes
AND DX, 2020h
XOR EAX, EAX
CMP DL, DH
JE @@1
CMP [EBX].TSortDirData.FoldersFirst, AL
JE @@1
OR AL, DL
JNE @@exit_near
DEC EAX
@@exit_near:
POP EDI
POP ESI
POP EBX
RET
@@sdrByDateChanged:
LEA EAX, [ESI].TWin32FindData.ftLastWriteTime
LEA EDX, [EDI].TWin32FindData.ftLastWriteTime
JMP @@sdrByDate1
@@sdrByDateAccessed:
LEA EAX, [ESI].TWin32FindData.ftLastAccessTime
LEA EDX, [EDI].TWin32FindData.ftLastAccessTime
JMP @@sdrByDate1
@@jmp_table:
DD offset[@@exit1], offset[@@2], offset[@@2]
DD offset[@@sdrByName], offset[@@sdrByExt]
DD offset[@@sdrBySize], offset[@@sdrBySize]
DD offset[@@sdrByDateCreate], offset[@@sdrByDateChanged]
DD offset[@@sdrByDateAccessed]
@@1:
LEA EDX, [EBX].TSortDirData.Rules
PUSH EDX
@@2:
POP EDX
XOR EAX, EAX
MOV AL, [EDX]
INC EDX
PUSH EDX
JMP dword ptr [@@jmp_table+EAX*4]
@@sdrByDateCreate:
LEA EAX, [ESI].TWin32FindData.ftCreationTime
LEA EDX, [EDI].TWin32FindData.ftCreationTime
@@sdrByDate1:
PUSH EDX
PUSH EAX
CALL CompareFileTime
TEST EAX, EAX
JE @@2
JMP @@exit1
@@sdrBySize:
MOV EAX, [ESI].TWin32FindData.nFileSizeHigh
SUB EAX, [EDI].TWin32FindData.nFileSizeHigh
JNE @@sdrBySize1
MOV EAX, [ESI].TWin32FindData.nFileSizeLow
SUB EAX, [EDI].TWin32FindData.nFileSizeLow
@@to_2:
JE @@2
@@sdrBySize1:
POP EDX
DEC EDX
CMP byte ptr[EDX], sdrBySizeDescending
JNE @@sdrBySize2
NEG EAX
@@sdrBySize2:
JNE @@exit
DD -1, 1
@@point:DB '.',0
@@sdrByExt:
LEA EAX, [EDI].TWin32FindData.cFileName
MOV EDX, offset[@@point]
PUSH EDX
CALL __DelimiterLast
POP EDX
PUSH EAX
LEA EAX, [ESI].TWin32FindData.cFileName
CALL __DelimiterLast
POP EDX
JMP @@sdrByName0
@@sdrByName:
LEA EAX, [ESI].TWin32FindData.cFileName
LEA EDX, [EDI].TWin32FindData.cFileName
@@sdrByName0:
CMP [EBX].TSortDirData.CaseSensitive, 0
JNE @@sdrByName1
CALL _AnsiCompareStrNoCase
JMP @@sdrByName2
@@sdrByName1:
CALL _AnsiCompareStr
@@sdrByName2:
TEST EAX, EAX
JE @@to_2
//JMP @@exit1
@@exit1:
POP EDX
@@exit:
POP EDI
POP ESI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function CompareDirItems( const Data : PSortDirData; const e1, e2 : DWORD ) : Integer;
var I : Integer;
Item1, Item2 : PFindFileData;
S1, S2 : PKOLChar;
IsDir1, IsDir2 : Boolean;
Date1, Date2 : PFileTime;
begin
Item1 := Data.Dir.fList.fItems[ e1 ];
Item2 := Data.Dir.fList.fItems[ e2 ];
Result := 0;
IsDir1 := (Item1.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0;
IsDir2 := (Item2.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0;
if (IsDir1 <> IsDir2) and Data.FoldersFirst then
begin
if IsDir1 then Result := -1 else Result := 1;
exit;
end;
for I := 0 to High(Data.Rules) do
begin
case Data.Rules[ I ] of
sdrByName:
begin
S1 := Item1.cFileName;
S2 := Item2.cFileName;
if not Data.CaseSensitive then
Result := {$IFDEF UNICODE_CTRLS}
WStrComp( AnsiUpperCase( S1 ), AnsiUpperCase( S2 ) )
{$ELSE} _AnsiCompareStrNoCase( S1, S2 ) {$ENDIF}
else
Result := {$IFDEF UNICODE_CTRLS}
_WStrComp( S1, S2 )
{$ELSE}
_AnsiCompareStr( S1, S2 )
{$ENDIF};
end;
sdrByExt:
begin
S1 := Item1.cFileName;
S2 := Item2.cFileName;
S1 := {$IFDEF UNICODE_CTRLS} @ S1[ DelimiterLast( WideString( S1 ), '.' ) - 1 ]
{$ELSE} __DelimiterLast( S1, '.' ) {$ENDIF};
S2 := {$IFDEF UNICODE_CTRLS} @ S2[ DelimiterLast( WideString( S2 ), '.' ) - 1 ]
{$ELSE} __DelimiterLast( S2, '.' ) {$ENDIF};
if not Data.CaseSensitive then
Result := {$IFDEF UNICODE_CTRLS}
WStrComp( WAnsiUpperCase( S1 ), WAnsiUpperCase( S2 ) )
{$ELSE} _AnsiCompareStrNoCase( S1, S2 ) {$ENDIF}
else
Result := {$IFDEF UNICODE_CTRLS} WStrComp( S1, S2 )
{$ELSE} _AnsiCompareStr( S1, S2 ) {$ENDIF};
end;
sdrBySize, sdrBySizeDescending:
begin
if Item1.nFileSizeHigh < Item2.nFileSizeHigh then
Result := -1
else
if Item1.nFileSizeHigh > Item2.nFileSizeHigh then
Result := 1
else
if Item1.nFileSizeLow < Item2.nFileSizeLow then
Result := -1
else
if Item1.nFileSizeLow > Item2.nFileSizeLow then
Result := 1;
if Data.Rules[ I ] = sdrBySizeDescending then
Result := -Result;
end;
sdrByDateCreate:
begin
Date1 := @Item1.ftCreationTime;
Date2 := @Item2.ftCreationTime;
Result := FileTimeCompare( Date1^, Date2^ );
end;
sdrByDateChanged:
begin
Date1 := @Item1.ftLastWriteTime;
Date2 := @Item2.ftLastWriteTime;
Result := FileTimeCompare( Date1^, Date2^ );
end;
sdrByDateAccessed:
begin
Date1 := @Item1.ftLastAccessTime;
Date2 := @Item2.ftLastAccessTime;
Result := FileTimeCompare( Date1^, Date2^ );
end;
end; {case}
if Result <> 0 then break;
end;
end;
{$ENDIF ASM_VERSION}
//[END CompareDirItems]
//[PROCEDURE SwapDirItems]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure SwapDirItems( const Data : PSortDirData; const e1, e2 : DWORD );
var Tmp : Pointer;
begin
Tmp := Data.Dir.FList.fItems[ e1 ];
Data.Dir.FList.fItems[ e1 ] := Data.Dir.FList.fItems[ e2 ];
Data.Dir.FList.fItems[ e2 ] := Tmp;
end;
{$ENDIF ASM_VERSION}
//[END SwapDirItems]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TDirList.Sort(Rules: array of TSortDirRules);
var SortDirData : TSortDirData;
I, J : Integer;
function RulePresent( Rule : TSortDirRules ) : Boolean;
var K : Integer;
begin
Result := True;
for K := J - 1 downto 0 do
if Rule = SortDirData.Rules[ K ] then exit;
Result := False;
end;
procedure AddRule( Rule : TSortDirRules );
begin
if J > High( SortDirData.Rules ) then exit;
if RulePresent( Rule ) then exit;
SortDirData.Rules[ J ] := Rule;
Inc( J );
end;
begin
if fList = nil then Exit;
J := 0;
for I := 0 to High(Rules) do
AddRule( Rules[ I ] );
for I := 0 to High(DefSortDirRules) do
AddRule( DefSortDirRules[ I ] );
while J < High( SortDirData.Rules ) do
begin
SortDirData.Rules[ J ] := sdrNone;
Inc( J );
end;
SortDirData.Dir := @Self;
SortDirData.FoldersFirst := RulePresent( sdrFoldersFirst );
SortDirData.CaseSensitive := RulePresent( sdrCaseSensitive );
SortData( Pointer( @SortDirData ), fList.fCount, @CompareDirItems, @SwapDirItems );
end;
{$ENDIF ASM_VERSION}
//[function TDirList.FileList]
function TDirList.FileList(const Separator: KOLString; Dirs,
FullPaths: Boolean): KOLString;
var I: Integer;
begin
Result := '';
for I := 0 to Count-1 do
begin
if not Dirs and IsDirectory[ I ] then Continue;
if FullPaths then
Result := Result + Path;
Result := Result + Names[ I ] + Separator;
end;
end;
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
////////////////////////////////////////////////////////////////////////
// R E G I S T R Y
////////////////////////////////////////////////////////////////////////
{++}(*
function RegSetValueEx; external advapi32 name 'RegSetValueExA';
*){--}
{ -- registry -- }
//[function RegKeyOpenRead]
function RegKeyOpenRead( Key: HKey; const SubKey: KOLString ): HKey;
begin
if RegOpenKeyEx( Key, PKOLChar( SubKey ), 0, KEY_READ, Result ) <> ERROR_SUCCESS then
Result := 0;
end;
//[function RegKeyOpenWrite]
function RegKeyOpenWrite( Key: HKey; const SubKey: KOLString ): HKey;
begin
if RegOpenKeyEx( Key, PKOLChar( SubKey ), 0, KEY_READ or KEY_WRITE, Result ) <> ERROR_SUCCESS then
Result := 0;
end;
//[function RegKeyOpenCreate]
function RegKeyOpenCreate( Key: HKey; const SubKey: KOLString ): HKey;
var dwDisp: DWORD;
begin
if RegCreateKeyEx( Key, PKOLChar( SubKey ), 0, nil, 0, KEY_ALL_ACCESS, nil, Result,
@dwDisp ) <> ERROR_SUCCESS then
Result := 0;
end;
//[function RegKeyGetDw]
function RegKeyGetDw( Key: HKey; const ValueName: KOLString ): DWORD;
var dwType, dwSize: DWORD;
begin
dwSize := sizeof( DWORD );
Result := 0;
if (Key = 0) or
(RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType, PByte( @Result ), @dwSize ) <> ERROR_SUCCESS)
or (dwType <> REG_DWORD) then Result := 0;
end;
//[function RegKeyGetStr]
function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString;
var dwType, dwSize: DWORD;
Buffer: PKOLChar;
function Query: Boolean;
begin
Result := RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType,
Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;
end;
begin
Result := '';
if Key = 0 then Exit;
dwSize := 0;
Buffer := nil;
if not Query or (dwType <> REG_SZ) then Exit;
GetMem( Buffer, dwSize * Sizeof( KOLChar ) );
if Query then
Result := Buffer;
FreeMem( Buffer );
end;
//[function RegKeyGetStrEx]
function RegKeyGetStrEx( Key: HKey; const ValueName: KOLString ): KOLString;
var dwType, dwSize: DWORD;
Buffer: PKOLChar;
{$ifdef win32}
Buffer2: PKOLChar;
Sz: Integer;
{$endif win32}
function Query: Boolean;
begin
Result := RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType,
Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;
end;
begin
Result := '';
if Key = 0 then Exit;
dwSize := 0;
Buffer := nil;
if not Query or ((dwType <> REG_SZ) and (dwtype <> REG_EXPAND_SZ)) then Exit;
GetMem( Buffer, dwSize * Sizeof( KOLChar ) );
if Query then
begin
{$ifdef win32}
if dwtype = REG_EXPAND_SZ then
begin
Sz := ExpandEnvironmentStrings(Buffer,nil,0); // bug in size detection! sometimes we get an additional 2 bytes at the end...
GetMem(Buffer2,Sz * Sizeof( KOLChar )); //
ExpandEnvironmentStrings(Buffer, Buffer2, Sz); //
Result:=Buffer2; //
FreeMem(Buffer2); //
end
else
{$endif win32}
Result := Buffer;
end;
FreeMem( Buffer );
end;
//[function RegKeySetDw]
function RegKeySetDw( Key: HKey; const ValueName: KOLString; Value: DWORD ): Boolean;
begin
Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0,
REG_DWORD, @Value, sizeof( DWORD ) ) = ERROR_SUCCESS);
end;
//[function RegKeySetStr]
function RegKeySetStr( Key: HKey; const ValueName: KOLString; const Value: KOLString ): Boolean;
begin
Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0,
REG_SZ, PKOLChar(Value),
(Length( Value ) + 1)*Sizeof(KOLChar) ) = ERROR_SUCCESS);
end;
//[function RegKeySetStrEx]
function RegKeySetStrEx( Key: HKey; const ValueName: KOLString; const Value: KOLString;
expand: boolean): Boolean;
var dwType: DWORD;
begin
dwType := REG_SZ;
if expand then
dwType := REG_EXPAND_SZ;
Result := (Key <> 0) and (RegSetValueEx(Key, PKOLChar(ValueName), 0, dwType,
PKOLChar(Value), (Length(Value) + 1)*Sizeof(KOLChar)) = ERROR_SUCCESS);
end;
//[procedure RegKeyClose]
procedure RegKeyClose( Key: HKey );
begin
if Key <> 0 then
RegCloseKey( Key );
end;
//[function RegKeyDelete]
function RegKeyDelete( Key: HKey; const SubKey: KOLString ): Boolean;
begin
Result := FALSE;
if Key <> 0 then
Result := RegDeleteKey( Key, PKOLChar( SubKey ) ) = ERROR_SUCCESS;
end;
//[function RegKeyDeleteValue]
function RegKeyDeleteValue( Key: HKey; const SubKey: KOLString ): Boolean;
begin
Result := FALSE;
if Key <> 0 then
Result := RegDeleteValue( Key, PKOLChar( SubKey ) ) = ERROR_SUCCESS;
end;
//[function RegKeyExists]
function RegKeyExists( Key: HKey; const SubKey: String ): Boolean;
var K: Integer;
begin
if Key = 0 then
begin
Result := FALSE;
Exit;
end;
K := RegKeyOpenRead( Key, SubKey );
Result := K <> 0;
if K <> 0 then
RegKeyClose( K );
end;
//[function RegKeyValExists]
function RegKeyValExists( Key: HKey; const ValueName: KOLString ): Boolean;
var dwType, dwSize: DWORD;
begin
Result := (Key <> 0) and
(RegQueryValueEx( Key, PKOLChar( ValueName ), nil,
@dwType, nil, @dwSize ) = ERROR_SUCCESS);
end;
//[function RegKeyValueSize]
function RegKeyValueSize( Key: HKey; const ValueName: KOLString ): Integer;
begin
Result := 0;
if Key = 0 then Exit;
RegQueryValueEx( Key, PKOLChar( ValueName ), nil, nil, nil, @ DWORD( Result ) );
end;
//[function RegKeyGetBinary]
function RegKeyGetBinary( Key: HKey; const ValueName: KOLString; var Buffer; Count: Integer ): Integer;
begin
Result := 0;
if Key = 0 then Exit;
Result := Count;
if RegQueryValueEx( Key, PKOLChar( ValueName ), nil, nil, @ Buffer, @ Result ) <> 0 then
Result:=0;
end;
//[function RegKeySetBinary]
function RegKeySetBinary( Key: HKey; const ValueName: KOLString; const Buffer; Count: Integer ): Boolean;
begin
Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0,
REG_BINARY, @ Buffer, Count ) = ERROR_SUCCESS);
end;
//[function RegKeyGetDateTime]
function RegKeyGetDateTime(Key: HKey; const ValueName: KOLString): TDateTime;
begin
if RegKeyGetBinary( Key, ValueName, Result, Sizeof( Result ) ) <> Sizeof( Result ) then
Result:=0;
end;
//[function RegKeySetDateTime]
function RegKeySetDateTime(Key: HKey; const ValueName: KOLString; DateTime: TDateTime): Boolean;
begin
Result := RegKeySetBinary( Key, ValueName, DateTime, Sizeof( DateTime ) );
end;
{$IFDEF OLD_REGKEYGETSUBKEYS}
//-----------------------------------------------
// functions by Valerian Luft
//-----------------------------------------------
//[function RegKeyGetSubKeys]
function RegKeyGetSubKeys( const Key: HKEY; List: PStrList) : Boolean;
var
I, Size, NumSubKeys, MaxSubKeyLen : DWORD;
KeyName: KOLString;
begin
Result := False;
List.Clear ;
if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, @MaxSubKeyLen, nil, nil, nil, nil,
nil, nil) = ERROR_SUCCESS then
begin
if NumSubKeys > 0 then begin
for I := 0 to NumSubKeys-1 do
begin
Size := MaxSubKeyLen+1;
SetLength(KeyName, Size);
//FillChar(KeyName[1],Size,#0);
RegEnumKeyEx(Key, I, @KeyName[1], Size, nil, nil, nil, nil);
SetLength(KeyName, {$ifdef UNICODE_CTRLS}WStrLen{$else}StrLen{$endif}(@KeyName[1]));
List.Add(KeyName);
end;
end;
Result:= True;
end;
end;
{$ELSE} // new (faster) version by Alex Shyshko (Psychedelic)
function RegKeyGetSubKeys(const Key: HKEY; List: PStrList) : Boolean;
var
i, MaxSubKeyLen, Size: DWORD;
Buf: PKOLchar;
begin
Result:=false;
List.Clear;
if RegQueryInfoKey(Key, nil, nil, nil, nil, @MaxSubKeyLen, nil, nil, nil, nil,
nil, nil) = ERROR_SUCCESS then
begin
if MaxSubKeyLen > 0 then
begin
Inc(MaxSubKeyLen);
GetMem(Buf,MaxSubKeyLen*SizeOfKOLChar);
i:=0;
while True do begin
Size:=MaxSubKeyLen;
if RegEnumKeyEx(Key,i,buf,Size,nil,nil,nil,nil) <> ERROR_SUCCESS then
break;
List.Add(Buf);
inc(i);
end;
FreeMem(Buf);
end; // if MaxSubKeyLen
Result:=true;
end; // if RegQueryInfoKey
end;
{$ENDIF}
//[function RegKeyGetValueNames]
{$IFDEF OLD_REGKEYGETVALUENAMES}
function RegKeyGetValueNames(const Key: HKEY; List: PStrList): Boolean;
var
I, Size, NumSubKeys, NumValueNames, MaxValueNameLen: DWORD;
ValueName: String;
begin
List.Clear ;
Result:=False;
if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, nil, nil, @NumValueNames,
@MaxValueNameLen, nil, nil, nil) = ERROR_SUCCESS then
begin
if NumValueNames > 0 then
for I := 0 to NumValueNames - 1 do begin
Size := MaxValueNameLen + 1;
SetLength(ValueName, Size);
//FillChar(ValueName[1],Size,#0);
RegEnumValue(Key, I, @ValueName[1], Size, nil, nil, nil, nil);
SetLength(ValueName, {$ifdef UNICODE_CTRLS}WStrLen{$else}StrLen{$endif}(@ValueName[1]));
List.Add(ValueName);
end;
Result := True;
end ;
end;
{$ELSE} // new (faster) version by Alex Shyshko (Psychedelic)
function RegKeyGetValueNames(const Key: HKEY; List: PStrList) : Boolean;
var
i, MaxValueNameLen, Size: DWORD;
Buf: PKOLchar;
begin
Result:=false;
List.Clear;
if RegQueryInfoKey(Key, nil, nil, nil, nil, nil, nil, nil, @MaxValueNameLen, nil,
nil, nil) = ERROR_SUCCESS then
begin
if MaxValueNameLen > 0 then
begin
GetMem(Buf,MaxValueNameLen + SizeOf(KOLChar) );
i:=0;
Size:=MaxValueNameLen+1;
while RegEnumValue(Key,i,buf,Size,nil,nil,nil,nil) <> ERROR_NO_MORE_ITEMS do
begin
List.Add(Buf);
Size:=MaxValueNameLen+1;
inc(i);
end;
FreeMem(Buf {,MaxValueNameLen + ... system always knows how long buffer is});
end; // if MaxValueNameLen
Result:=true;
end; // if RegQueryInfoKey
end;
{$ENDIF}
//[function RegKeyGetValueTyp]
function RegKeyGetValueTyp (const Key:HKEY; const ValueName: KOLString) : DWORD;
begin
Result:= Key ;
if Key <> 0 then
RegQueryValueEx (Key,@ValueName[1],NIL,@Result,NIL,NIL)
end;
//////////////////////////////////////////////////////////////////////
// D A T E A N D T I M E
//////////////////////////////////////////////////////////////////////
{ -- date and time utilities -- }
{* This part of the unit contains date-time routines. It is not a simple compilation
of Delphi VCL date-time. E.g., TDateTime type is not based on 31-Dec-1899,
but it is based on 31-Dec-0000 instead, allowing easy manipulating of dates
at all Christian era, and all other historical era too. }
//[procedure DivMod]
procedure DivMod(Dividend: Integer; Divisor: Word;
var Result, Remainder: Word);
{$ifdef cpu86}
asm
PUSH EBX
MOV EBX,EDX
MOV EDX,EAX
SHR EDX,16
DIV BX
MOV EBX,Remainder
MOV [ECX],AX
MOV [EBX],DX
POP EBX
end;
{$else}
begin
Result := Dividend div Divisor;
Remainder := Dividend mod Divisor;
end;
{$endif cpu86}
{++}(*
//[API GetLocalTime, GetSystemTime]
procedure GetLocalTime; external kernel32 name 'GetLocalTime';
procedure GetSystemTime; external kernel32 name 'GetSystemTime';
*){--}
//*
//[function Now]
function Now : TDateTime;
var SystemTime : TSystemTime;
begin
GetLocalTime( SystemTime );
SystemTime2DateTime( SystemTime, Result );
end;
//[function Date]
function Date: TDateTime;
begin
Result := Trunc( Now );
end;
//[procedure DecodeDateFully]
procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD );
var ST: TSystemTime;
begin
DateTime2SystemTime( DateTime, ST );
Year := ST.wYear;
Month := ST.wMonth;
Day := ST.wDay;
DayOfWeek := ST.wDayOfWeek;
end;
//[procedure DecodeDate]
procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD );
var Dummy: Word;
begin
DecodeDateFully( DateTime, Year, Month, Day, Dummy );
end;
//[function EncodeDate]
function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean;
var ST: TSystemTime;
begin
FillChar( ST, Sizeof( ST ), #0 );
ST.wYear := Year;
ST.wMonth := Month;
ST.wDay := Day;
Result := SystemTime2DateTime( ST, DateTime );
end;
//[procedure IncDays]
procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer );
var DateTime : TDateTime;
begin
SystemTime2DateTime( SystemTime, DateTime );
DateTime := DateTime + DaysNum;
DateTime2SystemTime( DateTime, SystemTime );
end;
//*
//[procedure IncMonths]
procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer );
var M : Integer;
DateTime : TDateTime;
begin
M := SystemTime.wMonth + MonthsNum - 1;
Inc( SystemTime.wYear, M div 12 );
SystemTime.wMonth := M mod 12 + 1;
// Normalize wDayOfWeek field:
SystemTime2DateTime( SystemTime, DateTime );
DateTime2SystemTime( DateTime, SystemTime );
end;
//*
//[function IsLeapYear]
function IsLeapYear(Year: Integer): Boolean;
begin
Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
end;
//*
//[function SystemTime2DateTime]
function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean;
var I : Integer;
_Day : Integer;
DayTable: PDayTable;
begin
Result := False;
DateTime := 0.0;
DayTable := @MonthDays[IsLeapYear(SystemTime.wYear)];
with SystemTime do
if {(wYear >= 0) !always true! and} (wYear <= 9999) and
{(wMonth >= 1) and !otherwise can not convert time only!}
(wMonth <= 12) and
{(wDay >= 1) and !otherwise can not convert time only!}
(wDay <= DayTable^[wMonth]) and //
(wHour < 24) and (wMinute < 60) and (wSecond < 60) and (wMilliSeconds < 1000) then //
begin
_Day := wDay;
for I := 1 to wMonth - 1 do
Inc(_Day, DayTable^[I]);
I := wYear - 1;
//--------------- by Vadim Petrov ------++
if I<0 then i := 0; //
//--------------------------------------++
DateTime := I * 365 + I div 4 - I div 100 + I div 400 + _Day
+ (LongInt(wHour) * 3600000 + LongInt(wMinute) * 60000 + LongInt(wSecond) * 1000 + LongInt(wMilliSeconds)) / MSecsPerDay;
Result := True;
end;
end;
//*
//[function DayOfWeek]
function DayOfWeek(Date: TDateTime): Integer;
begin
Result := (Trunc( Date ) + 6) mod 7;
end;
//*
//[function DateTime2SystemTime]
function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
const
D1 = 365;
D4 = D1 * 4 + 1;
D100 = D4 * 25 - 1;
D400 = D100 * 4 + 1;
var Days : Integer;
Y, M, D, I: Word;
MSec : Integer;
DayTable: PDayTable;
MinCount, MSecCount: Word;
begin
Days := Trunc( DateTime );
MSec := Round((DateTime - Days) * MSecsPerDay);
Result := False;
with SystemTime do
if Days > 0 then
begin
Dec(Days);
Y := 1;
while Days >= D400 do
begin
Dec(Days, D400);
Inc(Y, 400);
end;
DivMod(Days, D100, I, D);
if I = 4 then
begin
Dec(I);
Inc(D, D100);
end;
Inc(Y, I * 100);
DivMod(D, D4, I, D);
Inc(Y, I * 4);
DivMod(D, D1, I, D);
if I = 4 then
begin
Dec(I);
Inc(D, D1);
end;
Inc(Y, I);
DayTable := @MonthDays[IsLeapYear(Y)];
M := 1;
while True do
begin
I := DayTable^[M];
if D < I then Break;
Dec(D, I);
Inc(M);
end;
wYear := Y;
wMonth := M;
wDay := D + 1;
wDayOfWeek := KOL.DayOfWeek( DateTime );
DivMod(MSec, 60000, MinCount, MSecCount);
DivMod(MinCount, 60, wHour, wMinute);
DivMod(MSecCount, 1000, wSecond, wMilliSeconds);
Result := True;
end;
end;
function DateTime_DiffSysLoc: TDateTime;
var ST, LT: TSystemTime;
FT, FT1: TFileTime;
D1, D2: TDateTime;
begin
GetSystemTime( ST );
SystemTimeToFileTime( ST, FT );
FileTimeToLocalFileTime( FT, FT1 );
FileTimeToSystemTime( FT1, LT );
SystemTime2DateTime( ST, D1 );
SystemTime2DateTime( LT, D2 );
Result := D2 - D1;
end;
//[function DateTime_System2Local]
function DateTime_System2Local( DTSys: TDateTime ): TDateTime;
begin
Result := DTSys + DateTime_DiffSysLoc;
end;
//[function DateTime_Local2System]
function DateTime_Local2System( DTLoc: TDateTime ): TDateTime;
begin
Result := DTLoc - DateTime_DiffSysLoc;
end;
function FileTime2DateTime( const ft: TFileTime; var DT: TDateTime ): Boolean;
var ft1: TFileTime;
st: TSystemTime;
begin
Result := FileTimeToLocalFileTime( ft, ft1 ) and
FileTimeToSystemTime( ft1, st ) and
SystemTime2DateTime( st, dt );
end;
function DateTime2FileTime( DT: TDateTime; var ft: TFileTime ): Boolean;
var st: TSystemTime;
begin
Result := DateTime2SystemTime( DT, ST ) and
SystemTimeToFileTime( st, ft ) and
LocalFileTimeToFileTime( ft, ft );
end;
//*
//[function SystemDate2Str]
function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
const DfltDateFormat : TDateFormat;
const DateFormat : PKOLChar ) : KOLString;
var Buf : PKOLChar;
Sz : Integer;
Flags : DWORD;
begin
Sz := 100;
Buf := nil;
Result := '';
Flags := 0;
if DateFormat = nil then
if DfltDateFormat = dfShortDate then
Flags := DATE_SHORTDATE
else
Flags := DATE_LONGDATE;
while True do
begin
if Buf <> nil then
FreeMem( Buf );
GetMem( Buf, Sz * Sizeof( KOLChar ) );
if Buf = nil then Exit;
if GetDateFormat( LocaleID, Flags, @SystemTime, DateFormat, Buf, Sz )
= 0 then
begin
if GetLastError = ERROR_INSUFFICIENT_BUFFER then
Sz := Sz * 2
else
break;
end
else
begin
Result := Buf;
break;
end;
end;
if Buf <> nil then
FreeMem( Buf );
end;
//*
//[function SystemTime2Str]
function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
const Flags : TTimeFormatFlags;
const TimeFormat : PKOLChar ) : KOLString;
var Buf : PKOLChar;
Sz : Integer;
Flg : DWORD;
begin
Sz := 100;
Buf := nil;
Result := '';
Flg := 0;
if tffNoMinutes in Flags then
Flg := TIME_NOMINUTESORSECONDS
else
if tffNoSeconds in Flags then
Flg := TIME_NOSECONDS;
if tffNoMarker in Flags then
Flg := Flg or TIME_NOTIMEMARKER;
if tffForce24 in Flags then
Flg := Flg or TIME_FORCE24HOURFORMAT;
while True do
begin
if Buf <> nil then
FreeMem( Buf );
GetMem( Buf, Sz * Sizeof( KOLChar ) );
if Buf = nil then Exit;
if GetTimeFormat( LocaleID, Flg, @SystemTime, TimeFormat, Buf, Sz )
= 0 then
begin
if GetLastError = ERROR_INSUFFICIENT_BUFFER then
Sz := Sz * 2
else
break;
end
else
begin
Result := Buf;
break;
end;
end;
if Buf <> nil then
FreeMem( Buf );
end;
//[function Date2StrFmt]
function Date2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
var ST: TSystemTime;
lpFmt: PKOLChar;
begin
DateTime2SystemTime( D, ST );
lpFmt := nil;
if Fmt <> '' then lpFmt := PKOLChar( Fmt );
Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT, dfShortDate, lpFmt );
end;
//[function Time2StrFmt]
function Time2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
var ST: TSystemTime;
lpFmt: PKOLChar;
begin
if D < 1 then D := D + 1;
DateTime2SystemTime( D, ST );
lpFmt := nil;
if Fmt <> '' then lpFmt := PKOLChar( Fmt );
Result := SystemTime2Str( ST, LOCALE_USER_DEFAULT, [], lpFmt );
end;
//[function DateTime2StrShort]
function DateTime2StrShort( D: TDateTime ): String;
var ST: TSystemTime;
begin
//--------- by Vadim Petrov --------++
if D < 1 then D := D + 1; //
//----------------------------------++
DateTime2SystemTime( D, ST );
Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, dfShortDate, nil ) + ' ' +
SystemTime2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, [], nil );
end;
//[function Str2DateTimeFmt]
function Str2DateTimeFmt( const sFmtStr, sS: KOLString ): TDateTime;
var h12, hAM: Boolean;
FmtStr, S: PKOLChar;
function GetNum( var S: PKOLChar; NChars: Integer ): Integer;
begin
Result := 0;
while (S^ <> #0) and (NChars <> 0) do
begin
Dec( NChars );
{$IFDEF UNICODE_CTRLS}
if (S^ >= '0') and (S^ <= '9') then
{$ELSE}
if S^ in ['0'..'9'] then
{$ENDIF}
begin
Result := Result * 10 + Ord(S^) - Ord('0');
Inc( S );
end
else
break;
end;
end;
function GetYear( var S: PKOLChar; NChars: Integer ): Integer;
var STNow: TSystemTime;
OldDate: Boolean;
begin
Result := GetNum( S, NChars );
GetSystemTime( STNow );
OldDate := Result < 50;
Result := Result + STNow.wYear - STNow.wYear mod 100;
if OldDate then Dec( Result, 100 );
end;
function GetMonth( const fmt: KOLString; var S: PKOLChar ): Integer;
var SD: TSystemTime;
M: Integer;
C, MonthStr: KOLString;
begin
GetSystemTime( SD );
for M := 1 to 12 do
begin
SD.wMonth := M;
C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/dd/yyyy/' ) );
MonthStr := Parse( C, '/' );
if AnsiCompareStrNoCase( MonthStr, Copy( S, 1, Length( MonthStr ) ) ) = 0 then
begin
Result := M;
Inc( S, Length( MonthStr ) );
Exit;
end;
end;
Result := 1;
end;
procedure SkipDayOfWeek( const fmt: KOLString; var S: PKOLChar );
var SD: TSystemTime;
Dt: TDateTime;
D: Integer;
C, DayWeekStr: KOLString;
begin
GetSystemTime( SD );
SystemTime2DateTime( SD, Dt );
Dt := Dt - SD.wDayOfWeek;
for D := 0 to 6 do
begin
DateTime2SystemTime( Dt, SD );
C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/MM/yyyy/' ) );
DayWeekStr := Parse( C, '/' );
if AnsiCompareStrNoCase( DayWeekStr, Copy( S, 1, Length( DayWeekStr ) ) ) = 0 then
begin
Inc( S, Length( DayWeekStr ) );
Exit;
end;
Dt := Dt + 1.0;
end;
end;
procedure GetTimeMark( const fmt: KOLString; var S: PKOLChar );
var SD: TSystemTime;
AM: Boolean;
C, TimeMarkStr: KOLString;
begin
GetSystemTime( SD );
SD.wHour := 0;
for AM := FALSE to TRUE do
begin
C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/HH/mm' ) );
TimeMarkStr := Parse( C, '/' );
if AnsiCompareStrNoCase( TimeMarkStr, Copy( S, 1, Length( TimeMarkStr ) ) ) = 0 then
begin
Inc( S, Length( TimeMarkStr ) );
hAM := AM;
Exit;
end;
SD.wHour := 13;
end;
Result := 1;
end;
function FmtIs1( S: PKOLChar ): Boolean;
begin
if StrIsStartingFrom( FmtStr, S ) then
begin
Inc( FmtStr, {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( S ) );
Result := TRUE;
end
else
Result := FALSE;
end;
function FmtIs( S1, S2: PKOLChar ): Boolean;
begin
Result := FmtIs1( S1 ) or FmtIs1( S2 );
end;
var ST: TSystemTime;
begin
FmtStr := PKOLChar( sFmtStr);
S := PKOLChar( sS );
FillChar( ST, Sizeof( ST ), #0 );
h12 := FALSE;
hAM := FALSE;
while (FmtStr^ <> #0) and (S^ <> #0) do
begin
{$IFDEF UNICODE_CTRLS}
if ((FmtStr^ >= 'a') and (FmtStr^ <= 'z') or
(FmtStr^ >= 'A') and (FmtStr^ <= 'Z')) and
(S^ >= '0') and (S^ <= '9') then
{$ELSE}
if (FmtStr^ in ['a'..'z','A'..'Z']) and (S^ in ['0'..'9']) then
{$ENDIF}
begin
if FmtIs1( 'yyyy' ) then ST.wYear := GetNum( S, 4 )
else if FmtIs1( 'yy' ) then ST.wYear := GetYear( S, 2 )
else if FmtIs1( 'y' ) then ST.wYear := GetYear( S, -1 )
else if FmtIs( 'dd', 'd' ) then ST.wDay := GetNum( S, 2 )
else if FmtIs( 'MM', 'M' ) then ST.wMonth := GetNum( S, 2 )
else if FmtIs( 'HH', 'H' ) then ST.wHour := GetNum( S, 2 )
else if FmtIs( 'hh', 'h' ) then begin ST.wHour := GetNum( S, 2 ); h12 := TRUE end
else if FmtIs( 'mm', 'm' ) then ST.wMinute := GetNum( S, 2 )
else if FmtIs( 'ss', 's' ) then ST.wSecond := GetNum( S, 2 )
else break; // + ECM
end
else
{$IFDEF UNICODE_CTRLS}
if (FmtStr^ = 'M') or (FmtStr^ = 'd') or (FmtStr^ = 'g') then
{$ELSE}
if (FmtStr^ in [ 'M', 'd', 'g' ]) then
{$ENDIF}
begin
if FmtIs1( 'MMMM' ) then ST.wMonth := GetMonth( 'MMMM', S )
else if FmtIs1( 'MMM' ) then ST.wMonth := GetMonth( 'MMM', S )
else if FmtIs1( 'dddd' ) then SkipDayOfWeek( 'dddd', S )
else if FmtIs1( 'ddd' ) then SkipDayOfWeek( 'ddd', S )
else if FmtIs1( 'tt' ) then GetTimeMark( 'tt', S )
else if FmtIs1( 't' ) then GetTimeMark( 't', S )
else break; // + ECM
end
else
begin
if FmtStr^ = S^ then
Inc( FmtStr );
Inc( S );
end;
end;
if h12 then
if hAM then
Inc( ST.wHour, 12 );
SystemTime2DateTime( ST, Result );
end;
var FmtBuf: PKOLChar;
DateSeparator : KOLChar = #0; // + ECM
//[function Str2DateTimeShort]
function Str2DateTimeShort( const S: String ): TDateTime;
var FmtStr, FmtStr2: KOLString;
function EnumDateFmt( lpstrFmt: PKOLChar ): Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
GetMem( FmtBuf, {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}
(( lpstrFmt ) + 1) * Sizeof( KOLChar ) );
{$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
( FmtBuf, lpstrFmt );
Result := FALSE;
end;
begin
FmtStr := 'dd.MM.yyyy';
FmtBuf := nil;
EnumDateFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, DATE_SHORTDATE );
if FmtBuf <> nil then
begin
FmtStr := FmtBuf;
FreeMem( FmtBuf );
end;
FmtStr2 := 'H:mm:ss';
FmtBuf := nil;
EnumTimeFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, 0 );
if FmtBuf <> nil then
begin
FmtStr2 := FmtBuf;
FreeMem( FmtBuf );
end;
Result := Str2DateTimeFmt( FmtStr + ' ' + FmtStr2, S );
end;
// + ECM
//[function Str2DateTimeShortEx]
function Str2DateTimeShortEx( const S: KOLString ): TDateTime;
var St: KOLString;
Buff: Array[0..1] of KOLChar;
begin
if DateSeparator = #0 then
begin
if GetLocaleInfo({$ifdef wince}LOCALE_USER_DEFAULT{$else}GetThreadLocale{$endif},LOCALE_SDATE,Buff,2) > 0 then
DateSeparator := Buff[0];
end;
St := S;
if Pos(KOLString(DateSeparator),S) = 0 then
St := '0.0.0 '+S;
Result := Str2DateTimeShort(St);
end;
///////////////////////////////////////////////////////////////////////
// T H R E A D S
///////////////////////////////////////////////////////////////////////
{ -- Thread -- }
//[function ThreadFunc]
function ThreadFunc(Thread: PThread): integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
Result := Thread.Execute;
end;
{$IFDEF USE_CONSTRUCTORS}
//[function NewThread]
function NewThread: PThread;
begin
new( Result, ThreadCreate );
end;
//[END NewThread]
{$ELSE not_USE_CONSTRUCTORS}
//*
//[function NewThread]
function NewThread: PThread;
begin
{$IFNDEF FPC105ORBELOW}
IsMultiThread := True;
{$ENDIF}
{-}
New( Result, Create );
{+}
{++}(*Result := PThread.Create;*){--}
Result.FSuspended := True;
{$IFDEF PSEUDO_THREADS}
{$ELSE}
Result.FHandle := CreateThread( nil, // no security
0, // the same stack size
@ThreadFunc, // thread entry point
Result, // parameter to pass to ThreadFunc
CREATE_SUSPENDED, // always SUSPENDED
Result.FThreadID ); // receive thread ID
{$ENDIF}
end;
//[END NewThread]
{$ENDIF USE_CONSTRUCTORS}
{$IFDEF USE_CONSTRUCTORS}
//[function NewThreadEx]
function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
begin
new( Result, ThreadCreateEx( Proc ) );
end;
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewThreadEx]
{$IFDEF ASM_!VERSION}
function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
asm
CALL NewThread
POP EBP
POP ECX
POP EDX
MOV [EAX].TThread.fOnExecute.TMethod.Code, EDX
POP EDX
MOV [EAX].TThread.fOnExecute.TMethod.Data, EDX
PUSH ECX
PUSH EAX
CALL TThread.Resume
POP EAX
RET
end;
{$ELSE ASM_VERSION} //Pascal
function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
begin
Result := NewThread;
Result.OnExecute := {++}(*{$IFDEF F_P} @ {$ENDIF}*){--}Proc;
Result.Resume;
end;
{$ENDIF ASM_VERSION}
//[END NewThreadEx]
{$ENDIF USE_CONSTRUCTORS}
//[function NewThreadAutoFree]
function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread;
begin
Result := NewThread;
Result.OnExecute := {++}(*{$IFDEF F_P} @ {$ENDIF}*){--}Proc;
Result.F_AutoFree := TRUE;
if Assigned( Proc ) then
Result.Resume;
end;
{ TThread }
function WndProcCMExec( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
var Thread: PThread;
begin
Result := FALSE;
if Msg.message = CM_EXECPROC then
begin
//Global_Synchronized( Pointer( Msg.lParam ), Pointer( Msg.wParam ) );
Thread := PThread( Msg.lParam );
if Msg.wParam <> 0 then
Thread.FMethodEx( Thread, Pointer( Msg.wParam ) )
else
Thread.FMethod( );
Rslt := 0;
end;
end;
{$IFDEF PSEUDO_THREADS}
function timeBeginPeriod(uPeriod: UINT): UINT; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'winmm.dll' name 'timeBeginPeriod';
function timeEndPeriod(uPeriod: UINT): UINT; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'winmm.dll' name 'timeEndPeriod';
{$ENDIF}
procedure TThread.Init;
begin
{$IFDEF _D2orD3}
inherited;
{$ENDIF}
if Applet <> nil then
Applet.AttachProc( WndProcCMExec );
{$IFDEF PSEUDO_THREADS}
if (MainThread = nil) and not CreatingMainThread then
begin // creating main thread
CreatingMainThread := TRUE;
new( MainThread, Create );
CreatingMainThread := FALSE;
end;
if CreatingMainThread then
begin
MainThread := @ Self;
{MainThread.}AllThreads := NewList;
{MainThread.}CurrentThread := MainThread;
TimeBeginPeriod( 10 );
end;
if not CreatingMainThread and (MainThread <> @ Self) then
begin // creating other threads
GetMem( StackBottom, PseudoThreadStackSize );
CurStackPos := Pointer( DWORD( StackBottom ) + PseudoThreadStackSize );
Stack_Empty := TRUE;
end;
MainThread.AllThreads.Add( @ Self );
{$ENDIF}
end;
//[destructor TThread.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TThread.Destroy;
begin
RefInc;
if not FTerminated then
begin
Terminate;
WaitFor;
end;
if (FHandle <> 0) then
CloseHandle(FHandle);
{$IFDEF PSEUDO_THREADS}
if StackBottom <> nil then
FreeMem( StackBottom );
if MainThread = @ Self then
begin
TimeEndPeriod( 10 );
AllThreads.Free;
end
else
if MainThread <> nil then
begin
MainThread.AllThreads.Remove( @ Self );
if MainThread.AllThreads.Count <= 1 then
Free_And_Nil( MainThread );
end;
{$ENDIF}
inherited;
end;
{$ENDIF ASM_VERSION}
//*
//[function TThread.Execute]
function TThread.Execute: integer;
begin
Result := 0;
if Assigned( FOnExecute ) then
Result := FOnExecute( @Self );
FResult := Result;
FTerminated := TRUE; // fake thread object (to prevent terminating while freeing)
if F_AutoFree then
Free;
end;
//*
//[function TThread.GetPriorityCls]
function TThread.GetPriorityCls: Integer;
begin
{$IFDEF PSEUDO_THREADS}
Result := FPrtyCls;
{$ELSE}
Result := {$ifdef wince} NORMAL_PRIORITY_CLASS {$else} GetPriorityClass(FHandle) {$endif};
{$ENDIF}
end;
//*
//[function TThread.GetThrdPriority]
function TThread.GetThrdPriority: Integer;
begin
{$IFDEF PSEUDO_THREADS}
Result := FPriority;
{$ELSE}
Result := GetThreadPriority(FHandle);
{$ENDIF}
end;
//*
//[procedure TThread.Resume]
procedure TThread.Resume;
begin
{$IFDEF PSEUDO_THREADS}
if MainThread.CurrentThread = @ Self then
Exit;
MainThread.SwitchToThread( @ Self );
{$ELSE}
FSuspended := False;
if (ResumeThread(FHandle) > 1) then
FSuspended := True
else
if Assigned(FOnResume) then
FOnResume(@Self);
{$ENDIF}
end;
//*
//[procedure TThread.SetPriorityCls]
procedure TThread.SetPriorityCls(Value: Integer);
begin
{$ifdef win32}
{$IFDEF DEBUG}
if not SetPriorityClass(GetCurrentProcess, Value) then
begin
ShowMessage( SysErrorMessage( GetLastError ) );
end;
{$ELSE}
{$IFDEF PSEUDO_THREADS}
FPrtyCls := Value;
{$ELSE}
SetPriorityClass(GetCurrentProcess, Value);
{$ENDIF}
{$ENDIF}
{$endif win32}
end;
//*
//[procedure TThread.SetThrdPriority]
procedure TThread.SetThrdPriority(Value: Integer);
begin
FPriority := Value;
{$IFDEF PSEUDO_THREADS}
{$ELSE}
SetThreadPriority(FHandle, Value);
{$ENDIF}
end;
//*
//[procedure TThread.Suspend]
procedure TThread.Suspend;
begin
{$IFDEF PSEUDO_THREADS}
if MainThread <> @ Self then
FSuspended := TRUE;
if MainThread.CurrentThread = @ Self then
MainThread.NextThread;
{$ELSE}
FSuspended := TRUE;
if Assigned(FOnSuspend) then
Synchronize( FOnSuspend );
SuspendThread(FHandle);
{$ENDIF}
end;
{$IFDEF PSEUDO_THREADS}
procedure FinishThread;
begin
MainThread.CurrentThread.fTerminated := TRUE;
MainThread.CurrentThread.Stack_Empty := TRUE;
MainThread.NextThread;
end;
procedure TThread.SwitchToThread(T: PThread);
begin
if (T <> MainThread) and not Assigned( T.OnExecute ) then Exit;
if Assigned( MainThread.CurrentThread.OnSuspend ) then
begin
MainThread.CurrentThread.OnExecute( MainThread.CurrentThread );
end;
asm
mov edx, [T]
// 1. Suspending current thread
mov ecx, [MainThread]
mov eax, [ecx].CurrentThread
push ebx
push ebp
push esi
push edi
mov [eax].CurStackPos, esp
mov [eax].Stack_Empty, 0
// 2. Switching to another thread
mov [ecx].CurrentThread, edx
cmp [edx].Stack_Empty, 0
jz @@1
// the first call
mov [edx].Stack_Empty, 0
cmp [edx].FSuspended, 0
jz @@0
mov [edx].FSuspended, 0
mov esp, [edx].CurStackPos
mov ecx, [edx].fOnResume.TMethod.Code
jecxz @@0
mov eax, [edx].fOnResume.TMethod.Data
call ecx // calling OnResume for resuming thread
@@0:
mov eax, [edx].fOnExecute.TMethod.Data
mov ecx, [edx].fOnExecute.TMethod.Code
push offset [FinishThread] // if thread will be finished it will jump there
jmp ecx
@@1:
// other calls - resuming
mov esp, [edx].CurStackPos
pop edi
pop esi
pop ebp
pop ebx
cmp [edx].FSuspended, 0
jz @@2
mov [edx].FSuspended, 0
mov ecx, [edx].fOnResume.TMethod.Code
jecxz @@2
mov eax, [edx].fOnResume.TMethod.Data
call ecx // calling OnResume for resuming thread
@@2:
end;
// At this point, thread is resumed
end;
procedure TThread.NextThread;
var i: Integer;
T: PThread;
C: DWORD;
begin
i := MainThread.AllThreads.IndexOf( MainThread.CurrentThread );
if i >= 0 then
begin
C := GetTickCount;
while TRUE do
begin
inc( i );
if i >= MainThread.AllThreads.Count then i := 0;
T := MainThread.AllThreads.Items[ i ];
if (T.DoNotWakeUntil > C) and (T <> MainThread) then continue;
if (T = MainThread) and (MainThread.CurrentThread = T) then Exit;
if not T.Terminated and not ((T <> MainThread) and (T.Suspended)) then break;
end;
MainThread.SwitchToThread( MainThread.AllThreads.Items[ i ] );
end;
end;
procedure Sleep( n: DWORD );
begin
if Assigned( MainThread ) then
begin
MainThread.CurrentThread.DoNotWakeUntil := GetTickCount + n;
MainThread.NextThread;
end
else
if n > 0 then Windows.Sleep( n );
end;
function WaitForMultipleObjects( nCount: DWORD;
lpHandles: PHandle; fWaitAll: BOOL; dwMilliseconds: DWORD ): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
var i: Integer;
w: DWORD;
Ph: PHandle;
Limit: DWORD;
begin
if dwMilliseconds = INFINITE then
Limit := INFINITE
else
Limit := GetTickCount + dwMilliseconds;
while TRUE do
begin
Ph := lpHandles;
w := 0;
for i := 0 to nCount-1 do
begin
if Windows.WaitForSingleObject( Ph^, 0 ) = WAIT_OBJECT_0 then
begin
inc( w );
if not fWaitAll then
begin
Result := WAIT_OBJECT_0 + i;
Exit;
end;
end;
inc( Ph );
end;
if w = nCount then
begin
Result := WAIT_OBJECT_0;
Exit;
end;
if (Limit <> INFINITE) and (GetTickCount > Limit) then
begin
Result := WAIT_TIMEOUT;
Exit;
end;
if Assigned( MainThread ) then
MainThread.NextThread;
{$IFDEF WAIT_SLEEP}
Sleep( 10 );
{$ENDIF}
end;
end;
function WaitForSingleObject( hHandle: THandle; dwMilliseconds: DWORD ): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
Result := WaitForMultipleObjects( 1, @ hHandle, TRUE, dwMilliseconds );
end;
{$ENDIF PSEUDO_THREADS}
//*
//[procedure TThread.Synchronize]
procedure TThread.Synchronize(Method: TThreadMethod);
begin
{$IFDEF PSEUDO_THREADS}
Method;
{$ELSE}
FMethod := Method;
if Applet <> nil then
SendMessage( Applet.fHandle, CM_EXECPROC, 0, Integer( @Self ) );
{$ENDIF}
end;
//[procedure TThread.SynchronizeEx]
procedure TThread.SynchronizeEx( Method: TThreadMethodEx; Param: Pointer );
begin
Assert( Param <> nil, 'Parameter must not be NIL' );
{$IFDEF PSEUDO_THREADS}
Method( TMethod( Method ).Data, Param );
{$ELSE}
FMethodEx := Method;
SendMessage( Applet.fHandle, CM_EXECPROC, Integer( Param ), Integer( @Self ) );
{$ENDIF}
end;
//*
//[procedure TThread.Terminate]
procedure TThread.Terminate;
begin
{$IFDEF PSEUDO_THREADS}
FTerminated := TRUE;
if Assigned( MainThread ) then
if MainThread.CurrentThread = @ Self then
MainThread.NextThread;
{$ELSE}
TerminateThread(FHandle,0);
FTerminated := True;
{$ENDIF}
end;
//*
//[function TThread.WaitFor]
function TThread.WaitFor: Integer;
begin
RefInc;
Result := -1;
{$IFDEF PSEUDO_THREADS}
while not Terminated do
Resume;
if Terminated then
Result := FResult;
{$ELSE}
if FHandle = 0 then Exit;
WaitForSingleObject(FHandle, INFINITE);
GetExitCodeThread(FHandle, DWORD(Result));
{$ENDIF}
RefDec;
end;
function TThread.WaitForTime(T: DWORD): Integer;
{$IFDEF PSEUDO_THREADS}
var LimitTime: DWORD;
{$ENDIF}
begin
{$IFDEF PSEUDO_THREADS}
LimitTime := GetTickCount + T;
RefInc;
while not Terminated and (GetTickCount < LimitTime) do
Resume;
Result := -1;
if Terminated then
Result := FResult;
RefDec;
{$ELSE}
Result := WAIT_OBJECT_0;
RefInc;
if FHandle = 0 then Exit;
Result := WaitForSingleObject(FHandle, T);
if Result = WAIT_OBJECT_0 then
GetExitCodeThread(FHandle, T);
RefDec;
{$ENDIF}
end;
{$IFDEF _D2}
{$DEFINE _D2orFPC}
{$ENDIF}
{$IFDEF _FPC}
{$IFNDEF _D2orFPC}
{$DEFINE _D2orFPC}
{$ENDIF}
{$ENDIF}
function TThread.GetPriorityBoost: Boolean;
type TGetPriorityBoost = function(hThread: THandle;
var DisablePriorityBoost: Bool): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
var B: Bool;
GPB: TGetPriorityBoost;
M: THandle;
begin
Result := TRUE;
if fHandle = 0 then Exit;
if (WinVer >= WvNT) then // by TK: only evaluate if this is true, regardless of evaluation settings
begin
M := GetModuleHandle( 'kernel32' );
GPB := GetProcAddress( M, 'GetThreadPriorityBoost' );
if Assigned( GPB ) then
if GPB( fHandle, B ) then
Result := B;
end;
end;
procedure TThread.SetPriorityBoost(const Value: Boolean);
type TSetPriorityBoost = function(hThread: THandle;
DisablePriorityBoost: Bool): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
var M: THandle;
SPB: TSetPriorityBoost;
begin
if fHandle = 0 then Exit;
if WinVer >= WvNT then
begin
M := GetModuleHandle( 'kernel32' );
SPB := GetProcAddress( M, 'SetThreadPriorityBoost' );
if Assigned( SPB ) then
SPB( fHandle, not Value );
end;
end;
{ TStream }
{* This part of the unit contains implementation of streams for KOL. Please note,
that both stream types (file stream and memory stream) are incapsulated
by a single object type TStream. To avoid including unnedeed code,
use constructing functions NewReadFileStream and NewWriteFileStream
to work with file streams, which do not require both types of operation. }
{* To create new type of stream, define your own methods, and in your
constructing function, pass it to _NewStream function (through
TStreamMethods record). In a field Custom, You can store a reference to
your own data of any type (but do not forget to define correct releasing
of such data in your fClose procedure). }
//[function TStream.GetPosition]
function TStream.GetPosition: DWord;
begin
Result := Seek( 0, spCurrent );
end;
//[procedure TStream.SetPosition]
procedure TStream.SetPosition(Value: DWord);
begin
Seek( Value, spBegin );
end;
//[function TStream.GetSize]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TStream.GetSize: DWord;
begin
Result := fMethods.fGetSiz( @Self );
end;
{$ENDIF ASM_VERSION}
//[procedure TStream.SetSize]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStream.SetSize(NewSize: DWord);
begin
fMethods.fSetSiz( @Self, NewSize );
end;
{$ENDIF ASM_VERSION}
//[function TStream.GetFileStreamHandle]
function TStream.GetFileStreamHandle: THandle;
begin
Result := fData.fHandle;
end;
//[function TStream.Read]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TStream.Read(var Buffer; Count: DWord): DWord;
begin
Result := fMethods.fRead( @Self, Buffer, Count );
end;
{$ENDIF ASM_VERSION}
//[function TStream.GetCapacity]
function TStream.GetCapacity: DWORD;
begin
Result := fData.fCapacity;
end;
//[procedure TStream.SetCapacity]
procedure TStream.SetCapacity(Value: DWORD);
var OldSize: DWORD;
begin
{$IFDEF OLD_STREAM_CAPACITY}
if fData.fCapacity >= Value then Exit;
OldSize := Size;
Size := Value;
Size := OldSize;
{$ELSE}
if Value < fData.fSize then Value := fData.fSize;
if Value > fData.fCapacity then
begin
OldSize := Size;
Size := Value;
Size := OldSize;
end
else
if fMemory <> nil then
begin
{$IFDEF _D4orHigher}
fMemory := ReallocMemory( fMemory, Value );
{$ELSE}
ReallocMem( fMemory, Value );
{$ENDIF}
fData.fCapacity := Value;
end;
{$ENDIF}
end;
//[function TStream.Busy]
function TStream.Busy: Boolean;
begin
Result := Assigned( fData.fThread );
end;
//[function TStream.DoAsyncRead]
function TStream.DoAsyncRead( Sender: PThread ): Integer;
begin
Read( Pointer( fParam1 )^, fParam2 );
fData.fThread := nil;
Result := 0;
end;
//[procedure TStream.ReadAsync]
procedure TStream.ReadAsync(var Buffer; Count: DWord);
begin
if Busy then Wait;
fData.fThread := NewThreadAutoFree( nil );
fData.fThread.OnExecute := DoAsyncRead;
fParam1 := DWORD( @ Buffer );
fParam2 := Count;
fData.fThread.Resume;
end;
//[function TStream.DoAsyncSeek]
function TStream.DoAsyncSeek( Sender: PThread ): Integer;
begin
Seek( fParam1, TMoveMethod( fParam2 ) );
fData.fThread := nil;
Result := 0;
end;
//[procedure TStream.SeekAsync]
procedure TStream.SeekAsync(MoveTo: Integer; MoveMethod: TMoveMethod);
begin
if Busy then Wait;
fData.fThread := NewThreadAutoFree( nil );
fData.fThread.OnExecute := DoAsyncSeek;
fParam1 := MoveTo;
fParam2 := Ord( MoveMethod );
fData.fThread.Resume;
end;
//[function TStream.DoAsyncWrite]
function TStream.DoAsyncWrite( Sender: PThread ): Integer;
begin
Write( Pointer( fParam1 )^, fParam2 );
fData.fThread := nil;
Result := 0;
end;
//[procedure TStream.WriteAsync]
procedure TStream.WriteAsync(var Buffer; Count: DWord);
begin
if Busy then Wait;
fData.fThread := NewThreadAutoFree( nil );
fData.fThread.OnExecute := DoAsyncWrite;
fParam1 := DWORD( @ Buffer );
fParam2 := Count;
fData.fThread.Resume;
end;
//[procedure TStream.Wait]
procedure TStream.Wait;
begin
if not Assigned( fData.fThread ) then Exit;
if Assigned( fMethods.fWait ) then
fMethods.fWait( @Self )
else
fData.fThread.WaitFor;
end;
//[function TStream.Write]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TStream.Write(var Buffer; Count: DWord): DWord;
begin
Result := fMethods.fWrite( @Self, Buffer, Count );
end;
{$ENDIF ASM_VERSION}
//[function TStream.WriteVal]
function TStream.WriteVal(Value, Count: DWORD): DWORD;
begin
Result := Write( Value, Count );
end;
//[function TStream.WriteStr]
function TStream.WriteStr(S: String): DWORD;
begin
if S <> '' then
Result := fMethods.fWrite( @Self, S[1], Length( S ) )
else
Result := 0;
end;
//[function TStream.ReadStrZ]
function TStream.ReadStrZ: String;
var C: Char;
begin
Result := '';
REPEAT
C := #0;
Read( C, 1 );
if C <> #0 then Result := Result + C;
UNTIL C = #0;
end;
{$IFDEF _D3orHigher}
function TStream.ReadWStrZ: WideString;
var C: WideChar;
begin
Result := '';
REPEAT
C := #0;
Read( C, 2 );
if C <> #0 then
Result := Result +
{$IFDEF _D3}
WideString( C )
{$ELSE}
C
{$ENDIF};
UNTIL C = #0;
end;
{$ENDIF _D3orHigher}
//[function TStream.ReadStr]
function TStream.ReadStr: String;
var C: Char;
begin
Result := '';
REPEAT
C := #0;
Read( C, 1 );
if C <> #0 then
begin
if C = #13 then
begin
C := #0;
Read( C, 1 );
if C <> #10 then Position := Position - 1;
C := #13;
end
else
if C = #10 then
C := #13;
if C <> #13 then
Result := Result + C;
end;
UNTIL C in [ #13, #0 ];
end;
//[function TStream.ReadStrLen]
function TStream.ReadStrLen(Len: Integer): String;
var i: Integer;
begin
SetLength( Result, Len );
i := Read( Result[1], Len );
SetLength( Result, i );
end;
//[function TStream.WriteStrZ]
function TStream.WriteStrZ(S: String): DWORD;
var C: Char;
begin
if S = '' then
begin
C := #0;
Result := Write( C, 1 );
end
else
Result := Write( S[ 1 ], Length( S ) + 1 );
end;
{$IFDEF _D3orHigher}
function TStream.WriteWStrZ(S: WideString): DWORD;
var C: WideChar;
begin
if S = '' then
begin
C := #0;
Result := Write( C, 2 );
end
else
Result := Write( S[ 1 ], (Length( S ) + 1) * 2 );
end;
{$ENDIF _D3orHigher}
//[function TStream.WriteStrEx]
function TStream.WriteStrEx(S: String): DWord;
var L: DWORD;
begin
L := length(s);
result:=fmethods.fwrite(@self,L,Sizeof(DWORD));
if result = Sizeof(DWORD) then
Inc( result, fmethods.fwrite(@self,s[1],L) );
end;
//[function TStream.ReadStrExVar]
function TStream.ReadStrExVar(var S: String): DWord;
begin
fmethods.fread(@self,result,Sizeof(DWORD));
setlength(s,result);
if result<>0 then result:=fmethods.fread(@self,s[1],result);
end;
//[function TStream.ReadStrEx]
function TStream.ReadStrEx: String;
begin
readstrexvar(result);
end;
//[function TStream.WriteStrPas]
function TStream.WriteStrPas( S: String ): DWORD;
var L: Integer;
begin
Result := 0;
L := Length( S );
if L > 255 then L := 255;
if Write( L, 1 ) < 1 then Exit;
Result := 1;
if L > 0 then
Result := Write( S[ 1 ], L ) + 1;
end;
//[function TStream.ReadStrPas]
function TStream.ReadStrPas: String;
var L: Byte;
begin
Result := '';
if Read( L, 1 ) < 1 then Exit;
SetLength( Result, L );
L := Read( Result[ 1 ], L );
Result := Copy( Result, 1, L );
end;
//[function TStream.Seek]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TStream.Seek(MoveTo: integer; MoveMethod: TMoveMethod): DWord;
begin
Result := fMethods.fSeek( @Self, MoveTo, MoveMethod );
end;
{$ENDIF ASM_VERSION}
//[destructor TStream.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TStream.Destroy;
begin
fMethods.fClose( @Self );
fData.fThread.Free;
inherited;
end;
{$ENDIF ASM_VERSION}
procedure TStream.SaveToFile(const Filename: KOLString; Start, CountSave: DWORD);
var F: PStream;
SavePos: DWORD;
begin
F := NewWriteFileStream( Filename );
SavePos := Position;
Position := Start;
Stream2Stream( F, @ Self, CountSave );
Position := SavePos;
F.Free;
end;
//+-
//[function _NewStream]
function _NewStream( const StreamMethods: TStreamMethods ): PStream;
begin
{-}
New( Result, Create );
{+}{++}(*Result := PStream.Create;*){--}
Move( StreamMethods, Result.fMethods, Sizeof( TStreamMethods ) );
Result.fPMethods := @Result.fMethods;
end;
//+
//[function SeekFileStream]
function SeekFileStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;
begin
Result := FileSeek( Strm.fData.fHandle, MoveTo, MoveFrom );
{$IFDEF FILESTREAM_POSITION}
Strm.fData.fPosition := Result;
{$ENDIF}
end;
//+
//[function GetSizeFileStream]
function GetSizeFileStream( Strm: PStream ): DWORD;
begin
Result := GetFileSize( Strm.fData.fHandle, nil );
if Result = DWORD( -1 ) then Result := 0;
end;
//[procedure DummySetSize]
procedure DummySetSize( Strm: PStream; Value: DWORD );
begin
end;
//[procedure DummyStreamProc]
procedure DummyStreamProc(Strm: PStream);
begin
end;
//[function DummyReadWrite]
function DummyReadWrite( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
{$ifdef cpu86}
asm
XOR EAX, EAX
{$else}
begin
Result:=0;
{$endif cpu86}
end;
//[function ReadFileStream]
function ReadFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
begin
Result := FileRead( Strm.fData.fHandle, Buffer, Count );
{$IFDEF FILESTREAM_POSITION}
inc( Strm.fData.fPosition, Result );
{$ENDIF}
end;
//[function WriteFileStream]
function WriteFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
begin
Result := FileWrite( Strm.fData.fHandle, Buffer, Count );
{$IFDEF FILESTREAM_POSITION}
inc( Strm.fData.fPosition, Result );
{$ENDIF}
end;
//[FUNCTION WriteFileStreamEOF]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WriteFileStreamEOF( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
begin
Result := WriteFileStream( Strm, Buffer, Count );
SetEndOfFile( Strm.fData.fHandle );
end;
{$ENDIF ASM_VERSION}
//[END WriteFileStreamEOF]
//[procedure CloseFileStream]
procedure CloseFileStream( Strm: PStream );
begin
FileClose( Strm.fData.fHandle );
end;
//[FUNCTION SeekMemStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function SeekMemStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;
var NewPos: DWORD;
begin
case MoveFrom of
spBegin: NewPos := MoveTo;
spCurrent: NewPos := Strm.fData.fPosition + DWORD( MoveTo );
else //spEnd:
NewPos := Strm.fData.fSize + DWORD( MoveTo );
end;
if NewPos > Strm.fData.fSize then
Strm.SetSize( NewPos );
Strm.fData.fPosition := NewPos;
Result := NewPos;
end;
{$ENDIF ASM_VERSION}
//[END SeekMemStream]
//[function GetSizeMemStream]
function GetSizeMemStream( Strm: PStream ): DWORD;
begin
Result := Strm.fData.fSize;
end;
//[PROCEDURE SetSizeMemStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure SetSizeMemStream( Strm: PStream; NewSize: DWORD );
var S: PStream;
NewCapacity: DWORD;
begin
S := Strm;
if S.fData.fCapacity < NewSize then
begin
{$IFDEF OLD_MEMSTREAMS_SETSIZE}
NewCapacity := (NewSize or CapacityMask) + 1;
{$ELSE}
NewCapacity := NewSize;
{$ENDIF}
if S.fMemory = nil then
begin
if NewSize <> 0 then
GetMem( S.fMemory, NewCapacity );
end
else
ReallocMem( S.fMemory, NewCapacity );
S.fData.fCapacity := NewCapacity;
end
else
if NewSize = 0 then
begin
FreeMem( S.fMemory );
S.fMemory := nil;
S.fData.fCapacity := 0;
end;
S.fData.fSize := NewSize;
if S.fData.fPosition > S.fData.fSize then
S.fData.fPosition := S.fData.fSize;
end;
{$ENDIF ASM_VERSION}
//[END SetSizeMemStream]
//[FUNCTION ReadMemStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function ReadMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
var S: PStream;
begin
S := Strm;
if Count + S.fData.fPosition > S.fData.fSize then
Count := S.fData.fSize - S.fData.fPosition;
Result := Count;
Move( Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Buffer, Result );
Inc( S.fData.fPosition, Result );
end;
{$ENDIF ASM_VERSION}
//[END ReadMemStream]
//[FUNCTION WriteMemStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WriteMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
var S: PStream;
begin
S := Strm;
if Count + S.fData.fPosition > S.fData.fSize then
S.SetSize( S.fData.fPosition + Count );
Result := Count;
Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result );
Inc( S.fData.fPosition, Result );
end;
{$ENDIF ASM_VERSION}
//[END WriteMemStream]
//[PROCEDURE CloseMemStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure CloseMemStream( Strm: PStream );
var S: PStream;
begin
S := Strm;
if S.fMemory <> nil then
FreeMem( S.fMemory );
end;
{$ENDIF ASM_VERSION}
//[END CloseMemStream]
procedure DummyCloseStream( Strm: PStream );
begin
// nothing here
end;
// by Roman Vorobets:
//[procedure SetSizeFileStream]
procedure SetSizeFileStream( Strm: PStream; NewSize: DWORD );
var
P: DWORD;
begin
P:=Strm.Position;
Strm.Position:=NewSize;
SetEndOfFile(Strm.Handle);
if P < NewSize then
Strm.Position:=P;
end;
//[function NewFileStream]
function NewFileStream( const FileName: KOLString; Options: DWORD ): PStream;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fRead := ReadFileStreamProc;
Result.fMethods.fWrite := WriteFileStream; // not WriteStreamEOF, Lлексей +увалов
Result.fMethods.fSetSiz := SetSizeFileStream;
Result.fData.fHandle := FileCreate( FileName, Options );
end;
//[FUNCTION NewReadFileStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewReadFileStream( const FileName: KOLString ): PStream;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fRead := ReadFileStreamProc;
Result.fData.fHandle := FileCreate( FileName,
ofOpenRead or ofShareDenyWrite or ofOpenExisting );
end;
{$ENDIF ASM_VERSION}
//[END NewReadFileStream]
function NewExFileStream( F: HFile ): PStream;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fRead := ReadFileStreamProc;
Result.fMethods.fWrite := WriteFileStream;
Result.fData.fHandle := F;
Result.fMethods.fClose := DummyCloseStream;
end;
{$IFDEF _D3orHigher}
function NewReadFileStreamW( const FileName: WideString ): PStream;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fRead := ReadFileStreamProc;
Result.fData.fHandle := WFileCreate( FileName,
ofOpenRead or ofShareDenyWrite or ofOpenExisting );
end;
{$ENDIF _D3orHigher}
//[FUNCTION NewWriteFileStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewWriteFileStream( const FileName: KOLString ): PStream;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fWrite := WriteFileStreamEOF;
Result.fMethods.fSetSiz := SetSizeFileStream;
Result.fData.fHandle := FileCreate( FileName,
ofOpenWrite or ofCreateAlways or ofShareDenyWrite );
end;
{$ENDIF ASM_VERSION}
//[END NewWriteFileStream]
{$IFDEF _D3orHigher}
function NewWriteFileStreamW( const FileName: WideString ): PStream;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fWrite := WriteFileStreamEOF;
Result.fMethods.fSetSiz := SetSizeFileStream;
Result.fData.fHandle := WFileCreate( FileName,
ofOpenWrite or ofCreateAlways or ofShareDenyWrite );
end;
{$ENDIF _D3orHigher}
//[FUNCTION NewReadWriteFileStream]
{$IFDEF ASM_noVERSION}
function NewReadWriteFileStream( const FileName: String ): PStream;
asm
PUSH EBX
XCHG EBX, EAX
MOV EAX, offset[BaseFileMethods]
CALL _NewStream
MOV EDX, [ReadFileStreamProc]
MOV [EAX].TStream.fMethods.fRead, EDX
MOV [EAX].TStream.fMethods.fWrite, offset[WriteFileStream]
MOV [EAX].TStream.fMethods.fSetSiz, offset[SetSizeFileStream]
XCHG EBX, EAX
PUSH EAX
CALL FileExists
MOV EDX, ofOpenReadWrite or ofCreateAlways or ofShareDenyWrite
ADD DH, AL // $200 (ofCreateAlways) -> $300 (ofCreateExisting)
POP EAX
CALL FileCreate
MOV [EBX].TStream.fData.fHandle, EAX
XCHG EAX, EBX
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function NewReadWriteFileStream( const FileName: KOLString ): PStream;
var Creation: DWORD;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fRead := ReadFileStreamProc;
Result.fMethods.fWrite := WriteFileStream;
Result.fMethods.fSetSiz := SetSizeFileStream;
Creation := ofCreateAlways;
if FileExists( FileName ) then Creation := ofOpenExisting;
Result.fData.fHandle := FileCreate( FileName,
ofOpenReadWrite or Creation or ofShareDenyWrite );
end;
{$ENDIF ASM_VERSION}
//[END NewReadWriteFileStream]
{$IFDEF _D3orHigher}
function NewReadWriteFileStreamW( const FileName: WideString ): PStream;
var Creation: DWORD;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fRead := ReadFileStreamProc;
Result.fMethods.fWrite := WriteFileStream;
Result.fMethods.fSetSiz := SetSizeFileStream;
Creation := ofCreateAlways;
if WFileExists( FileName ) then Creation := ofOpenExisting;
Result.fData.fHandle := WFileCreate( FileName,
ofOpenReadWrite or Creation or ofShareDenyWrite );
end;
{$ENDIF _D3orHigher}
//[function NewMemoryStream]
function NewMemoryStream: PStream;
begin
Result := _NewStream( MemoryMethods );
end;
//[FUNCTION WriteExMemoryStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION}
function WriteExMemoryStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
var S: PStream;
begin
S := Strm;
if Count + S.fData.fPosition > S.fData.fSize then
Count := S.fData.fSize - S.fData.fPosition;
Result := Count;
Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result );
Inc( S.fData.fPosition, Result );
end;
{$ENDIF ASM_VERSION}
//[END WriteExMemoryStream]
//[procedure DummyClose_ExMemStream]
procedure DummyClose_ExMemStream( Strm: PStream );
begin
// nothing to do - ignore call (memory is not released by any way)
end;
//[function NewExMemoryStream]
function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream;
begin
Result := NewMemoryStream;
Result.fMemory := ExistingMem;
Result.fData.fCapacity := Size;
Result.fData.fSize := Size;
Result.fMethods.fWrite := WriteExMemoryStream;
Result.fMethods.fSetSiz := DummySetSize;
Result.fMethods.fClose := DummyClose_ExMemStream;
end;
//*
//[function Stream2Stream]
function Stream2Stream( Dst, Src: PStream; Count: DWORD ): DWORD;
var Buf: Pointer;
begin
if Src.fMemory <> nil then
begin
if Src.fData.fPosition + Count > Src.fData.fSize then
Count := Src.fData.fSize - Src.fData.fPosition;
Result := Dst.Write( Pointer(DWORD(Src.fMemory)+Src.fData.fPosition)^,
Count );
Inc( Src.fData.fPosition, Result );
end
else
if Dst.fMemory <> nil then
begin
if Dst.fData.fPosition + Count > Dst.fData.fSize then
Dst.SetSize( Dst.fData.fPosition + Count );
Result := Src.Read( Pointer( DWORD( Dst.fMemory ) + Dst.fData.fPosition )^,
Count );
Inc( Dst.fData.fPosition, Result );
end
else
begin
GetMem( Buf, Count );
Count := Src.Read( Buf^, Count );
Result := Dst.Write( Buf^, Count );
FreeMem( Buf );
end;
end;
//[function Stream2StreamEx]
function Stream2StreamEx( Dst, Src: PStream; Count: DWORD ): DWORD;
begin
Result := Stream2StreamExBufSz( Dst, Src, Count, 65536 );
end;
//[function Stream2StreamExBufSz]
function Stream2StreamExBufSz( Dst, Src: PStream; Count, BufSz: DWORD ): DWORD;
var
buf:pointer;
rd, wr:dword;
begin
if count=0 then result:=0 else
begin
result:=0;
BufSz := Min( BufSz, Count );
if BufSz = 0 then BufSz := Count;
getmem(buf,BufSz);
repeat
if countBufSz) or (Count=0);
freemem(buf);
end;
end;
//[FUNCTION Resource2Stream]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function Resource2Stream( DestStrm : PStream; Inst : HInst;
ResName : PKOLChar; ResType : PKOLChar ): Integer;
var R : HRSRC;
G : HGlobal;
P : PChar;
Sz : DWORD;
E : Integer;
begin
Result := 0;
R := FindResource( Inst, ResName, ResType );
if R <> 0 then
begin
Sz := SizeofResource( Inst, R );
G := LoadResource( Inst, R );
if G <> 0 then
begin
P := GlobalLock( G );
if P = nil then
begin
E := GetLastError;
if E = ERROR_INVALID_HANDLE then
P := Pointer( G )
else
Exit;
end;
Result := DestStrm.Write( P^, Sz );
if P <> Pointer( G ) then
GlobalUnlock( G );
//FreeResource( G );
{ from Win32.hlp: "You do not need to call the FreeResource
function to free a resource loaded by using the LoadResource
function." }
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END Resource2Stream]
///////////////////////////////////////////////////////////////////////////
// I N I - F I L E S
///////////////////////////////////////////////////////////////////////////
{$ifdef wince}
{$define read_implementation}
{$I KOLCE_IniFile.inc}
{$undef read_implementation}
{$else}
{ TIniFile }
//[destructor TIniFile.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TIniFile.Destroy;
begin
fFileName := '';
fSection := '';
inherited;
end;
{$ENDIF ASM_VERSION}
{$IFNDEF _D5orHigher}
// Place here correct definition for WritePrivateProfileStruct
// and GetPrivateProfileStruct (a bug in Delphi2, Delphi3 and Delphi4)
//[API WritePrivateProfileStruct]
function WritePrivateProfileStruct(lpszSection, lpszKey: PChar;
lpStruct: Pointer; uSizeStruct: UINT; szFile: PChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external kernel32 name 'WritePrivateProfileStructA';
//[API GetPrivateProfileStruct]
function GetPrivateProfileStruct(lpszSection, lpszKey: PAnsiChar;
lpStruct: Pointer; uSizeStruct: UINT; szFile: PAnsiChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external kernel32 name 'GetPrivateProfileStructA';
// + by Slava A. Gavrik:
////////////////////////////////////////////////////////////////////////////
//[function WritePrivateProfileSection]
function WritePrivateProfileSection(lpAppName, lpString,
lpFileName: PChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external kernel32 name 'WritePrivateProfileSectionA';
//[function GetPrivateProfileSection]
function GetPrivateProfileSection(lpAppName: PChar; lpReturnedString: PChar;
nSize: DWORD; lpFileName: PChar): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
external kernel32 name 'GetPrivateProfileSectionA';
//[function GetPrivateProfileSectionNames]
function GetPrivateProfileSectionNames(lpszReturnBuffer: PChar; nSize:
DWORD;
lpFileName: PChar): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
external kernel32 name 'GetPrivateProfileSectionNamesA';
////////////////////////////////////////////////////////////////////////////
{$ENDIF}
//[procedure TIniFile.ClearAll]
procedure TIniFile.ClearAll;
begin
WritePrivateProfileString( nil, nil, nil,
PKOLChar( fFileName ) );
end;
//[procedure TIniFile.ClearKey]
procedure TIniFile.ClearKey(const Key: KOLString);
begin
WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ), nil,
PKOLChar( fFileName ) );
end;
//[procedure TIniFile.ClearSection]
procedure TIniFile.ClearSection;
begin
WritePrivateProfileString( PKOLChar( fSection ), nil, nil,
PKOLChar( fFileName ) );
end;
//[function TIniFile.ValueBoolean]
function TIniFile.ValueBoolean(const Key: KOLString; Value: Boolean): Boolean;
begin
if fMode = ifmRead then
Result := GetPrivateProfileInt( PKOLChar( fSection ), PKOLChar( Key ),
Integer( Value ), PKOLChar( fFileName ) ) <> 0
else
begin
WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ),
PKOLChar( KOLString( Int2Str( Integer( Value ) ) ) ),
PKOLChar( fFileName ) );
Result := Value;
end;
end;
//[function TIniFile.ValueData]
function TIniFile.ValueData(const Key: KOLString; Value: Pointer;
Count: Integer): Boolean;
begin
if fMode = ifmRead then
Result := GetPrivateProfileStruct( PKOLChar( fSection ), PKOLChar( Key ),
Value, Count, PKOLChar( fFileName ) )
else
Result := WritePrivateProfileStruct( PKOLChar( fSection ), PKOLChar( Key ),
Value, Count, PKOLChar( fFileName ) );
end;
//[function TIniFile.ValueInteger]
function TIniFile.ValueInteger(const Key: KOLString; Value: Integer): Integer;
begin
if fMode = ifmRead then
Result := GetPrivateProfileInt( PKOLChar( fSection ), PKOLChar( Key ),
Integer( Value ), PKOLChar( fFileName ) )
else
begin
Result := Value;
WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ),
PKOLChar( KOLString( Int2Str( Value ) ) ), PKOLChar( fFileName ) );
end;
end;
//[function TIniFile.ValueString]
function TIniFile.ValueString(const Key, Value: KOLString): KOLString;
var
Buffer: array[0..4095] of KOLChar;
begin
if fMode = ifmRead then
begin
Buffer[ 0 ] := #0;
if GetPrivateProfileString(PKOLChar(fSection),
PKOLChar(Key), PKOLChar(Value), Buffer, SizeOf(Buffer) div Sizeof(KOLChar),
PKOLChar(fFileName)) <> 0 then
Result := Buffer
else
Result := ''; // По причине того, что FPC выдает ошибку при отсутствии Key в INI-файле // MTsv DN
end
else
begin
Result := Value;
WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ),
PKOLChar( Value ), PKOLChar( fFileName ) );
end;
end;
//[function OpenIniFile]
function OpenIniFile( const FileName: KOLString ): PIniFile;
begin
{-}
New( Result, Create );
{+}{++}(*Result := PIniFile.Create;*){--}
Result.fFileName := FileName;
end;
/////////////////////////////////////////////////// GetSectionNames, SectionData
// - by Vyacheslav A. Gavrik :
const
IniBufferSize = 32767;
IniBufferStrSize = IniBufferSize+4; /// для махинаций :)
//[procedure _FillStrList]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
//[procedure TIniFile.GetSectionNames]
{$IFDEF UNICODE_CTRLS}
procedure TIniFile.GetSectionNames(Names:PWStrList);
{$ELSE}
procedure TIniFile.GetSectionNames(Names:PStrList);
{$ENDIF}
var
i:integer;
Pc:PKOLChar;
PcEnd:PKOLChar;
Buffer:Pointer;
begin
GetMem(Buffer,IniBufferSize * Sizeof( KOLChar ));
Pc:=Buffer;
i := GetPrivateProfileSectionNames(Buffer, IniBufferSize, PKOLChar(fFileName));
PcEnd:=Pc+i;
repeat
Names.Add(Pc);
Pc:=PC+Length(PC)+1;
until PC>=PcEnd;
FreeMem(Buffer);
end;
//[procedure TIniFile.SectionData]
procedure TIniFile.SectionData(Names: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF});
var
i:integer;
Pc:PKOLChar;
PcEnd:PKOLChar;
Buffer:Pointer;
begin
GetMem(Buffer,IniBufferSize * Sizeof(KOLChar));
Pc:=Buffer;
if fMode = ifmRead then
begin
i:=GetPrivateProfileSection(PKOLChar(fSection), Buffer, IniBufferSize, PKOLChar(fFileName));
PcEnd:=Pc+i;
while PC < PcEnd do // Chg by ECM from REPEAT-UNTIL: i=0 (empty section) => Names.Count=1
begin
Names.Add(Pc);
Pc:=PC+Length(PC)+1;
end;
end else
begin
for i:= 0 to Names.Count-1 do
begin
{$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
(Pc,Names.ItemPtrs[i]);
Pc:=PC+Length(PC)+1;
end;
Pc[0]:=#0;
ClearSection;
WritePrivateProfileSection(PKOLChar(fSection), Buffer, PKOLChar(fFileName));
end;
FreeMem(Buffer);
end;
{$ENDIF ASM_VERSION}
{$endif wince}
/////////////////////////////////////////////////////////////////////////
// M E N U
/////////////////////////////////////////////////////////////////////////
{ -- Menu implementation -- }
//[FUNCTION MakeAccelerator]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;
begin
Result.fVirt := fVirt;
Result.Key := Key;
end;
{$ENDIF ASM_VERSION}
//[END MakeAccelerator]
//[FUNCTION GetAcceleratorText]
{$ifdef wince}
function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLstring;
begin
Result:='';
end;
{$else}
function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLstring;
var
KeyName: array[0..255] of KOLChar;
procedure AddKeyName( Code: Integer );
begin
Code := MapVirtualKey(Code, 0);
if Code = 0 then exit;
if GetKeyNameText(Code shl 16, KeyName, 256) > 0 then begin
if Result <> '' then
Result := Result + '+';
Result := Result + KeyName;
end;
end;
begin
Result := '';
with Accelerator do begin
if fVirt and FCONTROL <> 0 then
AddKeyName(VK_CONTROL);
if fVirt and FSHIFT <> 0 then
AddKeyName(VK_SHIFT);
if fVirt and FALT <> 0 then
AddKeyName(VK_ALT);
if fVirt and $20 <> 0 then
AddKeyName(VK_LWIN);
if fVirt and $40 <> 0 then
AddKeyName(VK_RWIN);
AddKeyName(Key);
end;
end;
{$endif wince}
//[END GetAcceleratorText]
const
MIDATA_CHECKITEM = $40000000;
MIDATA_RADIOITEM = $80000000;
//[function WndProcMenu]
{$IFNDEF NEW_MENU_ACCELL}
function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var M, M1: PMenu;
Idx: Integer;
Id: Integer;
begin
Result := False;
if Msg.message = WM_COMMAND then
begin
if {$ifdef wince}(LOWORD( Msg.wParam ) <> 0){$else}(Msg.lParam = 0){$endif} and (HIWORD( Msg.wParam ) <= 1) then
begin
M := PMenu( Sender.fMenuObj );
while (M = nil) and (Sender.Parent <> nil) do
begin
Sender := Sender.Parent;
M := PMenu( Sender.fMenuObj );
end;
while M <> nil do
begin
Id := LoWord( Msg.wParam );
M1 := M.Items[ Id ];
if M1 <> nil then
begin
Result := True;
Rslt := 0;
Idx := M.IndexOf( M1 );
M.fByAccel := HiWord( Msg.wParam ) <> 0;
if M1.FRadioGroup <> 0 then
M1.RadioCheckItem
else
if M1.FIsCheckItem then
M1.Checked := not M1.Checked;
if Assigned(M1.FOnMenuItem) then
M1.FOnMenuItem( M, Idx )
else if Assigned( M.FOnMenuItem ) then
M.FOnMenuItem( M, Idx );
break;
end;
M := M.fNextMenu;
end;
end;
end;
end;
{$ELSE}
function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
function ProcessMenuItem(M: PMenu; Id: Integer): Boolean;
var
M1: PMenu;
Idx: Integer;
begin
M1 := M.Items[ Id ];
Result := (M1 <> nil);
if Result then
begin
Idx := M.IndexOf( M1 );
M.fByAccel := HiWord( Msg.wParam ) <> 0;
if M1.FRadioGroup <> 0 then
M1.RadioCheckItem
else
if M1.FIsCheckItem then
M1.Checked := not M1.Checked;
if Assigned(M1.FOnMenuItem) then begin
{$IFDEF USE_MENU_CURCTL} // fixed
M.fCurCtl := Sender; // fixed
{$ENDIF} // fixed
M1.FOnMenuItem( M, Idx )
end
else if Assigned( M.FOnMenuItem ) then
M.FOnMenuItem( M, Idx );
end;
end;
var
M: PMenu;
Id: Integer;
begin
Result := False;
if Msg.message = WM_COMMAND then
if {$ifdef win32}(Msg.lParam = 0) and {$endif} (HIWORD( Msg.wParam ) <= 1) then begin
Id := LoWord(Msg.wParam);
M := PMenu(Sender.fAutoPopupMenu);
if (M <> nil) and ProcessMenuItem(M, Id) then begin
Result := True;
Rslt := 0;
end
else begin
M := PMenu(Sender.fMenuObj);
while M <> nil do begin
if ProcessMenuItem(M, Id) then begin
Result := True;
Rslt := 0;
Break;
end;
M := M.fNextMenu;
end;
end;
end;
end;
{$ENDIF}
{$ENDIF WIN_GDI}
//[function NewMenu]
{$IFDEF GDI}
function NewMenu( AParent : PControl; MaxCmdReserve : DWORD;
const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu;
var M: PMenu;
{$IFDEF INITIALFORMSIZE_FIXMENU}
R: TRect;
{$ENDIF}
begin
{-}
New( Result, Create );
{+}{++}(*Result := PMenu.Create;*){--}
Result.FVisible := TRUE;
Result.FPopupFlags := TPM_LEFTALIGN or TPM_LEFTBUTTON;
Result.FItems := NewList;
Result.FOnMenuItem := aOnMenuItem;
if (High(Template)>=0) and (Template[0] <> nil) then
begin
{$ifdef win32}
if (AParent <> nil) and (AParent.fMenuObj = nil) and not AParent.fIsControl then
Result.FHandle := CreateMenu
else
{$endif win32}
Result.FHandle := CreatePopupMenu;
Result.FillMenuItems( Result.FHandle, 0, Template );
end;
if assigned( AParent ) then
begin
Result.FControl := AParent;
if AParent.fMenuObj <> nil then
begin
// add popup menu to the end of menu chain
M := PMenu( AParent.fMenuObj );
while M.fNextMenu <> nil do
M := M.fNextMenu;
M.fNextMenu := Result;
end
else
begin
if not AParent.fIsControl then
begin
{$IFDEF INITIALFORMSIZE_FIXMENU}
R := AParent.ClientRect;
{$ENDIF}
{$ifdef wince}
CeSetMenuProc:=@CeSetMenuHandler;
AParent.fMenu:=Result.FHandle;
if AParent.fHandle <> 0 then begin
DestroyWindow(SHFindMenuBar(AParent.fHandle));
CeSetMenu(AParent.fHandle, Result);
end;
{$else}
AParent.Menu := Result.FHandle;
{$endif wince}
{$IFDEF INITIALFORMSIZE_FIXMENU}
AParent.SetClientSize( R.Right, R.Bottom );
{$ENDIF}
end;
AParent.fMenuObj := Result;
AParent.AttachProc( WndProcMenu );
{$IFDEF USE_AUTOFREE4CONTROLS}
AParent.Add2AutoFree( Result );
{$ENDIF}
end;
end;
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
//--- some code from samples - may be useful to see "how to"
Function AddSeparatorToMenu( Menu : PGtkMenu ) : PgtkMenuItem ;
begin
Result := PGtkMenuitem( gtk_menu_item_new ) ;
gtk_menu_append( GTK_WIDGET( Menu ), PGtkWidget( Result ) ) ;
gtk_widget_show( PGtkWidget ( Result ) ) ;
end;
Function AddItemToMenu( Menu : PGtkMenu;
ShortCuts : PGtkAccelGroup;
const Caption : AnsiString;
const ShortCut : AnsiString;
CallBack : TGtkSignalFunc;
CallBackdata : Pointer ) : PGtkMenuItem;
Var
Key, Modifiers : DWORD;
//LocalAccelGroup : PGtkAccelGroup; -- not used since gtk_menu_ensure_uline_accel_group not defined anywhere...
TheLabel : PGtkLabel;
begin
Result := PGtkMenuItem ( gtk_menu_item_new_with_label( '' ) ) ;
TheLabel := GTK_LABEL(GTK_BIN( Result )^.child ) ;
Key:= gtk_label_parse_uline( TheLabel , Pchar ( Caption ) ) ;
//----------------
{If Key<>0 then // gtk_menu_ensure_uline_accel_group -- not defined anywhere...
begin
LocalAccelGroup := gtk_menu_ensure_uline_accel_group( Menu );
gtk_widget_add_accelerator( PGtkWidget ( Result ), 'activateitem',
LocalAccelGroup , Key ,
0 , TGtkAccelFlags ( 0 ) ) ;
end;}
//-----------------
gtk_menu_append( GTK_WIDGET( Menu ), PGtkWidget( Result ) ) ;
//-----------------
If ( ShortCut<>'' ) and ( ShortCuts<> Nil ) then
begin
gtk_accelerator_parse ( pchar( ShortCut ) , @key , @modifiers ) ;
gtk_widget_add_accelerator ( PGtkWidget ( Result ) , ' activateitem' ,
ShortCuts, Key, modifiers, GTK_ACCEL_VISIBLE );
end;
//------------------
If Assigned( CallBack ) then
begin
gtk_signal_connect( PGtkObject ( Result ) , 'activate' ,
CallBack , CallBackdata ) ;
gtk_widget_show( PgtkWidget ( Result ) ) ;
end ;
end;
Function AddMenuToMenuBar( MenuBar : PGtkMenuBar;
ShortCuts : PGtkAccelGroup;
Caption : AnsiString;
CallBack : TGtkSignalFunc;
CallBackdata : Pointer;
AlignRight : Boolean;
Var MenuItem : PgtkMenuItem ) : PGtkMenu;
Var Key : DWORD;
TheLabel : PGtkLabel;
begin
MenuItem := PGtkMenuItem( gtk_menu_item_new_with_label( '' ) ) ;
If AlignRight Then
gtk_menu_item_right_justify( MenuItem );
TheLabel := GTK_LABEL( GTK_BIN( MenuItem )^ .child ) ;
Key := gtk_label_parse_uline( TheLabel, Pchar ( Caption ) ) ;
If Key<>0 then
gtk_widget_add_accelerator( PGtkWidget( MenuItem ), 'activateitem',
Shortcuts, Key, GDK_MOD1_MASK, GTK_ACCEL_LOCKED );
Result := PGtkMenu( gtk_menu_new );
If Assigned( CallBack ) then
gtk_signal_connect( PGtkObject ( Result ), 'activate',
CallBack, CallBackdata ) ;
gtk_widget_show( PgtkWidget ( MenuItem ) ) ;
gtk_menu_item_set_submenu( MenuItem, PGtkWidget( Result ) ) ;
gtk_menu_bar_append( GTK_WIDGET( MenuBar ), PgtkWidget( MenuItem ) ) ;
end;
function NewMenu( AParent : PControl; MaxCmdReserve : DWORD;
const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu;
procedure CreateMenuItems( ParentMenu: PMenu; var i: Integer );
var Item, PrevItem: PMenu;
s: String;
j: Integer;
begin
PrevItem := nil;
while i <= High( Template )-1 do
begin
inc( i );
s := Template[ i ];
if s = '' then break; // end of template
if s = ')' then
begin
inc( i ); break; // end of submenu
end;
new( Item, Create );
Item.FCaption := s;
Item.FVisible := TRUE;
Item.FParentMenu := ParentMenu;
if ParentMenu.FItems = nil then
ParentMenu.FItems := NewList;
ParentMenu.FItems.Add( Item );
if (s <> '') and (s[ 1 ] in [ '+', '-' ]) then
begin
Item.fIsCheckItem := TRUE;
Item.fChecked := S[ 1 ] = '+';
s := CopyEnd( s, 2 );
if (s <> '') and (s[ 1 ] = '!') then
begin
if PrevItem <> nil then
begin
if PrevItem.fRadioGroup <> 0 then
Item.fRadioGroup := PrevItem.fRadioGroup;
end
else inc( Item.fRadioGroup );
s := CopyEnd( s, 2 );
end;
end;
if s = '-' then
Item.fIsSeparator := TRUE
else
begin
// extract mnemonic
for j := Length( s )-1 downto 1 do
begin
if (s[ j ] = '&') and (s[ j+1 ] <> '&') then // mnemonic
begin
Item.fMnemonics := Item.fMnemonics + s[ j+1 ];
Delete( s, j, 1 );//? m ?
end;
end;
end;
//---------------------------- now call gtk for create item's widget
if Item.FIsSeparator then
Item.fGtkMenuItem := gtk_menu_item_new
else
Item.fGtkMenuItem := gtk_menu_item_new_with_label( PChar( s ) );
if ParentMenu.fGtkMenuBar <> nil then
gtk_menu_bar_append(
ParentMenu.fGtkMenuBar,
Item.fGtkMenuItem )
else
gtk_menu_shell_append(
GTK_MENU_SHELL( ParentMenu.fGtkMenuShell ),
Item.fGtkMenuItem );
if s = '(' then
begin
inc( i );
if PrevItem <> nil then
begin
PrevItem.fGtkMenuShell := gtk_menu_new;
gtk_menu_item_set_submenu(
GTK_MENU_ITEM( PrevItem.fGtkMenuItem ),
PrevItem.fGtkMenuShell );
CreateMenuItems( PrevItem, i );
end;
end;
PrevItem := Item;
end;
end;
var i: Integer;
begin
new( Result, Create );
i := -1;
if AParent.fMenuObj = nil then
begin // создается главное меню с линейкой меню (наверху формы? любого контрола?)
AParent.fMenuObj := Result;
Result.fGtkMenuBar := gtk_menu_bar_new;
//AParent.fMenuBar := Result.fGtkMenuBar;
gtk_container_add( GTK_CONTAINER( AParent.fClient ), Result.fGtkMenuBar );
gtk_widget_show( Result.fGtkMenuBar );
end
else
begin
PMenu( AParent.fMenuObj ).fNextMenu := Result;
Result.fGtkMenuShell := gtk_menu_new;
end;
CreateMenuItems( Result, i );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[END NewMenu]
//[function NewMenuEx]
function NewMenuEx( AParent : PControl; FirstCmd : Integer;
const Template : array of PKOLChar; aOnMenuItems: array of TOnMenuItem ): PMenu;
begin
Result := NewMenu( AParent, FirstCmd, Template, nil );
{$IFDEF GDI}
Result.AssignEvents( 0, aOnMenuItems );
{$ENDIF GDI}
end;
//[END NewMenuEx]
{$IFDEF WIN_GDI}
{ TMenu }
const
Breaks: array[ TMenuBreak ] of DWORD = ( 0, MFT_MENUBREAK, MFT_MENUBARBREAK );
{ + by AK - Andrzej Kubaszek }
//[function MenuStructSize]
function MenuStructSize: Integer;
begin
{$ifdef win32}
Result := 44;
if not( WinVer in [wv31, wv95, wvNT] ) then
{$endif win32}
Result := {48=} Sizeof( TMenuItemInfo );
end;
{$ENDIF WIN_GDI}
//[destructor TMenu.Destroy]
{$IFDEF GDI}
destructor TMenu.Destroy;
var Next, Prnt: PMenu;
begin
{$IFDEF DEBUG_MENU_DESTROY}
LogFileOutput( GetStartDir + 'TMenu.Destroy.txt',
Int2Hex( DWORD( @ Self ), 6 ) + ' ' + Int2Str( RefCount ) );
{$ENDIF}
if Count > 0 then
begin
FItems.ReleaseObjects;
FItems := NewList;
end;
if FParentMenu <> nil then
begin
Prnt := FParentMenu;
Next := Prnt.RemoveSubMenu( FId );
Prnt.FItems.Remove( @ Self );
{$ifdef wince}
if FParentMenu.FParentMenu = nil then
RedrawFormMenuBar;
{$endif wince}
FParentMenu := nil;
if Next = nil then
begin
{$ifdef cpu86}
asm
nop
end;
{$endif cpu86}
Exit;
end;
end;
if (FControl <> nil) and (FControl.fMenu = FHandle) and (FHandle <> 0) then
begin
//if FControl.fHandle <> 0 then
if not FControl.fDestroying then //!!!fix by Galkov
begin
{$ifdef wince}
CeSetMenu( FControl.fHandle, 0 );
{$else}
Windows.SetMenu( FControl.fHandle, 0 );
{$endif}
// this removes main menu from window, but does not destroy it
end;
FControl.fMenu := 0;
Next := PMenu( FControl.fMenuObj );
while Next <> nil do
begin
if Next.fNextMenu = @Self then
begin
Next.fNextMenu := fNextMenu;
break;
end;
Next := Next.fNextMenu;
end;
end;
Next := fNextMenu;
if FBitmap <> 0 then
Bitmap := 0;
if FHandle <> 0 then
begin
//if not
DestroyMenu( FHandle )
// then LogFileOutput( GetStartDir + 'err.log.txt', SysErrorMessage( GetLastError ) )
;
end;
FCaption := '';
FItems.Free;
Next.Free;
inherited;
// all later created (popup) menus (of the same control)
// are destroyed too
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
destructor TMenu.Destroy;
//var Next, Prnt: PMenu;
begin
{$IFDEF DEBUG_MENU_DESTROY}
LogFileOutput( GetStartDir + 'TMenu.Destroy.txt',
Int2Hex( DWORD( @ Self ), 6 ) + ' ' + Int2Str( RefCount ) );
{$ENDIF}
//if Count > 0 then
if Assigned( fItems ) then
begin
FItems.ReleaseObjects;
FItems := NewList;
end;
{if FParentMenu <> nil then
begin
Prnt := FParentMenu;
Next := Prnt.RemoveSubMenu( FId );
FParentMenu := nil;
Prnt.FItems.Remove( @ Self );
if Next = nil then Exit;
end;}
{if (FControl <> nil) and (FControl.fMenu = FHandle) and (FHandle <> 0) then
begin
begin
Windows.SetMenu( FControl.fHandle, 0 );
// this removes main menu from window, but does not destroy it
end;
FControl.fMenu := 0;
Next := PMenu( FControl.fMenuObj );
while Next <> nil do
begin
if Next.fNextMenu = @Self then
begin
Next.fNextMenu := fNextMenu;
break;
end;
Next := Next.fNextMenu;
end;
end;}
//Next := fNextMenu;
//if FBitmap <> 0 then Bitmap := 0;
//if FHandle <> 0 then DestroyMenu( FHandle );
FCaption := '';
fMnemonics := '';
FItems.Free;
//Next.Free;
inherited;
// all later created (popup) menus (of the same control)
// are destroyed too
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[function TMenu.GetInfo]
function TMenu.GetInfo( var MII: TMenuItemInfo ): Boolean;
begin
MII.cbSize := MenuStructSize;
Result := GetMenuItemInfo( Parent.FHandle, FId, FALSE,
{Windows.}PMenuitemInfo( @ MII )^ );
end;
//[procedure TMenu.RedrawFormMenuBar]
procedure TMenu.RedrawFormMenuBar;
var C: PControl;
begin
C := TopParent.FControl;
if not AppletTerminated then
if (C <> nil) and not C.IsControl and (Pointer( C.fMenuObj ) = Pointer( TopParent )) and not C.fDestroying then
{$ifdef wince}
CeSetMenu( C.FHandle, TopParent );
{$else}
DrawMenuBar( C.FHandle );
{$endif wince}
end;
//[function TMenu.SetInfo]
function TMenu.SetInfo( var MII: TMenuItemInfo ): Boolean;
var H: THandle;
begin
MII.cbSize := MenuStructSize;
H := FHandle;
if FParentMenu <> nil then
H := FParentMenu.FHandle;
if H = 0 then begin
Result:=False;
exit;
end;
{$ifdef wince}
if (FHandle <> 0) and (FParentMenu <> nil) then begin
FParentMenu.SaveState;
DestroyMenu(FHandle);
FParentMenu.ReCreate;
Result:=True;
end
else
if MII.fMask and MIIM_STATE <> 0 then begin
EnableMenuItem(H, FId, MII.fState and MFS_DISABLED);
CheckMenuItem(H, FId, MII.fState and MFS_CHECKED);
Result:=True;
end
else
{$endif wince}
// {$IFNDEF UNICODE_CTRLS}
Result := SetMenuItemInfo( H, FId, FALSE, {Windows.}PMenuitemInfo( @ MII )^ );
// {$ELSE}
// Result := SetMenuItemInfoW( H, FId, FALSE, Windows.PMenuitemInfoW( @ MII )^ );
// {$ENDIF}
if Result and ((FParentMenu = nil) or (FParentMenu.FParentMenu = nil)) then
RedrawFormMenuBar;
end;
//[function TMenu.SetTypeInfo]
function TMenu.SetTypeInfo( var MII: TMenuItemInfo ): Boolean;
begin
if not FIsSeparator then
begin
if FBmpItem = 0 then
MII.dwTypeData := PKOLChar( FCaption )
else
MII.dwTypeData := Pointer( FBmpItem );
MII.cch := Length( FCaption )*SizeOfKOLChar;
end;
Result := SetInfo( MII );
end;
//[function TMenu.GetTopParent]
function TMenu.GetTopParent: PMenu;
begin
Result := @ Self;
while Result.FParentMenu <> nil do
Result := Result.FParentMenu;
end;
//[function TMenu.GetControl]
function TMenu.GetControl: PControl;
begin
Result := TopParent.FControl;
end;
//[function TMenu.GetItems]
function TMenu.GetItems( Id: HMenu ): PMenu;
function SearchItems( ParentMenu: PMenu; var FromIdx: Integer ): PMenu;
var I: Integer;
begin
Result := ParentMenu;
if Id = HMenu( FromIdx ) then Exit;
if (Id >= 4096) and (DWORD( ParentMenu.FId ) = Id) then Exit;
if ParentMenu.FItems = nil then Exit;
for I := 0 to ParentMenu.FItems.FCount-1 do
begin
Inc( FromIdx );
Result := SearchItems( ParentMenu.FItems.Items[ I ], FromIdx );
if Result <> nil then Exit;
end;
Result := nil;
end;
var I: Integer;
begin
I := -1;
Result := SearchItems( @ Self, I );
end;
//[function TMenu.GetCount]
function TMenu.GetCount: Integer;
var I: Integer;
SubM: PMenu;
begin
Result := FItems.FCount;
for I := 0 to Result-1 do
begin
SubM := FItems.Items[ I ];
Result := Result + SubM.Count;
end;
end;
//[function TMenu.IndexOf]
function TMenu.IndexOf( Item: PMenu ): Integer;
function SearchMenu( ParentMenu: PMenu; var FromIdx: Integer ): PMenu;
var I: Integer;
begin
Result := ParentMenu;
if Result = Item then Exit;
for I := 0 to ParentMenu.FItems.FCount-1 do
begin
Inc( FromIdx );
Result := SearchMenu( ParentMenu.FItems.Items[ I ], FromIdx );
if Result <> nil then Exit;
end;
Result := nil;
end;
begin
Result := -1;
if SearchMenu( @ Self, Result ) = nil then
Result := -2;
end;
//[function TMenu.GetState]
function TMenu.GetState( const Index: Integer ): Boolean;
var MII: TMenuItemInfo;
begin
if FVisible then
begin
MII.fMask := MIIM_STATE;
if GetInfo( MII ) then
FSavedState := MII.fState;
end;
Result := LongBool( FSavedState and Index );
if Index < 0 then
Result := not Result;
end;
//[procedure TMenu.SetState]
procedure TMenu.SetState( const Index: Integer; Value: Boolean );
var MII: TMenuItemInfo;
begin
GetState( 0 );
if Value xor (Index < 0) then
FSavedState := FSavedState or DWORD( Index and $7FFFFFFF )
else
FSavedState := FSavedState and not DWORD( Index );
if FVisible then
begin
MII.fMask := MIIM_STATE;
if GetInfo( MII ) then
begin
MII.fState := FSavedState;
SetInfo( MII );
end;
end;
end;
//[procedure TMenu.SetData]
procedure TMenu.SetData( Value: Pointer );
var MII: TMenuItemInfo;
begin
MII.fMask := MIIM_DATA;
MII.dwItemData := DWORD( Value );
SetInfo( MII );
FData := Value;
end;
//[procedure TMenu.ClearBitmaps]
procedure TMenu.ClearBitmaps;
begin
if FBitmap <> 0 then
DeleteObject( FBitmap );
if FBmpChecked <> 0 then
DeleteObject( FBmpChecked );
if FBmpItem <> 0 then
DeleteObject( FBmpItem );
end;
//[procedure TMenu.SetBitmap]
procedure TMenu.SetBitmap( Value: HBitmap );
var MII: TMenuItemInfo;
begin
if not FClearBitmaps then
begin
FClearBitmaps := TRUE;
Add2AutoFreeEx( ClearBitmaps );
end;
if Value = FBitmap then Exit;
if FBitmap <> 0 then
DeleteObject( FBitmap ); // seems not necessary.
FBitmap := Value;
MII.fMask := MIIM_CHECKMARKS;
MII.hbmpChecked := FBmpChecked;
MII.hbmpUnchecked := FBitmap;
SetInfo( MII );
end;
//[procedure TMenu.SetBmpChecked]
procedure TMenu.SetBmpChecked( Value: HBitmap );
var MII: TMenuItemInfo;
begin
if not FClearBitmaps then
begin
FClearBitmaps := TRUE;
Add2AutoFreeEx( ClearBitmaps );
end;
if Value = FBmpChecked then Exit;
if FBmpChecked <> 0 then
DeleteObject( FBmpChecked );
FBmpChecked := Value;
MII.fMask := MIIM_CHECKMARKS;
MII.hbmpChecked := FBmpChecked;
MII.hbmpUnchecked := FBitmap;
SetInfo( MII );
end;
//[procedure TMenu.SetBmpItem]
procedure TMenu.SetBmpItem( Value: HBitmap );
var MII: TMenuItemInfo;
begin
if not FClearBitmaps then
begin
FClearBitmaps := TRUE;
Add2AutoFreeEx( ClearBitmaps );
end;
if Value = FBmpItem then Exit;
if FBmpItem <> 0 then
DeleteObject( FBmpItem );
FBmpItem := Value;
{$ifdef win32}
if WinVer >= wv98 then {AK}
begin {AK}
MII.fMask := $80 {MIIM_BITMAP} ; {AK}
MII.hbmpItem:=Value; {AK}
end {AK}
else {AK}
{$endif}
begin//I haven't possibility to test it in Win95 {AK}
MII.fType := MFT_BITMAP;
MII.dwItemData := Value;
end; {AK}
SetInfo( MII );
end;
//[procedure TMenu.SetAccelerator]
{$IFNDEF NEW_MENU_ACCELL}
procedure TMenu.SetAccelerator(const Value: TMenuAccelerator);
const MaxAccel = 1000;
type TAccTab = array[0..10000] of TAccel;
PAccTab = ^TAccTab;
var AccTab: PAccTab;
I, N : Integer;
M, SubM: PMenu;
C: PControl;
Main: Boolean;
begin
if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then Exit;
FAccelerator := Value;
C := TopParent.FControl;
if C = nil then Exit;
if C.fAccelTable <> 0 then
DestroyAcceleratorTable( C.fAccelTable );
C.fAccelTable := 0;
GetMem( AccTab, sizeof( TAccel ) * MaxAccel );
N := 0;
M := PMenu( C.fMenuObj );
Main := TRUE;
while M <> nil do
begin
if Main or M.Visible then
begin
for I := 0 to MaxInt-1 do
begin
SubM := M.Items[ I ];
if SubM = nil then break;
if SubM.FVisible then
if (SubM.FAccelerator.Key <> 0) or (SubM.FAccelerator.fVirt <> 0) then
begin
AccTab[ N ].fVirt := SubM.FAccelerator.fVirt;
AccTab[ N ].key := SubM.FAccelerator.Key;
AccTab[ N ].cmd := WORD( SubM.FId );
Inc( N );
if N > MaxAccel then break;
end;
end;
end;
if N > MaxAccel then break;
M := M.fNextMenu;
end;
if N > 0 then
begin
C.fAccelTable := CreateAcceleratorTable( AccTab[ 0 ], N );
{$IFDEF USE_AUTOFREE4CONTROLS}
C.Add2AutoFreeEx( C.DoDestroyAccelTable );
{$ENDIF}
C := C.ParentForm;
if C <> nil then
C.SupportMnemonics;
end;
FreeMem( AccTab );
end;
{$ELSE NEW_MENU_ACCELL}
procedure TMenu.SetAccelerator(const Value: TMenuAccelerator);
var
C: PControl;
M: PMenu;
begin
if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then Exit;
FAccelerator := Value;
C := FControl;
M := @Self;
while (C = nil) and (M <> nil) do begin
M := M.Parent;
if (M <> nil) then
C := M.FControl;
end;
if (C <> nil) then
C.SupportMnemonics;
end;
{$ENDIF NEW_MENU_ACCELL}
//[procedure TMenu.SetMenuItemCaption]
procedure TMenu.SetMenuItemCaption( const Value: KOLString );
var MII: TMenuItemInfo;
begin
FCaption := Value;
if FParentMenu = nil then Exit; {+ecm}
{$ifdef win32}
{AK}if not (WinVer in [wv95,wvNT]) then
{AK} MII.fMask := $40 {MIIM_STRING}
{AK}else begin
{$endif win32}
MII.fMask := MIIM_TYPE;
MII.fType := MFT_STRING;
{$ifdef win32}
{AK}end;
{$endif win32}
MII.dwTypeData:=nil;
MII.cch := 0; // to fix turning radio mark to check mark in NT4
GetInfo( MII ); //-----------------------------------------------
MII.dwTypeData := PKOLChar( Value );
MII.cch := Length( Value )*SizeOfKOLChar;
SetInfo( MII );
end;
//[procedure TMenu.SetMenuBreak]
procedure TMenu.SetMenuBreak( Value: TMenuBreak );
var MII: TMenuItemInfo;
begin
if FId = 0 then Exit;
if FMenuBreak = Value then Exit;
FMenuBreak := Value;
FillChar( MII, Sizeof( MII ), #0 );
MII.fMask := MIIM_TYPE;
MII.dwTypeData := nil;
if GetInfo( MII ) then
begin
MII.fType := MII.fType and not( MFT_MENUBREAK or MFT_MENUBARBREAK ) or
Breaks[ Value ];
SetTypeInfo( MII );
end;
end;
//[procedure TMenu.SetVisible]
procedure TMenu.SetVisible( Value: Boolean );
var I, MPos: Integer;
M: PMenu;
MII: TMenuItemInfo;
begin
if Value then
if FParentMenu <> nil then
FParentMenu.Visible := TRUE;
if Value = FVisible then Exit;
FVisible := Value;
if (FControl <> nil) and (FControl.fMenuObj = @ Self) then
begin
FControl.GetWindowHandle;
{$ifdef wince}
if Value then
CeSetMenu( FControl.fHandle, TopParent )
else
CeSetMenu( FControl.fHandle, nil );
{$else}
if Value then
SetMenu( FControl.fHandle, FHandle )
else
SetMenu( FControl.fHandle, 0 );
{$endif wince}
Exit;
end;
if FId = 0 then Exit;
if FParentMenu = nil then Exit;
MPos := 0;
for I := 0 to FParentMenu.FItems.FCount-1 do
begin
M := FParentMenu.FItems.Items[ I ];
if M = @Self then
break;
if M.FVisible then
Inc(MPos);
end;
if Value then
begin // show menu item inserting it again into appropriate position
FillChar( MII, Sizeof( MII ), #0 );
MII.cbSize := MenuStructSize;
MII.fMask := MIIM_CHECKMARKS or MIIM_ID or MIIM_STATE or
MIIM_TYPE;
MII.fType := Breaks[ FMenuBreak ];
MII.fState := FSavedState;
MII.wID := FId;
MII.dwItemData := DWORD( FData );
if not FIsSeparator then
begin
MII.fType := MII.fType or MFT_STRING;
MII.dwTypeData := PKOLChar( FCaption );
MII.cch := Length( FCaption );
end
else
MII.fType := MII.fType or MFT_SEPARATOR;
if FRadioGroup <> 0 then
MII.fType := MII.fType or MFT_RADIOCHECK;
if FOwnerDraw then
MII.fType := MII.fType or MFT_OWNERDRAW;
if FBitmap <> 0 then
begin
MII.fMask := MII.fMask or MIIM_CHECKMARKS;
MII.hbmpUnchecked := FBitmap;
end;
if FHandle <> 0 then
begin
MII.fMask := MII.fMask or MIIM_SUBMENU;
MII.hSubMenu := FHandle;
end;
InsertMenuItem( FParentMenu.FHandle, MPos, True, PMenuitemInfo( @ MII )^ );
end
else
begin // hide menu item removing it
GetState( 0 ); // store menu item state in FSavedState to allow
// changing its state while it is not attached to
// a menu
RemoveMenu( FParentMenu.FHandle, MPos, MF_BYPOSITION );
end;
if (FControl <> nil) or (FParentMenu <> nil) and (FParentMenu.FControl <> nil) then
RedrawFormMenuBar;
end;
//[procedure TMenu.RadioCheckItem]
procedure TMenu.RadioCheckItem;
var I, J: Integer;
M, First, Last: PMenu;
begin
if (FParentMenu <> nil) and (FRadioGroup <> 0) then
begin
I := FParentMenu.FItems.IndexOf( @ Self );
if I >= 0 then
begin
First := @ Self;
Last := @ Self;
for J := I-1 downto 0 do
begin
M := FParentMenu.FItems.Items[ J ];
if M.FRadioGroup <> FRadioGroup then break;
if M.FVisible then
First := M;
end;
for J := I+1 to FParentMenu.FItems.FCount-1 do
begin
M := FParentMenu.FItems.Items[ J ];
if M.FRadioGroup <> FRadioGroup then break;
if M.FVisible then
Last := M;
end;
if First <> Last then
begin
CheckMenuRadioItem( FParentMenu.FHandle, First.FId, Last.FId,
FId, MF_BYCOMMAND {or MF_CHECKED} );
Exit;
end;
end;
end;
Checked := TRUE;
end;
//[function TMenu.FillMenuItems]
function TMenu.FillMenuItems(AHandle: HMenu; StartIdx: Integer;
const Template: array of PKOLChar): Integer;
var S, S1: PKOLChar;
I: Integer;
MII: TMenuItemInfo;
Item, PrevItem: PMenu;
begin
PrevItem := nil;
I := StartIdx;
while I <= High( Template ) do
begin
S := Template[ I ];
if (S = nil) or (S^ = #0) then break;
if String( S ) = {$IFDEF F_P}'' +{$ENDIF} ')' then
begin
Inc(I);
break;
end;
{-}
new( Item, Create );
{+}{++}(*Item := PMenu.Create;*){--}
Item.FVisible := TRUE;
Item.FParentMenu := @ Self;
Item.FItems := NewList;
FItems.Add( Item );
FillChar( MII, Sizeof( MII ), #0 );
MII.cbSize := MenuStructSize;
MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
if String( S ) <> {$IFDEF F_P}'' +{$ENDIF} '-' then
begin
if (S^ = {$IFDEF F_P}'' +{$ENDIF} '-') or
(S^ = {$IFDEF F_P}'' +{$ENDIF} '+') then
begin
Item.FIsCheckItem := TRUE;
{$ifdef win32}
MII.dwItemData := MIDATA_CHECKITEM;
{$endif win32}
if S^ <> {$IFDEF F_P}'' +{$ENDIF} '-' then
MII.fState := MII.fState or MFS_CHECKED;
Inc( S );
if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then
begin
MII.fType := MII.fType or MFT_RADIOCHECK;
{$ifdef win32}
MII.dwItemData := MII.dwItemData or MIDATA_RADIOITEM;
{$endif win32}
Inc( S );
if PrevItem <> nil then
begin
if PrevItem.FRadioGroup <> 0 then
Item.FRadioGroup := PrevItem.FRadioGroup;
end;
if Item.FRadioGroup = 0 then
Inc( Item.FRadioGroup );
if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then
begin
Inc( S );
Inc( Item.FRadioGroup );
end;
end;
end;
Item.FCaption := S;
end
else
begin
Item.FIsSeparator := TRUE;
MII.fType := MFT_SEPARATOR;
MII.fState := MFS_GRAYED;
MII.wID := 0;
end;
Item.FId := FDynamicMenuID;
Inc( FDynamicMenuID );
MII.wID := Item.FId;
if I <> High( Template ) then
begin
S1 := Template[ I + 1 ];
if String( S1 ) = {$IFDEF F_P}'' +{$ENDIF} '(' then Item.FHandle := CreatePopupMenu;
end;
MII.hSubMenu := Item.FHandle;
MII.dwTypeData := PKOLChar( S );
MII.cch := {$IFDEF UNICODE_CTRLS} WStrLen( S ) {$ELSE} StrLen( S ) {$ENDIF};
InsertMenuItem( AHandle, DWORD(-1), True, PMenuitemInfo( @ MII )^ );
if Item.FHandle <> 0 then
I := Item.FillMenuItems( Item.FHandle, I + 2, Template )
else
Inc( I );
PrevItem := Item;
end;
Result := I;
end;
//[procedure TMenu.AssignEvents]
procedure TMenu.AssignEvents(StartIdx: Integer;
const Events: array of TOnMenuItem);
var I: Integer;
M: PMenu;
begin
for I := 0 to High(Events) do
begin
M := Items[ StartIdx ];
if M = nil then break;
M.FOnMenuItem := Events[ I ];
Inc( StartIdx );
end;
end;
//[procedure TMenu.Popup]
function TMenu.Popup(X, Y: Integer): Integer;
{$ifdef wince}
var
OldFlags: DWORD;
{$endif wince}
begin
{$IFDEF GDI}
if Assigned( fOnPopup ) then fOnPopup( @Self );
if not FNotPopup then begin
{$ifdef wince}
OldFlags:=Flags;
Flags:=Flags or $1000;
{$endif wince}
Result := Integer( TrackPopupMenu( FHandle, {$ifdef wince} OldFlags {$else} FPopupFlags {$endif},
X, Y, 0, FControl.Handle, nil ) );
{$ifdef wince}
Flags:=OldFlags;
{$endif wince}
end
else Result := 0;
{$ENDIF GDI}
end;
//[procedure TMenu.PopupEx]
function TMenu.PopupEx( X, Y: Integer ): Integer;
{$IFDEF GDI}
var OldBounds: TRect;
WasVisible: Boolean;
{$ENDIF GDI}
begin
{$IFDEF GDI}
WasVisible := TRUE;
if FControl <> nil then
begin
OldBounds := FControl.BoundsRect;
if not FControl.fIsControl then
begin
WasVisible := FControl.Visible;
if not WasVisible then
FControl.Top := ScreenHeight + 50;
FControl.Show;
end;
end;
// -- by Martin Larsen: -----------------------
FControl.ProcessMessage; // specific for Win9x
Result := Popup( X, Y ); {*ecm}
if FControl <> nil then
begin
if FControl.Top = ScreenHeight + 50 then
begin
if not WasVisible then
FControl.Visible := FALSE;
FControl.BoundsRect := OldBounds;
end;
end;
{$ENDIF GDI}
end;
//[function TMenu.GetItemChecked]
function TMenu.GetItemChecked( Item : Integer ) : Boolean;
begin
Result := Items[ Item ].Checked;
end;
//[procedure TMenu.SetItemChecked]
procedure TMenu.SetItemChecked( Item : Integer; Value : Boolean );
begin
Items[ Item ].Checked := Value;
end;
//[function TMenu.GetMenuItemHandle]
function TMenu.GetMenuItemHandle( Idx : Integer ): DWORD;
begin
Result := Items[ Idx ].FId;
end;
//[procedure TMenu.RadioCheck]
procedure TMenu.RadioCheck( Idx : Integer );
begin
Items[ Idx ].RadioCheckItem;
end;
//[function TMenu.GetItemBitmap]
function TMenu.GetItemBitmap(Idx: Integer): HBitmap;
begin
Result := Items[ Idx ].Bitmap;
end;
//[procedure TMenu.SetItemBitmap]
procedure TMenu.SetItemBitmap(Idx: Integer; const Value: HBitmap);
begin
Items[ Idx ].Bitmap := Value;
end;
//[procedure TMenu.AssignBitmaps]
procedure TMenu.AssignBitmaps(StartIdx: Integer; Bitmaps: array of HBitmap);
var I: Integer;
begin
for I := 0 to High(Bitmaps) do
ItemBitmap[ I + StartIdx ] := Bitmaps[ I ];
end;
//[function TMenu.GetItemText]
function TMenu.GetItemText(Idx: Integer): KOLString;
begin
Result := Items[ Idx ].FCaption;
end;
//[procedure TMenu.SetItemText]
procedure TMenu.SetItemText(Idx: Integer; const Value: KOLString);
begin
Items[ Idx ].Caption := Value;
end;
//[function TMenu.GetItemEnabled]
function TMenu.GetItemEnabled(Idx: Integer): Boolean;
begin
Result := Items[ Idx ].Enabled;
end;
//[procedure TMenu.SetItemEnabled]
procedure TMenu.SetItemEnabled(Idx: Integer; const Value: Boolean);
begin
Items[ Idx ].Enabled := Value;
end;
//[function TMenu.GetItemVisible]
function TMenu.GetItemVisible(Idx: Integer): Boolean;
begin
Result := Items[ Idx ].Visible;
end;
//[procedure TMenu.SetItemVisible]
procedure TMenu.SetItemVisible(Idx: Integer; const Value: Boolean);
begin
Items[ Idx ].Visible := Value;
end;
//[function TMenu.ParentItem]
function TMenu.ParentItem( Idx: Integer ): Integer;
begin
Result := TopParent.IndexOf( Items[ Idx ].FParentMenu );
end;
//[function TMenu.GetItemAccelerator]
function TMenu.GetItemAccelerator(Idx: Integer): TMenuAccelerator;
begin
Result := Items[ Idx ].Accelerator;
end;
//[procedure TMenu.SetItemAccelerator]
procedure TMenu.SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator);
begin
Items[ Idx ].Accelerator := Value;
end;
//[function TMenu.GetItemSubMenu]
function TMenu.GetItemSubMenu( Idx: Integer ): HMenu;
begin
Result := Items[ Idx ].SubMenu;
end;
{$ifdef wince}
procedure TMenu.ReCreate;
var
MII: TMenuItemInfo;
i, j: integer;
begin
if FHandle = 0 then exit;
while RemoveMenu(FHandle, 0, MF_BYPOSITION) do ;
j:=0;
for i:=0 to FItems.Count - 1 do
with PMenu(FItems.Items[i])^ do begin
if FHandle <> 0 then
DestroyMenu(FHandle);
if FItems.Count > 0 then
FHandle:=CreatePopupMenu
else
FHandle:=0;
if Visible then begin
FillChar( MII, Sizeof( MII ), 0 );
MII.cbSize := SizeOf(MII);
MII.fMask := MIIM_CHECKMARKS or MIIM_ID or MIIM_STATE or MIIM_TYPE;
MII.fType := Breaks[ FMenuBreak ];
MII.fState := FSavedState;
MII.wID := FId;
MII.dwItemData := DWORD( FData );
if not FIsSeparator then
begin
MII.fType := MII.fType or MFT_STRING;
MII.dwTypeData := PKOLChar( FCaption );
MII.cch := Length( FCaption );
end
else
MII.fType := MII.fType or MFT_SEPARATOR;
if FRadioGroup <> 0 then
MII.fType := MII.fType or MFT_RADIOCHECK;
if FOwnerDraw then
MII.fType := MII.fType or MFT_OWNERDRAW;
if FBitmap <> 0 then
begin
MII.fMask := MII.fMask or MIIM_CHECKMARKS;
MII.hbmpUnchecked := FBitmap;
end;
if FHandle <> 0 then
begin
MII.fMask := MII.fMask or MIIM_SUBMENU;
MII.hSubMenu := FHandle;
end;
InsertMenuItem( Self.FHandle, j, True, PMenuitemInfo( @ MII )^ );
Inc(j);
end;
if FHandle <> 0 then
ReCreate;
end;
end;
procedure TMenu.SaveState;
var
i: integer;
begin
for i:=0 to FItems.Count - 1 do
with PMenu(FItems.Items[i])^ do begin
GetState(0);
if SubMenu <> 0 then
SaveState;
end;
end;
{$endif wince}
//[function WndProcHelp FORWARD DECLARATION]
function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
forward;
{$IFDEF GDI}
//[procedure TMenu.SetHelpContext]
procedure TMenu.SetHelpContext( Value: Integer );
{$ifdef wince}
begin
{$else}
var Form, C: PControl;
begin
if TopParent <> @ Self then Exit;
// Help context can not be associated with individual menu items
FHelpContext := Value;
C := FControl;
if C = nil then Exit;
Form := C.ParentForm;
Form.AttachProc( WndProcHelp );
SetMenuContextHelpID( FHandle, Value );
{$endif wince}
end;
{$ENDIF GDI}
//[procedure TMenu.SetSubmenu]
procedure TMenu.SetSubmenu( Value: HMenu );
var MII: TMenuItemInfo;
begin
MII.fMask := MIIM_SUBMENU;
MII.hSubMenu := Value;
SetInfo( MII );
FHandle := Value;
end;
//[function WndProcMeasureItem]
function WndProcMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var MIS: PMeasureItemStruct;
M, SM: PMenu;
H, I: Integer;
begin
Result := FALSE;
if (Msg.message = WM_MEASUREITEM) and (Msg.wParam = 0) then
begin
MIS := Pointer( Msg.lParam );
if MIS.CtlType = ODT_MENU then
begin
M := Pointer( Sender.fMenuObj );
while M <> nil do
begin
SM := M.Items[ MIS.itemID ];
if SM <> nil then
begin
Sender.CallDefWndProc( Msg );
I := M.IndexOf( SM );
if Assigned( SM.OnMeasureItem ) then
M := SM;
if not Assigned( M.OnMeasureItem ) then
Exit;
H := M.OnMeasureItem( M, I );
if HiWord( H ) <> 0 then
MIS.itemWidth := HiWord( H );
if LoWord( H ) <> 0 then
MIS.itemHeight := LoWord( H );
Rslt := 1;
Result := TRUE;
break;
end;
M := M.fNextMenu;
end;
end;
end;
end;
//[procedure TMenu.SetOnMeasureItem]
procedure TMenu.SetOnMeasureItem( const Value: TOnMeasureItem );
var C: PControl;
begin
FOnMeasureItem := Value;
C := TopParent.FControl;
if C <> nil then
C.AttachProc( WndProcMeasureItem );
end;
//[function WndProcDrawItem]
function WndProcDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
type PDrawAction = ^TDrawAction;
PDrawState = ^TDrawState;
var DIS: PDrawItemStruct;
M, SM: PMenu;
I: Integer;
begin
Result := FALSE;
if (Msg.message = WM_DRAWITEM) and (Msg.wParam = 0) then
begin
DIS := Pointer( Msg.lParam );
if DIS.CtlType = ODT_MENU then
begin
M := Pointer( Sender.fMenuObj );
while M <> nil do
begin
SM := M.Items[ DIS.itemID ];
if SM <> nil then
begin
I := M.IndexOf( SM );
if Assigned( SM.OnDrawItem ) then
M := SM;
if Assigned( M.OnDrawItem ) then
begin
if not M.OnDrawItem( M, DIS.hDC, DIS.rcItem, I,
PDrawAction( @ DIS.itemAction )^,
PDrawState( @ DIS.itemState )^ ) then Exit;
end
else Exit;
Rslt := 1;
Result := TRUE;
break;
end;
M := M.fNextMenu;
end;
end;
end;
end;
//[procedure TMenu.SetOnDrawItem]
procedure TMenu.SetOnDrawItem( const Value: TOnDrawItem );
var C: PControl;
begin
FOnDrawItem := Value;
C := TopParent.FControl;
if C <> nil then
C.AttachProc( WndProcDrawItem );
end;
//[procedure TMenu.SetOwnerDraw]
procedure TMenu.SetOwnerDraw( Value: Boolean );
const Masks: array[ Boolean ] of DWORD = ( 0, $FFFFFFFF );
var MII: TMenuItemInfo;
begin
FOwnerDraw := Value;
FillChar( MII, Sizeof( MII ), #0 );
MII.fMask := MIIM_TYPE;
MII.dwTypeData := nil;
if GetInfo( MII ) then
begin
MII.fType := MII.fType and not MFT_OWNERDRAW or
(MFT_OWNERDRAW and Masks[ Value ]);
SetTypeInfo( MII );
end;
end;
//[function TMenu.Insert]
function TMenu.Insert(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem;
Options: TMenuOptions): PMenu;
const
MenuStateFlags: array[TMenuOption] of Integer = (MFS_DEFAULT, MFS_DISABLED, MFS_CHECKED, 0, 0,
MFS_DISABLED, 0, 0, 0, 0);
MenuTypeFlags: array[TMenuOption] of Integer = (0, 0, 0, 0, MFT_RADIOCHECK, MFT_SEPARATOR, MFT_BITMAP, 0,
MFT_MENUBREAK, MFT_MENUBARBREAK);
var M: PMenu;
MII: TMenuItemInfo;
begin
{-}
new( Result, Create );
{+}{++}(*Result := PMenu.Create;*){--}
Result.FVisible := TRUE;
Result.FParentMenu := @ Self;
Result.FItems := NewList;
Result.FIsSeparator := moSeparator in Options;
if FHandle = 0 then
SetSubMenu( CreatePopupMenu );
M := nil;
if (InsertBefore >= 0) and (InsertBefore < 4096) then
begin
M := Items[ InsertBefore ];
if M <> nil then
begin
InsertBefore := M.FId;
M.Parent.FItems.Insert( M.Parent.FItems.IndexOf( M ), Result );
end;
end;
if M = nil then
begin
InsertBefore := -1;
FItems.Add( Result );
end;
Result.FOnMenuItem := Event;
FillChar( MII, Sizeof( MII ), #0 );
MII.cbSize := MenuStructSize;
MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
MII.fState := MakeFlags( Pointer( @Options ), MenuStateFlags);
{$ifdef wince}
Result.FSavedState:=MII.fState;
{$endif wince}
MII.fType := MakeFlags( Pointer( @Options ), MenuTypeFlags);
Result.FId := FDynamicMenuID;
Inc( FDynamicMenuID );
MII.wID := Result.FId;
if moSubMenu in Options
then begin
Result.FHandle := CreatePopupMenu;
MII.hSubMenu := Result.FHandle;
end;
MII.dwTypeData := PKOLChar(ACaption);
{$IFNDEF UNICODE_CTRLS}
if not (moBitmap in Options) then MII.cch := StrLen( ACaption );
{$ELSE}
if not (moBitmap in Options) then MII.cch := WStrLen( ACaption );
{$ENDIF}
InsertMenuItem( FHandle, InsertBefore, InsertBefore = -1,
PMenuItemInfo( @ MII )^ );
if moBitmap in Options then
begin
Result.BitmapItem := DWORD( ACaption );
end
else
Result.FCaption := ACaption;
RedrawFormMenuBar;
end;
//[function TMenu.AddItem]
function TMenu.AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;
begin
Result := InsertItem( -1, ACaption, Event, Options );
end;
//[function TMenu.InsertItem]
function TMenu.InsertItem( InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem;
Options: TMenuOptions): Integer;
begin
Result := InsertItemEx( InsertBefore, ACaption, Event, Options, FALSE );
end;
//[function TMenu.InsertItemEx]
function TMenu.InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar;
Event: TOnMenuItem; Options: TMenuOptions; ByPosition: Boolean): Integer;
var M: PMenu;
begin
M := Insert( InsertBefore, ACaption, Event, Options );
Result := M.FId;
end;
//[procedure TMenu.InsertSubMenu]
procedure TMenu.InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer );
var AFlags: DWORD;
M: PMenu;
{$ifndef wince}
MII: TMenuItemInfo;
{$endif wince}
begin
if SubMenuToInsert.FParentMenu <> nil then
SubMenuToInsert := SubMenuToInsert.FParentMenu.RemoveSubMenu( SubMenuToInsert.FId );
if SubMenuToInsert = nil then Exit;
AFlags := MF_BYPOSITION;
M := nil;
if (InsertBefore >= 0) and (InsertBefore < 4096) then
begin
M := Items[ InsertBefore ];
if M = nil then
InsertBefore := -1
else
InsertBefore := M.FId;
end;
if M = nil then
begin
FItems.Add( SubMenuToInsert );
SubMenuToInsert.FParentMenu := @ Self;
end
else
begin
M.FParentMenu.FItems.Insert( M.FParentMenu.FItems.IndexOf( M ), SubMenuToInsert );
SubMenuToInsert.FParentMenu := M.FParentMenu;
end;
if InsertBefore > 0 then
AFlags := MF_BYCOMMAND;
{$ifdef wince}
if FHandle <> 0 then
{$endif wince}
if SubMenuToInsert.FBmpItem <> 0 then
InsertMenu( FHandle, InsertBefore, AFlags or MF_BITMAP or MF_POPUP,
SubMenuToInsert.FHandle, PKOLChar( SubMenuToInsert.FBmpItem ) )
else
InsertMenu( FHandle, InsertBefore, AFlags or MF_STRING or MF_POPUP,
SubMenuToInsert.FHandle, PKOLChar( SubMenuToInsert.Caption ) );
{$ifndef wince}
if SubMenuToInsert.FId = 0 then
begin
SubMenuToInsert.FId := FDynamicMenuID;
Inc( FDynamicMenuID );
MII.cbSize := MenuStructSize;
MII.fMask := MIIM_ID;
MII.wID := SubMenuToInsert.FId;
// {$IFNDEF UNICODE_CTRLS}
SetMenuItemInfo( SubMenuToInsert.FParentMenu.FHandle,
SubMenuToInsert.FParentMenu.FItems.IndexOf( SubMenuToInsert ),
TRUE, {Windows.}PMenuItemInfo( @ MII )^ );
// {$ELSE}
// SetMenuItemInfoW( SubMenuToInsert.FParentMenu.FHandle,
// SubMenuToInsert.FParentMenu.FItems.IndexOf( SubMenuToInsert ),
// TRUE, Windows.PMenuItemInfoW( @ MII )^ );
// {$ENDIF}
end;
{$endif wince}
if (FParentMenu = nil) or (FParentMenu.FParentMenu = nil) then
RedrawFormMenuBar;
end;
//[function TMenu.RemoveSubMenu]
function TMenu.RemoveSubMenu( ItemToRemove: Integer ): PMenu;
{$IFDEF DEBUG_MENU}var OK: Boolean; {$ENDIF}
begin
Result := Items[ ItemToRemove ];
if Result = nil then Exit;
{$ifdef wince}
if Result.FHandle = 0 then
{$endif wince}
if Result.FParentMenu <> nil then
{$IFDEF DEBUG_MENU} OK := {$ENDIF}
RemoveMenu( Result.FParentMenu.FHandle, Result.FId, MF_BYCOMMAND )
else
{$IFDEF DEBUG_MENU} OK := {$ENDIF}
RemoveMenu( FHandle, Result.FId, MF_BYCOMMAND );
{$IFDEF DEBUG_MENU}
if not OK then
ShowMessage( 'Error removing menu: ' + Int2Str( GetLastError ) + ' - ' +
SysErrorMessage( GetLastError ) );
{$ENDIF}
if Count = 0 then
begin
Result.Free;
Result := nil;
end;
{$ifndef wince}
RedrawFormMenuBar;
{$endif wince}
end;
//[function TMenu.GetItemHelpContext]
function TMenu.GetItemHelpContext(Idx: Integer): Integer;
begin
Result := Items[ Idx ].HelpContext;
end;
//[procedure TMenu.SetItemHelpContext]
procedure TMenu.SetItemHelpContext(Idx: Integer; const Value: Integer);
begin
Items[ Idx ].HelpContext := Value;
end;
//[procedure ClearText]
procedure ClearText( Sender: PControl );
begin
Sender.Caption := '';
end;
//[procedure ClearListbox]
procedure ClearListbox( Sender: PControl );
begin
Sender.Perform( LB_RESETCONTENT, 0, 0 );
end;
//[procedure ClearCombobox]
procedure ClearCombobox( Sender: PControl );
begin
Sender.Perform( CB_RESETCONTENT, 0, 0 );
end;
//[procedure ClearListView]
procedure ClearListView( Sender: PControl );
begin
Sender.Perform( LVM_DELETEALLITEMS, 0, 0 );
end;
//[procedure ClearToolbar]
procedure ClearToolbar( Sender: PControl );
begin
while Sender.TBButtonCount > 0 do
Sender.TBDeleteButton( Sender.TBIndex2Item( 0 ) );
Sender.Perform( TB_SETBITMAPSIZE, 0, 0 );
end;
{$ENDIF WIN_GDI}
{ -- Constructor of canvas -- }
//[function NewCanvas]
function NewCanvas( DC: HDC ): PCanvas;
begin
{-}
New( Result, Create );
{+}
{++}(*
Result := PCanvas.Create;
*){--}
{$IFDEF GDI}
Result.ModeCopy := cmSrcCopy;
if DC <> 0 then
begin
Result.SetHandle( DC );
//Result.fIsPaintDC := True; // If Canvas will be destroyed, DC will not be deleted
end;
{$ENDIF GDI}
end;
//[END NewCanvas]
{ -- Contructors of controls -- }
//[FUNCTION _NewTControl]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar; Ctl3D: Boolean ): PControl;
begin
{-}
New( Result, CreateParented( AParent ) );
//Result.fWindowed := TRUE; // is set in TControl.Init
{+}{++}(*Result := PControl.CreateParented( AParent );*){--}
Result.fControlClassName := ControlClassName;
if AParent <> nil then
begin
{$IFDEF WIN_GDI}
Result.fWndProcResizeFlicks := AParent.fWndProcResizeFlicks;
{$ENDIF WIN_GDI}
Result.fGotoControl := AParent.fGotoControl;
Result.fCtl3Dchild := AParent.fCtl3Dchild;
if AParent.fCtl3Dchild then
Result.fCtl3D := Ctl3D
else
Result.fCtl3D := False; //
Result.fMargin := AParent.fMargin;
Result.fTextColor := AParent.fTextColor;
{$IFDEF SMALLEST_CODE}
{$ELSE}
{$IFDEF WIN_GDI} // for now Font is complicated a bit, implement it later
Result.fFont := Result.fFont.Assign( AParent.fFont );
if Result.fFont <> nil then
begin
{$IFDEF USE_AUTOFREE4CONTROLS}
Result.Add2AutoFree( Result.fFont );
{$ENDIF USE_AUTOFREE4CONTROLS}
Result.fFont.fParentGDITool := AParent.fFont;
Result.fFont.fOnChange := Result.FontChanged;
Result.FontChanged( Result.fFont );
end;
{$ENDIF WIN_GDI}
{$ENDIF SMALLEST_CODE}
Result.fColor := AParent.fColor;
{$IFDEF WIN_GDI}
Result.fBrush := Result.fBrush.Assign( AParent.fBrush );
if Result.fBrush <> nil then
begin
{$IFDEF USE_AUTOFREE4CONTROLS}
Result.Add2AutoFree( Result.fBrush );
{$ENDIF USE_AUTOFREE4CONTROLS}
Result.fBrush.fParentGDITool := AParent.fBrush;
Result.fBrush.fOnChange := Result.BrushChanged;
Result.BrushChanged( Result.fBrush );
end;
{$ENDIF WIN_GDI}
end;
end;
//[END _NewWindowed]
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
var GTK_initialized: Boolean;
argc: Integer = 0;
procedure FixedChildSetPos( Ctl, Chld: PControl; x, y: Integer );
begin
gtk_fixed_move( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y );
end;
procedure LayoutChildSetPos( Ctl, Chld: PControl; x, y: Integer );
begin
gtk_layout_move( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y );
end;
procedure FixedChildPut( Ctl, Chld: PControl; x, y: Integer );
begin
gtk_fixed_put( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y );
end;
procedure LayoutChildPut( Ctl, Chld: PControl; x, y: Integer );
begin
gtk_layout_put( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y );
end;
function FixedClientArea( Ctl: PControl ): PGtkWidget;
begin
if Ctl.fClient = nil then
begin
Ctl.fClient := gtk_fixed_new;
gtk_container_set_border_width(GTK_CONTAINER(Ctl.fHandle), 0);
gtk_container_add( GTK_CONTAINER( Ctl.fHandle ), Ctl.fClient );
gtk_container_set_border_width(GTK_CONTAINER(Ctl.fClient), 0);
gtk_widget_show( Ctl.fClient );
Ctl.fChildPut := FixedChildPut;
Ctl.fChildSetPos := FixedChildSetPos;
end;
Result := Ctl.fClient;
end;
function ClientAreaLayout( Ctl: PControl ): PGtkWidget;
begin
if Ctl.fClient = nil then
begin
Ctl.fClient := gtk_layout_new( {hadjustment} nil, {vadjustment} nil );
Ctl.fChildPut := LayoutChildPut;
Ctl.fChildSetPos := LayoutChildSetPos;
end;
Result := Ctl.fClient;
end;
function _NewWindowed( AParent: PControl; ControlClassName: PChar;
widget: PGtkWidget; need_eventbox: Boolean ): PControl;
//var GVal: TGValue;
begin
(*if not GTK_initialized then
begin
GTK_initialized := TRUE;
gtk_init( @ argc, {@ argv} nil );
end;*)
{-}
New( Result, CreateParented( AParent, widget, need_eventbox ) );
//Result.fWindowed := TRUE; // is set in TControl.Init
//???//Result.fControlClassName := ControlClassName;
if AParent <> nil then
begin
Result.fGotoControl := AParent.fGotoControl;
{Result.fCtl3Dchild := AParent.fCtl3Dchild;
if AParent.fCtl3Dchild then
Result.fCtl3D := Ctl3D
else
Result.fCtl3D := False;}
Result.fMargin := AParent.fMargin;
Result.fTextColor := AParent.fTextColor;
{$IFDEF SMALLEST_CODE}
{$ELSE}
{$IFDEF WIN_GDI} // for now Font is complicated a bit, implement it later
Result.fFont := Result.fFont.Assign( AParent.fFont );
if Result.fFont <> nil then
begin
{$IFDEF USE_AUTOFREE4CONTROLS}
Result.Add2AutoFree( Result.fFont );
{$ENDIF USE_AUTOFREE4CONTROLS}
Result.fFont.fParentGDITool := AParent.fFont;
Result.fFont.fOnChange := Result.FontChanged;
Result.FontChanged( Result.fFont );
end;
{$ENDIF WIN_GDI}
{$ENDIF SMALLEST_CODE}
Result.fColor := AParent.fColor;
{$IFDEF WIN_GDI}
Result.fBrush := Result.fBrush.Assign( AParent.fBrush );
if Result.fBrush <> nil then
begin
{$IFDEF USE_AUTOFREE4CONTROLS}
Result.Add2AutoFree( Result.fBrush );
{$ENDIF USE_AUTOFREE4CONTROLS}
Result.fBrush.fParentGDITool := AParent.fBrush;
Result.fBrush.fOnChange := Result.BrushChanged;
Result.BrushChanged( Result.fBrush );
end;
{$ENDIF WIN_GDI}
end;
Result.fGetClientArea := FixedClientArea;
end;
{$ENDIF GTK}
{$ENDIF _X_}
//===================== Form ========================//
{$IFDEF USE_CONSTRUCTORS}
//[function NewForm]
function NewForm( AParent: PControl; const Caption: String ): PControl;
begin
new( Result, CreateForm( AParent, Caption ) );
end;
//[END NewForm]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewForm]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewForm( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := _NewWindowed( AParent, 'Form', True );
{$ifdef wince}
Result.fStyle:=Result.fStyle and not WS_BORDER;
if AParent <> nil then
Result.fStyle:=Result.fStyle or WS_POPUP;
{$endif wince}
Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS;
Result.AttachProc( WndProcForm );
Result.AttachProc( WndProcDoEraseBkgnd );
{$IFNDEF SMALLEST_CODE}
Result.fSizeGrip := TRUE;
{$ENDIF}
Result.Caption := Caption;
Result.fIsForm := TRUE;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function getFormCaption(F: PControl): KOLString;
begin
F.fCaption := gtk_window_get_title( GTK_WINDOW( F.fHandle ) );
Result := F.fCaption;
end;
procedure setFormCaption(F: PControl; const Value: KOLString);
begin
F.fCaption := Value;
gtk_window_set_title( GTK_WINDOW( F.fCaptionHandle ), PChar( String( Value ) ) );
end;
procedure DestroyForm( Widget: PGtkWidget; Sender: PControl ); cdecl;
var Quit: Boolean;
begin
Quit := Sender.IsMainWindow;
Sender.Free;
if Quit then
gtk_main_quit();
end;
function NewForm( AParent: PControl; const Caption: KOLString ): PControl;
{$IFDEF GTK}
var widget: PGtkWidget;
{$ENDIF GTK}
begin
if not GTK_initialized then
begin
GTK_initialized := TRUE;
gtk_init( @ argc, {@ argv} nil );
end;
{$IFDEF GDI}
Result := _NewWindowed( AParent, 'Form', True );
{$ELSE _X_}
{$IFDEF GTK}
widget := gtk_window_new( GTK_WINDOW_TOPLEVEL );
Result := _NewWindowed( AParent, 'Form', widget, FALSE );
{$ENDIF GTK}
{$ENDIF _X_}
Result.fGetCaption := getFormCaption;
Result.fSetCaption := setFormCaption;
Result.Caption := Caption;
Result.fIsForm := TRUE;
gtk_signal_connect( Pointer( Result.fHandle ), 'destroy',
@ DestroyForm, Result );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[END NewForm]
{$ENDIF USE_CONSTRUCTORS}
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
//===================== Applet button ========================//
//[FUNCTION WndProcApp]
{$IFDEF ASM_VERSION}
function WndProcAppAsm(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
asm
CMP word ptr [EDX].TMsg.message, WM_SETFOCUS
JNZ @@chk_CLOSE
MOV ECX, [EAX].TControl.FCurrentControl
JECXZ @@ret_false
XCHG EAX, ECX
PUSH EAX
CALL CallTControlCreateWindow
TEST AL, AL
POP EAX
JZ @@1
PUSH [EAX].TControl.fHandle
CALL SetFocus
@@1: MOV AL, 1
RET
@@chk_CLOSE:
CMP word ptr [EDX].TMsg.message, WM_SYSCOMMAND
JNZ @@ret_false
MOV EDX, dword ptr [EDX].TMsg.wParam
AND DX, $FFF0
CMP DX, SC_CLOSE
JNZ @@ret_false
PUSH ECX
MOV ECX, [EAX].TControl.fChildren
JECXZ @@ret_false1
XCHG EAX, ECX
MOV ECX, [EAX].TList.fCount
JECXZ @@ret_false1
MOV EAX, [EAX].TList.fItems
MOV ECX, dword ptr [EAX]
JECXZ @@ret_false1
XCHG EAX, ECX
PUSH EAX
CALL TControl.IsMainWindow
TEST EAX, EAX
POP EAX
JZ @@ret_false1
CALL TControl.Close
POP ECX
XOR EAX, EAX
MOV dword ptr [ECX], EAX
INC EAX
JMP @@exit
@@ret_false1:
POP ECX
@@ret_false:
XOR EAX, EAX
@@exit:
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcAppPas(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
begin
Result := False;
case Msg.message of
WM_SETFOCUS:
{$IFDEF NEW_MODAL}
if Self_.fModalForm <> nil then
SetFocus( Self_.fModalForm.fHandle )
else if ( Self_.FCurrentControl <> nil ) and not
( Self_.fCurrentControl.IsForm xor Self_.fIsApplet ) then
{$ELSE not_NEW_MODAL}
if Self_.FCurrentControl <> nil then
{$ENDIF NEW_MODAL}
begin
if Self_.FCurrentControl.CreateWindow then
SetFocus( Self_.FCurrentControl.fHandle );
Result := True;
end;
WM_SYSCOMMAND:
CASE Msg.wParam and $FFF0 OF
SC_CLOSE:
if (Self_.fChildren <> nil) and (Self_.fChildren.fCount > 0) and
PControl( Self_.fChildren.fItems[ 0 ] ).IsMainWindow then
begin
PControl( Self_.fChildren.fItems[ 0 ] ).Close;
Rslt := 0;
Result := TRUE;
end;
END;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcApp]
{$IFDEF USE_CONSTRUCTORS}
{$DEFINE CREATEAPPBUTTON_USED}
//[function NewApplet]
function NewApplet( const Caption: String ): PControl;
begin
new( Result, CreateApplet( Caption ) );
end;
//[END NewApplet]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewApplet]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
//[procedure CreateAppButton]
{$ifdef win32}
procedure CreateAppButton( App: PControl );
var M: HMenu;
begin
M := GetSystemMenu( App.fHandle, False );
DeleteMenu( M, SC_MAXIMIZE, MF_BYCOMMAND );
DeleteMenu( M, SC_MOVE, MF_BYCOMMAND );
DeleteMenu( M, SC_SIZE, MF_BYCOMMAND );
EnableMenuItem( M, SC_RESTORE, MF_GRAYED or MF_BYCOMMAND );
end;
{$endif win32}
//[function NewApplet]
function NewApplet( const Caption: KOLString ): PControl;
begin
AppButtonUsed := True;
Result := _NewWindowed( nil, 'App', True );
Result.FIsApplet := TRUE;
{$ifdef wince}
Result.fStyle := WS_VISIBLE;
{$else}
Result.fStyle := DWORD(WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX or WS_CAPTION);
Result.fExStyle := WS_EX_APPWINDOW;
Result.FCreateWndExt := CreateAppButton;
{$endif wince}
{$IFDEF ASM_VERSION}
Result.AttachProc( WndProcAppAsm );
{$ELSE}
Result.AttachProc( WndProcAppPas );
{$ENDIF}
Result.Caption := Caption;
end;
{$ENDIF ASM_VERSION}
//[END NewApplet]
{$ENDIF USE_CONSTRUCTORS}
{$IFDEF CREATEAPPBUTTON_USED}
procedure CreateAppButton( App: PControl );
asm
{$IFDEF F_P}
MOV EAX, [App]
{$ENDIF F_P}
PUSH ESI
PUSH 0
PUSH [EAX].TControl.fHandle
CALL GetSystemMenu
MOV ESI, offset[DeleteMenu]
XCHG ECX, EAX
MOV EAX, SC_MAXIMIZE
CDQ
PUSH EDX
PUSH EAX
PUSH ECX
PUSH EDX
{$IFDEF PARANOIA} DB $2C, $20 {$ELSE} SUB AL, $20 {$ENDIF} // SC_MOVE
PUSH EAX
PUSH ECX
PUSH EDX
{$IFDEF PARANOIA} DB $2C, $10 {$ELSE} SUB AL, $10 {$ENDIF} // SC_SIZE
PUSH EAX
PUSH ECX
PUSH 1 // MF_GRAYED or MF_BYCOMMAND
MOV AX, SC_RESTORE
PUSH EAX
PUSH ECX
CALL EnableMenuItem
CALL ESI
CALL ESI
CALL ESI
POP ESI
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ENDIF CREATEAPPBUTTON_USED}
var CtlIdCount: WORD = $8000;
{-}
{$IFNDEF ASM_VERSION}
//{$DEFINE CREATEPARAMS2_USED}
{$ENDIF}
{$IFDEF USE_CONSTRUCTORS}
//{$DEFINE CREATEPARAMS2_USED}
{$ENDIF}
{+}
{$IFDEF CREATEPARAMS2_USED} // seems not needed more
//[procedure CreateParams2]
procedure CreateParams2( Self_: PControl; var Params: TCreateParams);
begin
Self_.CreateSubclass( Params, Self_.fControlClassName );
end;
{$ENDIF}
{$ENDIF WIN_GDI}
//[FUNCTION _NewControl]
{$IFDEF GDI}
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function _NewControl( AParent: PControl; ControlClassName: PKOLChar;
Style: DWORD; Ctl3D: Boolean; Actions: PCommandActions ): PControl;
var Form: PControl;
begin
Result := _NewWindowed( AParent, ControlClassName, Ctl3D );
if Actions <> nil then
Result.fCommandActions := Actions^;
Result.fIsControl := True;
Result.fStyle := Style or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;
Result.fVerticalAlign := vaTop;
Result.fVisible := (Style and WS_VISIBLE) <> 0;
Result.fTabstop := (Style and WS_TABSTOP) <> 0;
if (AParent <> nil) then
begin
with Result.fBoundsRect do
begin
Left := AParent.fMargin + AParent.fClientLeft;
Top := AParent.fMargin + AParent.fClientTop;
Right := Left + 64;
Bottom := Top + 64;
end;
Inc( AParent.ParentForm.fTabOrder );
Result.fTabOrder := AParent.ParentForm.fTabOrder;
Result.fCursor := AParent.fCursor;
end;
Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];
{$ifdef win32}
if Result.fCtl3D then
begin
Result.fStyle := Result.fStyle and not WS_BORDER;
Result.fExStyle := Result.fExStyle or WS_EX_CLIENTEDGE;
end;
{$endif win32}
if (Style and WS_TABSTOP) <> 0 then
begin
Form := Result.ParentForm;
if Form <> nil then
if Form.FCurrentControl = nil then
Form.FCurrentControl := Result;
end;
Result.fMenu := CtlIdCount;
Inc( CtlIdCount );
Result.AttachProc( WndProcCtrl );
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function getLabelCaption( L: PControl ): KOLString;
begin
L.fCaption := gtk_label_get_text( Pointer( L.fCaptionHandle ) );
Result := L.fCaption;
end;
procedure setLabelCaption( L: PControl; const Value: KOLString );
begin
L.fCaption := Value;
gtk_label_set_text( Pointer( L.fCaptionHandle ), PChar( String( Value ) ) );
end;
function _NewControl( AParent: PControl; ControlClassName: PChar;
Style: DWORD; Ctl3D: Boolean; widget: PGtkWidget; need_eventbox: Boolean ): PControl;
var Rect: TRect;
begin
Result := _NewWindowed( AParent, ControlClassName, widget, need_eventbox );
Result.fIsControl := True;
Result.fVerticalAlign := vaTop;
Result.{todo: remove f}fVisible := (Style and WS_VISIBLE) <> 0;
Result.fTabstop := (Style and WS_TABSTOP) <> 0;
if (AParent <> nil) then
begin
with Rect do
begin
Left := AParent.fMargin + AParent.fClientLeft;
Top := AParent.fMargin + AParent.fClientTop;
end;
Inc( AParent.ParentForm.fTabOrder );
Result.fTabOrder := AParent.ParentForm.fTabOrder;
{$IFDEF GDI}
Result.fCursor := AParent.fCursor;
{$ENDIF GDI}
//gtk_container_add( GTK_CONTAINER( AParent.fHandle ), Result.fHandle );
end;
{with Rect do
begin
Right := Left + 64;
Bottom := Top + 64;
end;
Result.fBoundsRect := Result.BoundsRect;
Result.BoundsRect := Rect;}
Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];
{$IFDEF GDI}
if Result.fCtl3D then
begin
Result.fStyle := Result.fStyle and not WS_BORDER;
Result.fExStyle := Result.fExStyle or WS_EX_CLIENTEDGE;
end;
if (Style and WS_TABSTOP) <> 0 then
begin
Form := Result.ParentForm;
if Form <> nil then
if Form.FCurrentControl = nil then
Form.FCurrentControl := Result;
end;
Result.fMenu := CtlIdCount;
Inc( CtlIdCount );
Result.AttachProc( WndProcCtrl );
{$ENDIF GDI}
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[END _NewControl]
{$IFDEF WIN_GDI}
//===================== Button ========================//
//[function TControl.SetButtonIcon]
function TControl.SetButtonIcon(aIcon: HIcon): PControl;
var PrevImg: THandle;
begin
Style := Style or BS_ICON;
fButtonIcon := aIcon;
PrevImg := Perform( BM_SETIMAGE, IMAGE_ICON, aIcon );
if PrevImg <> 0 then
DeleteObject( PrevImg );
Result := @ Self;
end;
//[function TControl.SetButtonBitmap]
function TControl.SetButtonBitmap(aBmp: HBitmap): PControl;
var PrevImg: THandle;
begin
Style := Style or BS_BITMAP;
PrevImg := Perform( BM_SETIMAGE, IMAGE_BITMAP, aBmp );
if PrevImg <> 0 then
DeleteObject( PrevImg );
Result := @ Self;
end;
{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
//[function WndProcBtnReturnClick]
function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or
(Msg.message = WM_CHAR)) and (Msg.wParam = 13) then
Msg.wParam := 32;
end;
{$ENDIF}
{$IFNDEF BUTTON_DBLCLICK}
//[function WndProcBtnDblClkAsClk]
function WndProcBtnDblClkAsClk( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
if Msg.message = WM_LBUTTONDBLCLK then
Msg.message := WM_LBUTTONDOWN;
end;
{$ENDIF}
{$ifdef wince}
function WndProcBtnFocus( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
case Msg.message of
WM_SETFOCUS:
Sender.Style:=Sender.Style or BS_DEFPUSHBUTTON;
WM_KILLFOCUS:
Sender.Style:=Sender.Style and not BS_DEFPUSHBUTTON;
end;
end;
{$endif wince}
//[function AutoMinimizeApplet]
function AutoMinimizeApplet(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
begin
if (msg.Message=WM_SYSCOMMAND) and ((msg.wParam and not 15)=SC_MINIMIZE) then begin
AppletMinimize;
Result := True;
end else
Result := False;
end;
{$IFDEF USE_CONSTRUCTORS}
//[function NewButton]
function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
begin
new( Result, CreateButton( AParent, Caption ) );
end;
{$ELSE USE_CONSTRUCTORS}
{$IFDEF ASM_VERSION}
const ButtonClass: array[ 0..6 ] of KOLChar = ( 'B','U','T','T','O','N',#0 );
{$ENDIF ASM_VERSION}
//[FUNCTION NewButton]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := _NewControl( AParent, 'BUTTON',
WS_VISIBLE or WS_CHILD or BS_NOTIFY or
BS_PUSHLIKE or WS_TABSTOP, False, @ButtonActions );
{$ifdef wince}
Result.fColor:=clBtnFace;
if Result.fBrush <> nil then
Result.fBrush.fData.Color:=Result.fColor;
{$endif wince}
{$IFDEF BUTTON_DBLCLICK}
Result.ClsStyle := Result.ClsStyle - CS_DBLCLKS;
{$ENDIF}
Result.fIgnoreDefault := TRUE;
//Result.fCtl3D := TRUE;
with Result.fBoundsRect do
Bottom := Top + 22;
Result.fTextAlign := taCenter;
Result.Caption := Caption;
Result.fIsButton := TRUE;
{$IFNDEF SMALLEST_CODE}
{$IFNDEF BUTTON_DBLCLICK}
Result.AttachProc( WndProcBtnDblClkAsClk );
{$ENDIF}
{$ENDIF}
{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
Result.AttachProc( WndProcBtnReturnClick );
{$ENDIF}
{$ifdef wince}
Result.AttachProc(WndProcBtnFocus);
{$endif wince}
{$IFDEF GRAPHCTL_XPSTYLES}
Result.fClassicTransparent := Result.fTransparent;
Attach_WM_THEMECHANGED(Result);
XP_Themes_For_BitBtn(Result);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END NewButton]
{$ENDIF USE_CONSTRUCTORS}
{$ENDIF WIN_GDI}
{$IFDEF _X_}
{$IFDEF GTK}
const
HorAlignments: array[ TTextAlign ] of Single = ( {taLeft} 0, {taRight} 1, {taCenter} 0.5 );
VerAlignments: array[ TVerticalAlign ] of Single = ( {vaCenter} 0.5, {vaTop} 0, {vaBottom} 1 );
procedure ButtonSetTextAlign( Self_: PControl );
begin
gtk_button_set_alignment( GTK_BUTTON( Self_.fHandle ), HorAlignments[ Self_.fTextAlign ],
VerAlignments[ Self_.fVerticalAlign ] );
end;
function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := _NewControl( AParent, 'BUTTON',
WS_VISIBLE or WS_CHILD or BS_NOTIFY or
BS_PUSHLIKE or WS_TABSTOP, False,
gtk_button_new{_with_label}( {PChar( String( Caption ) )} ), FALSE );
//Result.Height := 22;
gtk_container_set_border_width( GTK_CONTAINER( Result.fHandle ), 0 );
Result.fCaptionHandle := gtk_label_new( PChar( String( Caption ) ) );
gtk_container_add( GTK_CONTAINER( Result.fHandle ), Result.fCaptionHandle );
//gtk_container_set_border_width( GTK_CONTAINER( Result.fCaptionHandle ), 0 );
gtk_widget_show( Result.fCaptionHandle );
Result.fGetCaption := getLabelCaption;
Result.fSetCaption := setLabelCaption;
//Result.fIgnoreDefault := TRUE;
//Result.fCtl3D := TRUE;
//with Result.fBoundsRect do
// Bottom := Top + 22;
Result.fTextAlign := taCenter;
Result.fCaption := Caption;
Result.fIsButton := TRUE;
Result.fSetTextAlign := ButtonSetTextAlign;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//----------------- BitBtn -----------------------
//[FUNCTION WndProc_DrawItem]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
var DI: PDrawItemStruct;
Control: PControl;
begin
Result := FALSE;
if Msg.message = WM_DRAWITEM then
begin
DI := Pointer( Msg.lParam );
{$IFDEF USE_PROP}
Control := Pointer( GetProp( DI.hwndItem, ID_SELF ) );
{$ELSE}
Control := Pointer( GetWindowLong( DI.hwndItem, GWL_USERDATA ) );
{$ENDIF}
if Control <> nil then
begin
Rslt := Control.Perform( CN_DRAWITEM, Msg.wParam, Msg.lParam );
Result := TRUE;
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProc_DrawItem]
//[function ExcludeAmpersands]
function ExcludeAmpersands( Self_: PControl; const S: String ): String;
var I: Integer;
begin
Result := S;
if not Self_.FBitBtnDrawMnemonic then Exit;
for I := Length( Result ) downto 1 do
begin
if Result[ I ] = '&' then
Delete( Result, I, 1 );
end;
end;
//[procedure BitBtnExtDraw]
procedure BitBtnExtDraw( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect;
const CapText, CapTxtOrig: KOLString; Color: TColor );
var I, J, W, H: Integer;
Sz: TSize;
Pen, OldPen: HPen;
begin
if not Self_.FBitBtnDrawMnemonic then Exit;
J := 0;
for I := 1 to Length( CapTxtOrig ) do
begin
if CapTxtOrig[ I ] <> '&' then
Inc( J )
else
begin
GetTextExtentPoint32( DC, PKOLChar( CapText ), J, Sz );
W := Sz.cx;
Windows.GetTextExtentPoint32( DC, '_', 1, Sz );
H := Sz.cy - 1;
Windows.GetTextExtentPoint32( DC, @ CapTxtOrig[ I + 1 ], 1, Sz );
Windows.MoveToEx( DC, X + W, Y + H, nil );
Pen := CreatePen( PS_SOLID, 0, Color2RGB( Color ) );
OldPen := SelectObject( DC, Pen );
Windows.LineTo( DC, X + W + Sz.cx, Y + H );
SelectObject( DC, OldPen );
DeleteObject( Pen );
end;
end;
end;
//[procedure TControl.SetBitBtnDrawMnemonic]
procedure TControl.SetBitBtnDrawMnemonic(const Value: Boolean);
begin
FBitBtnDrawMnemonic := Value;
FBitBtnGetCaption := ExcludeAmpersands;
FBitBtnExtDraw := BitBtnExtDraw;
Invalidate;
end;
//[function TControl.GetBitBtnImgIdx]
function TControl.GetBitBtnImgIdx: Integer;
begin
Result := LoWord( fGlyphCount );
end;
//[procedure TControl.SetBitBtnImgIdx]
procedure TControl.SetBitBtnImgIdx(const Value: Integer);
begin
if not( bboImageList in fBitBtnOptions ) then Exit;
fGlyphCount := HiWord( fGlyphCount ) or (Value and $FFFF);
Invalidate;
end;
//[function TControl.GetBitBtnImageList]
function TControl.GetBitBtnImageList: THandle;
begin
Result := 0;
if bboImageList in fBitBtnOptions then
Result := fGlyphBitmap;
end;
//[procedure TControl.SetBitBtnImageList]
procedure TControl.SetBitBtnImageList(const Value: THandle);
begin
fGlyphBitmap := Value;
if Value <> 0 then
begin
fBitBtnOptions := fBitBtnOptions + [ bboImageList ];
ImageList_GetIconSize( Value, fGlyphWidth, fGlyphHeight );
end
else
fBitBtnOptions := fBitBtnOptions - [ bboImageList ];
Invalidate;
end;
//[FUNCTION WndProcBitBtn]
{$IFDEF ASM_noVERSION} // remove &-s from view //+ TextShift & if Y < 0 then Y := 0; // + glyph + TextShift if not glyphOver
// timer when RepeatInterval set
function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
const szBitmapInfo = sizeof(TBitmapInfo);
asm
CMP word ptr [EDX].TMsg.message, WM_LBUTTONDBLCLK
JNZ @@noWM_LBUTTONDBLCLK
PUSH ECX
PUSH [EDX].TMsg.wParam
PUSH [EDX].TMsg.lParam
PUSH WM_LBUTTONDOWN
PUSH EAX
CALL TControl.Perform
POP ECX
MOV [ECX], EAX
MOV AL, 1
RET
@@noWM_LBUTTONDBLCLK:
PUSH EBX
CMP [EDX].TMsg.message, CN_DRAWITEM
JNZ @@noCN_DRAWITEM
PUSH EDI
PUSH ESI
XCHG EDI, EAX // EDI = @Self
MOV dword ptr [ECX], 1
MOV ESI, [EDX].TMsg.lParam // ESI = DIS
XOR EBX, EBX // G = 0
MOV EAX, [ESI].TDrawItemStruct.itemState
TEST byte ptr [EDI].TControl.fBitBtnOptions, 8 //1 shl Ord(bboFixed)
JNZ @@fixed_in_options
{$IFDEF PARANOIA} DB $A8, ODS_SELECTED {$ELSE} TEST AL, ODS_SELECTED {$ENDIF}
JZ @@not1
JMP @@1
@@fixed_in_options:
TEST byte ptr [EDI].TControl.fChecked, 1
JZ @@not1
@@1: INC EBX
@@not1:
{$IFDEF PARANOIA} DB $A8, ODS_DISABLED {$ELSE} TEST AL, ODS_DISABLED {$ENDIF}
JZ @@not2
MOV BL, 2
@@not2: TEST EBX, EBX
JNZ @@not3
{$IFDEF PARANOIA} DB $A8, ODS_FOCUS {$ELSE} TEST AL, ODS_FOCUS {$ENDIF}
JZ @@not3
MOV BL, 3
@@not3: CMP [EDI].TControl.fMouseInControl, BH
JZ @@not4
TEST EBX, EBX
JZ @@4
CMP BL, 3
JNZ @@not4
@@4: MOV BL, 4
@@not4: MOV ECX, [EDI].TControl.fOnBitBtnDraw.TMethod.Code
TEST ECX, ECX
JZ @@noOnBitBtnDraw
//JECXZ @@noOnBitBtnDraw
MOV EAX, [EDI].TControl.fCanvas
PUSH EAX
TEST EAX, EAX
JZ @@noCanvas
MOV EDX, [ESI].TDrawItemStruct.hDC
CALL TCanvas.SetHandle
@@noCanvas:
MOV EAX, [EDI].TControl.fOnBitBtnDraw.TMethod.Data
MOV EDX, EDI
PUSH EBX
XCHG ECX, EBX
CALL EBX
POP EBX
POP ECX // Canvas
PUSH EAX
JECXZ @@noCanvas2
XCHG EAX, ECX
XOR EDX, EDX
CALL TCanvas.SetHandle
@@noCanvas2:
POP EAX
TEST AL, AL
JNZ @@exit_draw
@@noOnBitBtnDraw:
TEST byte ptr [EDI].TControl.fBitBtnOptions, 2 //1 shl Ord(bboNoBorder)
JNZ @@noborder
TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS
JZ @@noDefaultBorder
PUSH {BLACK_BRUSH} DKGRAY_BRUSH
CALL GetStockObject
LEA EDX, [ESI].TDrawItemStruct.rcItem
OR ECX, -1
PUSH ECX
PUSH ECX
PUSH EDX
PUSH EAX
PUSH EDX
PUSH [ESI].TDrawItemStruct.hDC
CALL Windows.FrameRect
CALL InflateRect
XOR ECX, ECX
JMP @@noFlat
@@noDefaultBorder:
MOVZX ECX, [EDI].TControl.fFlat
JECXZ @@noFlat
AND CL, [EDI].TControl.fMouseInControl
JZ @@noborder
@@noFlat:
TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_SELECTED
MOV CL, {BDR_SUNKENOUTER or} BDR_SUNKENINNER
JNZ @@border_sunken
MOV CL, {BDR_RAISEDOUTER or} BDR_RAISEDINNER
@@border_sunken:
LEA EDX, [ESI].TDrawItemStruct.rcItem
OR EAX, -1
PUSH EAX
PUSH EAX
PUSH EDX
PUSH BF_ADJUST or BF_RECT
PUSH ECX
PUSH EDX
PUSH [ESI].TDrawItemStruct.hDC
CALL DrawEdge
CALL InflateRect
@@noborder:
PUSH [ESI].TDrawItemStruct.rcItem.Bottom
PUSH [ESI].TDrawItemStruct.rcItem.Right
PUSH [ESI].TDrawItemStruct.rcItem.Top
PUSH [ESI].TDrawItemStruct.rcItem.Left
MOV EAX, [EDI].TControl.fGlyphWidth
MOV EDX, [EDI].TControl.fGlyphHeight
TEST EAX, EAX
JLE @@noglyph
TEST EDX, EDX
JLE @@noglyph
PUSH EBP
MOV EBP, ESP
PUSH EDX // ImgH -> [EBP-4]
PUSH EAX // ImgW -> [EBP-8]
PUSH EDX // OutH -> [EBP-12]
PUSH EAX // OutW -> [EBP-16]
MOV EAX, [ESI].TDrawItemStruct.rcItem.Left // X = DIS.rcItem.Left
MOV EDX, [ESI].TDrawItemStruct.rcItem.Top // Y = DIS.rcItem.Top
MOV ECX, [ESI].TDrawItemStruct.rcItem.Bottom
SUB ECX, EDX
PUSH ECX // H -> [EBP-20]
MOV ECX, [ESI].TDrawItemStruct.rcItem.Right
SUB ECX, EAX
PUSH ECX // W -> [EBP-24]
MOVZX ECX, [EDI].TControl.fGlyphLayout
PUSH EBX
INC ECX
LOOP @@noGlyphLeft
MOV EBX, EAX // X
ADD EBX, [EBP-16] // +OutW
MOV [EBP+4].TRect.Left, EBX // TxRect.Left = X+OutW
JMP @@centerY
@@noGlyphLeft:
LOOP @@noGlyphTop
MOV EBX, EDX // Y
ADD EBX, [EBP-12] // +OutH
MOV [EBP+4].TRect.Top, EBX // TxRect.Top = Y+OutH
LOOP @@centerX // always JMP, ECX := -1
@@noGlyphTop:
LOOP @@noGlyphRight
MOV EAX, [ESI].TDrawItemStruct.rcItem.Right
SUB EAX, [EBP-16] // -OutW -> X
MOV [EBP+4].TRect.Right, EAX
@@centerY:
MOV EBX, [EBP-20] // H
SUB EBX, [EBP-12] // -OutH
JLE @@noGlyphRight
SAR EBX, 1
ADD EDX, EBX // Y = Y + (H-OutH)/2
@@noGlyphRight:
LOOP @@noGlyphBottom
MOV EDX, [ESI].TDrawItemStruct.rcItem.Bottom
SUB EDX, [EBP-12] // -OutH -> Y
MOV [EBP+4].TRect.Bottom, EDX
LOOP @@centerX // always JMP, ECX := -1
@@noGlyphBottom:
LOOP @@noGlyphOver
@@centerX:
MOV EBX, [EBP-24] // W
SUB EBX, [EBP-16] // -OutW
SHR EBX, 1 // /2
ADD EAX, EBX // +EAX, X = X + (W-OutW)/2
JECXZ @@centerY
@@noGlyphOver:
MOV ECX, [ESI].TDrawItemStruct.rcItem.Left
CMP EAX, ECX
JGE @@ok1
XCHG EAX, ECX
@@ok1: CMP EDX, [ESI].TDrawItemStruct.rcItem.Top
{$IFDEF USE_CMOV}
CMOVL EDX, [ESI].TDrawItemStruct.rcItem.Top
{$ELSE}
JGE @@ok2
MOV EDX, [ESI].TDrawItemStruct.rcItem.Top
@@ok2: {$ENDIF}
MOV ECX, [ESI].TDrawItemStruct.rcItem.Right
SUB ECX, EAX
CMP [EBP-16], ECX
JLE @@ok3
MOV [EBP-16], ECX // OutW := rcItem.Right - X;
@@ok3: MOV ECX, [ESI].TDrawItemStruct.rcItem.Bottom
SUB ECX, EDX
CMP ECX, [EBP-12]
JGE @@ok4
MOV [EBP-12], ECX // OutH := rcItem.Bottom - Y;
@@ok4:
POP EBX // EBX = G
TEST byte ptr [EDI].TControl.fBitBtnOptions, 1 //1 shl Ord(bboImageList)
JZ @@draw_bitmap
MOVZX ECX, word ptr [EDI].TControl.fGlyphCount
CMP word ptr [EDI].TControl.fGlyphCount + 2, BX
JLE @@no_add_glyphIdx
ADD ECX, EBX
@@no_add_glyphIdx:
XOR EBX, EBX
PUSH ILD_TRANSPARENT // Flags = 1 (ILD_TRANSPARENT)
PUSH EBX // Blend = 0
PUSH -1 // Bk = CLR_NONE
PUSH EBX // 0
PUSH EBX // 0
PUSH EDX
PUSH EAX
PUSH [ESI].TDrawItemStruct.hDC
PUSH ECX
PUSH [EDI].TControl.fGlyphBitmap
CMP [EDI].TControl.fTransparent, BL
JNZ @@imgl_transp
MOV EAX, [EDI].TControl.fColor
CALL Color2RGB
MOV [ESP+32], EAX // Bk = Color2RGB(fColor)
MOV [ESP+40], EBX // Flags = 0
@@imgl_transp:
INC EBX
CMP word ptr [EDI].TControl.fGlyphCount + 2, BX
JNZ @@draw_imagelist
DEC byte ptr [ESP+36+3] // $FF, CLR_DEFAULT = $FF000000
TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS
JZ @@draw_imagelist
OR byte ptr [ESP+40], ILD_BLEND25 // Flags != 2
@@draw_imagelist:
CALL ImageList_DrawEx
JMP @@glyph_drawn
@@draw_bitmap:
PUSH EAX // PlaceHold for DC
PUSH EAX // PlaceHold for OldBmp
PUSH SRCCOPY
PUSH dword ptr [EBP-4] // ImgH
PUSH dword ptr [EBP-8] // ImgW
PUSH 0
PUSH EAX // PlaceHold for I
PUSH EAX // PlaceHold for DC
PUSH dword ptr [EBP-12] // OutH
PUSH dword ptr [EBP-16] // OutW
PUSH EDX // Y
PUSH EAX // X
PUSH [ESI].TDrawItemStruct.hDC
PUSH 0
CALL CreateCompatibleDC
MOV [ESP+48], EAX // save DC
MOV [ESP+20], EAX // place DC
PUSH [EDI].TControl.fGlyphBitmap
PUSH EAX
CALL SelectObject
MOV [ESP+44], EAX // save OldBitmap
XOR EAX, EAX
CMP [EDI].TControl.fGlyphCount, EBX
JLE @@no_incGlyIdx
MOV EAX, [EBP-8] // ImgW
IMUL EBX
@@no_incGlyIdx:
MOV [ESP+24], EAX // place I
CALL StretchBlt
CALL FinishDC
@@glyph_drawn:
MOV ESP, EBP
POP EBP
@@noglyph:
TEST byte ptr[EDI].TControl.fBitBtnOptions, 4 //1 shl Ord(bboNoCaption)
JNZ @@noCaption
POP EAX
PUSH EAX
MOV EDX, [ESP].TRect.Right
CMP EDX, EAX
JLE @@noCaption
MOV EDX, [ESP].TRect.Bottom
CMP EDX, [ESP].TRect.Top
JLE @@noCaption
XOR EBX, EBX
PUSH EBX // > CapText
MOV EDX, ESP
MOV EAX, EDI
CALL TControl.GetCaption
PUSH EBX // > Bk
PUSH EBX // > Blend
CMP [EDI].TControl.fTransparent, BL
MOV BL, ETO_CLIPPED
JNZ @@drwTxTransparent
CMP [EDI].TControl.fGlyphLayout, glyphOver
JNZ @@drwTxOpaque
@@drwTxTransparent:
PUSH TRANSPARENT
PUSH [ESI].TDrawItemStruct.hDC
CALL SetBkMode
MOV [ESP+4], EAX // Bk := SetBkMode( DIS.hDC, TRANSPARENT )
JMP @@drwTx1
@@drwTxOpaque:
MOV BL, ETO_CLIPPED or ETO_OPAQUE
MOV EAX, [EDI].TControl.fColor
CALL Color2RGB
PUSH EAX
PUSH [ESI].TDrawItemStruct.hDC
CALL SetBkColor
POP ECX
PUSH EAX // Blend := SetBkColor(DIS.hDC,fColor)
@@drwTx1:
PUSH 0 // > OldFont
PUSH 0 // > OldTextColor
PUSH 0 // push
MOV EDX, [ESP+20] // CapText
CALL EDX2PChar
PUSH dword ptr [EDX-4] // push Length(CapText)
PUSH EDX // push PChar(CapText)
LEA EAX, [ESP+32]
PUSH EAX // push @TxRect
PUSH EBX // push Flags
MOV EBX, [ESI].TDrawItemStruct.hDC
MOV ECX, [EDI].TControl.fFont
JECXZ @@drwTx_noFont
XCHG EAX, ECX
CALL TGraphicTool.GetHandle
PUSH EAX
PUSH EBX
CALL SelectObject
MOV [ESP+24], EAX // OldFont := SelectObject...
@@drwTx_noFont:
MOV EAX, [EDI].TControl.fTextColor
CALL Color2RGB
PUSH EAX
PUSH EBX
CALL SetTextColor
MOV [ESP+20], EAX // OldTextColor := SetTextColor...
PUSH EAX
PUSH EAX
PUSH ESP
MOV ECX, [ESP+48] // ECX = CapText
XOR EAX, EAX
JECXZ @@drwTx0
MOV EAX, [ECX-4] // EAX = Length(CapText)
@@drwTx0:
PUSH EAX
PUSH ECX
PUSH EBX
CALL GetTextExtentPoint32
POP ECX // ECX = TextSz.cx
POP EDX // EDX = TextSz.cy
MOV EAX, [ESP+40].TRect.Bottom
SUB EAX, [ESP+40].TRect.Top
SUB EAX, EDX
JGE @@yOk
XOR EAX, EAX
@@yOk: SHR EAX, 1
ADD EAX, [ESP+40].TRect.Top
PUSH EAX // push Y
MOV EDX, [ESP+44].TRect.Right
MOV EAX, [ESP+44].TRect.Left // EAX = TxRect.Left
SUB EDX, EAX // EDX = W
PUSH EAX
CMP [EDI].TControl.fTextAlign, taRight
JL @@chk_X
JE @@alignR
SUB ECX, EDX
SAR ECX, 1
JMP @@alignC
@@alignR:
ADD EAX, EDX
@@alignC:
SUB EAX, ECX
@@chk_X:POP EDX
CMP EAX, EDX
JGE @@xOk
XCHG EAX, EDX
@@xOk: PUSH EAX // push X
PUSH EBX // push hDC
CALL ExtTextOut
PUSH EBX
CALL SetTextColor
POP ECX
JECXZ @@noRestoreFont
PUSH ECX
PUSH EBX
CALL SelectObject
@@noRestoreFont:
POP ECX // Blend
JECXZ @@restoreBk
PUSH ECX
PUSH EBX
CALL SetBkColor
POP ECX
JMP @@delCaption
@@restoreBk:
PUSH EBX
CALL SetBkMode
@@delCaption:
CALL RemoveStr
@@noCaption:
ADD ESP, 16
@@exit_draw:
POP ESI
POP EDI
POP EBX
MOV AL, 1
RET
@@noCN_DRAWITEM:
CMP word ptr [EDX].TMsg.message, WM_LBUTTONDOWN
JZ @@doDown
CMP word ptr [EDX].TMsg.message, WM_KEYDOWN
JNZ @@noWM_LBUTTONDOWN
CMP [EDX].TMsg.wParam, 32
JNZ @@noWM_LBUTTONDOWN
@@doDown:
PUSH EDX
XCHG EBX, EAX
CALL @@fixed_proc
MOV ECX, [EBX].TControl.fRepeatInterval
JECXZ @@exit_LBUTTONDOWN
POP EDX
PUSH EDX
CMP word ptr [EDX].TMsg.message, WM_KEYDOWN
JZ @@not_SetTimer
PUSH 0
PUSH [EBX].TControl.fRepeatInterval
PUSH 1
PUSH [EBX].TControl.fHandle
CALL SetTimer
@@exit_LBUTTONDOWN:
@@not_SetTimer:
POP EDX
JMP @@invalidate
@@noWM_LBUTTONDOWN:
CMP word ptr [EDX].TMsg.message, WM_TIMER
JNZ @@noWM_TIMER
XCHG EBX, EAX
PUSH 0
PUSH 0
PUSH BM_GETSTATE
PUSH EBX
CALL TControl.Perform
{$IFDEF PARANOIA} DB $A8, 4 {$ELSE} TEST AL, BST_PUSHED {$ENDIF}
JNZ @@pushed
PUSH 1
PUSH [EBX].TControl.fHandle
CALL KillTimer
CALL ReleaseCapture
JMP @@noWM_TIMER
@@fixed_proc:
TEST byte ptr [EBX].TControl.fBitBtnOptions, 8 // bboFixed
JZ @@not_fixed
XOR [EBX].TControl.fChecked, 1
MOV ECX, [EBX].TControl.fOnChange.TMethod.Code
JECXZ @@not_fixed
MOV EAX, [EBX].TControl.fOnChange.TMethod.Data
MOV EDX, EBX
JMP ECX
@@pushed:
CALL @@fixed_proc
MOV EAX, EBX
CALL TControl.DoClick
@@invalidate:
XCHG EAX, EBX
CALL TControl.Invalidate
@@noWM_TIMER:
XOR EAX, EAX
POP EBX
@@not_fixed:
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var DIS: PDrawItemStruct;
IsDown, IsDefault, IsDisabled: Boolean;
Flags: Integer;
X, Y, W, H, ImgW, ImgH, OutW, OutH, I, G, Bk, Blend: Integer;
TxRect, FocusRect: TRect;
OldFont: HFont;
OldTextColor: TColor;
CapText, CapTxtOrig: KOLString;
TextSz: TSize;
DC: HDC;
OldBmp: HBitmap;
Handled: Boolean;
begin
Result := False;
if (Msg.message = WM_LBUTTONDBLCLK) then
begin
Rslt := Self_.Perform( WM_LBUTTONDOWN, Msg.wParam, Msg.lParam );
Result := True;
Exit;
end;
if (Msg.message = CN_DRAWITEM) then
begin
Result := True;
Rslt := 1;
DIS := Pointer( Msg.lParam );
IsDown := (DIS.itemState and ODS_SELECTED <> 0) or Self_.fChecked;
IsDefault := DIS.itemState and ODS_FOCUS <> 0;
IsDisabled := DIS.itemState and ODS_DISABLED <> 0;
G := 0;
if IsDown then G := {$IFDEF BITBTN_DISABLEDGLYPH2} 1 {$ELSE} 2 {$ENDIF};
if IsDisabled then G := {$IFDEF BITBTN_DISABLEDGLYPH2} 2 {$ELSE} 1 {$ENDIF};
if (G = 0) and IsDefault then G := 3;
if ((G = 0) or (G = 3)) and Self_.MouseInControl then G := 4;
if Assigned( Self_.fOnBitBtnDraw ) then
begin
if Assigned( Self_.fCanvas ) then
Self_.fCanvas.SetHandle( DIS.hDC );
Handled := Self_.fOnBitBtnDraw( Self_, G );
if Assigned( Self_.fCanvas ) then
Self_.fCanvas.SetHandle( 0 );
if Handled then Exit;
end;
if not ( bboNoBorder in Self_.fBitBtnOptions ) then
begin
if IsDefault and not( bboFocusRect in Self_.fBitBtnOptions ) then
begin
{$ifdef wince}
CeFrameRect( DIS.hDC, DIS.rcItem, clGray );
{$else}
Windows.FrameRect( DIS.hDC, DIS.rcItem, GetStockObject( {BLACK_BRUSH} DKGRAY_BRUSH ) );
{$endif wince}
InflateRect( DIS.rcItem, -1, -1 );
end;
if Self_.fFlat then
begin
if IsDown then
Flags := BDR_RAISEDINNER
else
Flags := 0; //EDGE_ETCHED;
DrawEdge( DIS.hDC, DIS.rcItem, Flags, BF_FLAT or BF_RECT );
//InflateRect( DIS.rcItem, -1, -1 );
end;
if not Self_.fFlat or Self_.fMouseInControl or IsDefault then
begin
if IsDown then
Flags := BDR_SUNKENOUTER or BDR_SUNKENINNER
else
Flags := BDR_RAISEDOUTER or BDR_RAISEDINNER;
DrawEdge( DIS.hDC, DIS.rcItem, Flags, BF_ADJUST or BF_RECT );
InflateRect( DIS.rcItem, -1, -1 );
end;
end;
TxRect := DIS.rcItem;
if Self_.fGlyphBitmap <> 0 then
begin
ImgW := Self_.fGlyphWidth;
ImgH := Self_.fGlyphHeight;
if (ImgW > 0) and (ImgH > 0) then
begin
OutW := ImgW;
OutH := ImgH;
W := DIS.rcItem.Right - DIS.rcItem.Left;
H := DIS.rcItem.Bottom - DIS.rcItem.Top;
X := DIS.rcItem.Left;
Y := DIS.rcItem.Top;
if isDown and (Self_.fGlyphLayout <> glyphOver) then
begin
Inc( X, Self_.TextShiftX );
Inc( Y, Self_.TextShiftY );
end;
case Self_.fGlyphLayout of
glyphLeft:
begin
Y := Y + (H - OutH) div 2;
TxRect.Left := X + OutW;
end;
glyphTop:
begin
X := X + (W - OutW) div 2;
TxRect.Top := Y + OutH;
end;
glyphRight:
begin
X := DIS.rcItem.Right - OutW;
TxRect.Right := X;
Y := Y + (H - OutH) div 2;
end;
glyphBottom:
begin
Y := DIS.rcItem.Bottom - OutH;
TxRect.Bottom := Y;
X := X + (W - OutW) div 2;
end;
glyphOver:
begin
X := X + (W - OutW) div 2;
Y := Y + (H - OutH) div 2;
end;
end;
if X < DIS.rcItem.Left then
X := DIS.rcItem.Left;
if Y < DIS.rcItem.Top then
Y := DIS.rcItem.Top;
if X + OutW > DIS.rcItem.Right then
OutW := DIS.rcItem.Right - X;
if Y + OutH > DIS.rcItem.Bottom then
OutH := DIS.rcItem.Bottom - Y;
if bboImageList in Self_.fBitBtnOptions then
begin
I := LoWord( Self_.fGlyphCount );
if (HiWord( Self_.fGlyphCount ) > G) then
I := I + G;
Flags := 0; // ILD_NORMAL
Blend := 0;
if not Self_.fTransparent then
Bk := Color2RGB( Self_.fColor )
else
begin
Bk := Integer(CLR_NONE);
Flags := ILD_TRANSPARENT;
end;
if HiWord( Self_.fGlyphCount ) = 1 then
begin
Blend := Integer(CLR_DEFAULT);
if IsDefault then
Flags := Flags or ILD_BLEND25;
end;
ImageList_DrawEx( Self_.fGlyphBitmap, I, DIS.hDC, X, Y, 0, 0,
Bk, Blend, Flags );
end
else
begin
DC := CreateCompatibleDC( 0 );
OldBmp := SelectObject( DC, Self_.fGlyphBitmap );
I := 0;
if Self_.fGlyphCount > G then
I := I + G * ImgW;
StretchBlt( DIS.hDC, X, Y, OutW, OutH, DC, I, 0, ImgW, ImgH, SRCCOPY );
SelectObject( DC, OldBmp );
DeleteDC( DC );
end;
end;
end;
if not (bboNoCaption in Self_.fBitBtnOptions) then
if (TxRect.Right > TxRect.Left) and (TxRect.Bottom > TxRect.Top) then
begin
CapText := Self_.Caption;
CapTxtOrig := CapText; /////////////////////////// added 19 Nov 2001
if Assigned( Self_.FBitBtnGetCaption ) then
CapText := Self_.FBitBtnGetCaption( Self_, CapText ); ////////////
Bk := 0;
Blend := 0;
Flags := ETO_CLIPPED;
if Self_.fTransparent or (Self_.fGlyphLayout = glyphOver) then
Bk := SetBkMode( DIS.hDC, TRANSPARENT )
else
begin
Flags := Flags or ETO_OPAQUE;
Blend := SetBkColor( DIS.hDC, Color2RGB( Self_.fColor ) );
end; // Returned previous BkMode is either OPAQUE=1 or TRANSPARENT=2
OldFont := 0;
if assigned( Self_.fFont ) then
OldFont := SelectObject( DIS.hDC, Self_.fFont.Handle );
OldTextColor := SetTextColor( DIS.hDC, Color2RGB( Self_.fTextColor ) );
{Windows.}GetTextExtentPoint32( DIS.hDC, PKOLChar( CapText ), Length( CapText ),
TextSz );
W := TxRect.Right - TxRect.Left;
H := TxRect.Bottom - TxRect.Top;
Y := TxRect.Top + (H - TextSz.cy) div 2;
case Self_.fTextAlign of
taLeft: X := TxRect.Left;
taCenter: X := TxRect.Left + (W - TextSz.cx) div 2;
else {taRight:} X := TxRect.Right - TextSz.cx;
end;
if isDown then
begin
Inc( X, Self_.TextShiftX );
Inc( Y, Self_.TextShiftY );
end;
if Y < 0 then
Y := 0;
if X < TxRect.Left then
X := TxRect.Left;
Windows.
{$IFDEF UNICODE_CTRLS}
ExtTextOutW
{$ELSE}
ExtTextOut
{$ENDIF}
( DIS.hDC, X, Y, Flags, @TxRect,
PKOLChar( CapText ), Length( CapText ), nil );
if bboFocusRect in Self_.fBitBtnOptions then
if IsDefault then
begin
FocusRect := TxRect;
//InflateRect( FocusRect, 1, 1 );
Windows.DrawFocusRect( DIS.hDC, FocusRect );
end;
if Assigned( Self_.FBitBtnExtDraw ) then // to provide underlying mnemonic characters
Self_.FBitBtnExtDraw( Self_, DIS.hDC, X, Y, TxRect, CapText, CapTxtOrig,
OldTextColor ); /////////////////////////////////
SetTextColor( DIS.hDC, OldTextColor );
if OldFont <> 0 then
SelectObject( DIS.hDC, OldFont );
if Blend = 0 then
SetBkMode( DIS.hDC, Bk )
else
SetBkColor( DIS.hDC, Blend );
end;
end;
if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_KEYDOWN) and (Msg.wParam = 32) then
begin
if bboFixed in Self_.fBitBtnOptions then
begin
Self_.fChecked := not Self_.fChecked;
if Assigned( Self_.fOnChange ) then
Self_.fOnChange( Self_ );
end;
if Self_.fRepeatInterval > 0 then
begin
if Msg.message <> WM_KEYDOWN then
SetTimer( Self_.fHandle, 1, 400, nil );
Self_.Invalidate;
end;
end;
if (Msg.message = WM_LBUTTONUP) or (Msg.message = WM_KEYUP) then
begin
if Self_.fRepeatInterval > 0 then
KillTimer( Self_.fHandle, 1 );
end;
if Msg.message = WM_KILLFOCUS then // to repaint when focus lost
Self_.Invalidate;
if Msg.message = WM_TIMER then
begin
KillTimer( Self_.fHandle, 1 );
if bboFixed in Self_.fBitBtnOptions then
begin
Self_.fChecked := not Self_.fChecked;
if Assigned( Self_.fOnChange ) then
Self_.fOnChange( Self_ );
end;
Self_.DoClick;
SetTimer( Self_.fHandle, 1, Self_.fRepeatInterval, nil );
Self_.Invalidate;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcBitBtn]
{$IFDEF USE_CONSTRUCTORS}
//[function NewBitBtn]
function NewBitBtn( AParent: PControl; const Caption: String;
Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap;
GlyphCount: Integer ): PControl;
begin
new( Result, CreateBitBtn( AParent, Caption, Options, Layout, GlyphBitmap, GlyphCount ) );
end;
//[END NewBitBtn]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewBitBtn]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewBitBtn( AParent: PControl; const Caption: KOLString;
Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap;
GlyphCount: Integer ): PControl;
var
B: TBitmapInfo;
W, H: Integer;
f: DWORD;
begin
f := WS_VISIBLE or WS_CHILD or BS_OWNERDRAW or WS_TABSTOP or BS_NOTIFY;
Result := _NewControl( AParent, 'BUTTON', f, False, @ButtonActions );
Result.fIgnoreDefault := TRUE;
Result.fIsButton := TRUE;
Result.fIsBitBtn := TRUE;
Result.fCommandActions.aAutoSzX := 8;
Result.fCommandActions.aAutoSzY := 8;
Result.fBitBtnOptions := Options;
Result.fGlyphLayout := Layout;
Result.fGlyphBitmap := GlyphBitmap;
with Result.fBoundsRect do
begin
Bottom := Top + 22;
W := 0; H := 0;
if GlyphBitmap <> 0 then
begin
if bboImageList in Options then
ImageList_GetIconSize( GlyphBitmap, W, H )
else
begin
if GetObject( GlyphBitmap, Sizeof(B), @B ) > 0 then
begin
W := B.bmiHeader.biWidth;
H := B.bmiHeader.biHeight;
if GlyphCount = 0 then
GlyphCount := W div H;
if GlyphCount > 1 then
W := W div GlyphCount;
end;
end;
if W > 0 then
begin
if (Caption = '') or (Layout = glyphOver) then
begin
Right := Left + W;
Result.fCommandActions.aAutoSzX := 0;
end
else
if Layout in [ glyphLeft, glyphRight ] then
begin
Right := Right + W;
Inc( Result.fCommandActions.aAutoSzX, W );
end;
end;
if H > 0 then
begin
if Layout in [ glyphTop, glyphBottom ] then
begin
Bottom := Bottom + H;
Inc( Result.fCommandActions.aAutoSzY, H );
end
else
begin
Bottom := Top + H;
Result.fCommandActions.aAutoSzY := 0;
end;
end;
if not ( bboNoBorder in Options ) then
begin
if W > 0 then
begin
Inc( Right, 4 );
if Result.fCommandActions.aAutoSzX > 0 then
Inc( Result.fCommandActions.aAutoSzX, 4 );
end;
if H > 0 then
begin
Inc( Bottom, 4 );
if Result.fCommandActions.aAutoSzY > 0 then
Inc( Result.fCommandActions.aAutoSzY, 4 );
end;
end;
end;
Result.fGlyphWidth := W;
Result.fGlyphHeight := H;
end;
Result.fGlyphCount := GlyphCount;
if AParent <> nil then
AParent.AttachProc( WndProc_DrawItem );
Result.AttachProc( WndProcBitBtn );
Result.fTextAlign := taCenter;
Result.Caption := Caption;
{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
Result.AttachProc( WndProcBtnReturnClick );
{$ENDIF}
{$IFDEF GRAPHCTL_XPSTYLES}
Result.fClassicTransparent := Result.fTransparent;
Attach_WM_THEMECHANGED(Result);
XP_Themes_For_BitBtn(Result);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END NewBitBtn]
{$ENDIF USE_CONSTRUCTORS}
//===================== Check box ========================//
{$IFDEF USE_CONSTRUCTORS}
//[function NewCheckbox]
function NewCheckbox( AParent: PControl; const Caption: String ): PControl;
begin
new( Result, CreateCheckbox( AParent, Caption ) );
end;
//[END NewCheckbox]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewCheckbox]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := NewButton( AParent, Caption );
{$ifdef wince}
Result.DetachProc(WndProcBtnFocus);
{$endif wince}
Result.fColor:=AParent.fColor;
if Result.fBrush <> nil then
Result.fBrush.fData.Color:=Result.fColor;
with Result.fBoundsRect do
begin
Right := Left + 72;
end;
Result.fStyle := WS_VISIBLE or WS_CHILD or
BS_AUTOCHECKBOX or WS_TABSTOP or BS_NOTIFY;
Result.fCommandActions.aAutoSzX := 24;
Result.fIgnoreDefault := FALSE;
{$IFDEF GRAPHCTL_XPSTYLES}
Result.fClassicTransparent := Result.fTransparent;
Attach_WM_THEMECHANGED(Result);
XP_Themes_For_CheckBox(Result);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END NewCheckbox]
{$ENDIF USE_CONSTRUCTORS}
//[function NewCheckBox3State]
function NewCheckBox3State( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := NewCheckbox( AParent, Caption );
Result.fStyle := Result.fStyle and not BS_AUTOCHECKBOX or BS_AUTO3STATE;
end;
//===================== Radiobox ========================//
//[FUNCTION ClickRadio]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure ClickRadio( Sender:PObj );
var Self_:PControl;
begin
Self_ := PControl( Sender );
if Self_.FParent <> nil then
CheckRadioButton( Self_.fParent.fHandle,
Self_.fParent.fRadio1st,
Self_.fParent.fRadioLast,
Self_.fMenu );
end;
{$ENDIF ASM_VERSION}
//[END ClickRadio]
{$IFDEF USE_CONSTRUCTORS}
//[function NewRadiobox]
function NewRadiobox( AParent: PControl; const Caption: String ): PControl;
begin
new( Result, CreateRadiobox( AParent, Caption ) );
end;
//[END NewRadiobox]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewRadiobox]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := NewCheckbox( AParent, Caption );
Result.fStyle := WS_VISIBLE or WS_CHILD or
BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP or BS_NOTIFY;
{$ifdef wince}
Result.DetachProc(WndProcBtnFocus);
{$endif wince}
Result.fControlClick := ClickRadio;
if AParent <> nil then
begin
AParent.fRadioLast := Result.fMenu;
if AParent.fRadio1st = 0 then
begin
AParent.fRadio1st := Result.fMenu;
Result.SetRadioChecked;
end;
end;
{$IFDEF GRAPHCTL_XPSTYLES}
Result.fClassicTransparent := Result.fTransparent;
Attach_WM_THEMECHANGED(Result);
XP_Themes_For_RadioBox(Result);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END NewRadiobox]
{$ENDIF USE_CONSTRUCTORS}
//===================== Label ========================//
{$ENDIF WIN_GDI}
{$IFNDEF USE_CONSTRUCTORS}
{$IFDEF ASM_VERSION}
const StaticClass: array[0..6]of Char=('S','T','A','T','I','C',#0);
{$ENDIF ASM_VERSION}
{$ENDIF not USE_CONSTRUCTORS}
{$IFDEF USE_CONSTRUCTORS}
//[function NewLabel]
function NewLabel( AParent: PControl; const Caption: String ): PControl;
begin
new( Result, CreateLabel( AParent, Caption ) );
end;
//[END NewLabel]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewLabel]
{$IFDEF GDI}
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or
SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,
False ,@LabelActions );
Inc( Result.fIsStaticControl );
Result.fSizeRedraw := True;
with Result.fBoundsRect do
Bottom := Top + 22; //Right := Left + 64 {done in _NewControl};
Result.Caption := Caption;
{$IFDEF GRAPHCTL_XPSTYLES}
Result.fClassicTransparent := Result.fTransparent;
Attach_WM_THEMECHANGED(Result);
XP_Themes_For_Label(Result);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure LabelSetTextAlign( Self_: PControl );
begin
gtk_misc_set_alignment( GTK_MISC( Self_.fCaptionHandle ), HorAlignments[ Self_.fTextAlign ],
VerAlignments[ Self_.fVerticalAlign ] );
end;
function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or
SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,
False, gtk_label_new( PChar( String( Caption ) ) ),
TRUE );
Result.fGetCaption := getLabelCaption;
Result.fSetCaption := setLabelCaption;
Inc( Result.fIsStaticControl );
Result.fSetTextAlign := LabelSetTextAlign;
Result.fTextAlign := taCenter;
Result.TextAlign := taLeft;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$ENDIF USE_CONSTRUCTORS}
//[END NewLabel]
{$IFDEF WIN_GDI}
//===================== word wrap Label ========================//
{$IFDEF USE_CONSTRUCTORS}
//[function NewWordWrapLabel]
function NewWordWrapLabel( AParent: PControl; const Caption: String ): PControl;
begin
new( Result, CreateWordWrapLabel( AParent, Caption ) );
end;
//[END NewWordWrapLabel]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewWordWrapLabel]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewWordWrapLabel( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := NewLabel( AParent, Caption );
Result.fWordWrap := TRUE;
with Result.fBoundsRect do
begin
Bottom := Top + 44;
end;
Result.fStyle := Result.fStyle and not SS_LEFTNOWORDWRAP;
end;
{$ENDIF ASM_VERSION}
//[END NewWordWrapLabel]
{$ENDIF USE_CONSTRUCTORS}
//===================== Label Effect ========================//
{$IFDEF USE_CONSTRUCTORS}
function NewLabelEffect( AParent: PControl; const Caption: String; ShadowDeep: Integer ): PControl;
begin
new( Result, CreateLabelEffect( AParent, Caption, ShadowDeep ) );
end;
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewLabelEffect]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewLabelEffect( AParent: PControl; const Caption: KOLString; ShadowDeep: Integer ): PControl;
begin
Result := NewLabel( AParent, '' );
Dec( Result.fIsStaticControl ); // снова 0 !
Result.AttachProc( WndProcLabelEffect );
Result.Caption := Caption;
Result.AttachProc( WndProcDoEraseBkgnd );
Result.fTextAlign := taCenter;
Result.fTextColor := clWindowText;
Result.fShadowDeep := ShadowDeep;
Result.fIgnoreWndCaption := True;
with Result.fBoundsRect do
begin
Bottom := Top + 40;
end;
Result.fColor2 := clNone;
end;
{$ENDIF ASM_VERSION}
//[END NewLabelEffect]
{$ENDIF USE_CONSTRUCTORS}
//===================== Paint box ========================//
{$ENDIF WIN_GDI}
{$IFDEF USE_CONSTRUCTORS}
//[function NewPaintbox]
function NewPaintbox( AParent: PControl ): PControl;
begin
new( Result, CreatePaintBox( AParent ) );
end;
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewPaintbox]
{$IFDEF GDI}
{$UNDEF ASM_LOCAL}
{$IFNDEF GRAPHCTL_XPSTYLES}
{$IFDEF ASM_VERSION}
{$DEFINE ASM_LOCAL}
{$ENDIF ASM_VERSION}
{$ENDIF GRAPHCTL_XPSTYLES}
{$IFDEF ASM_LOCAL}
function NewPaintbox( AParent: PControl ): PControl;
asm
XOR EDX, EDX
CALL NewLabel
ADD [EAX].TControl.fBoundsRect.Bottom, 64-22
end;
{$ELSE ASM_LOCAL} //Pascal
function NewPaintbox( AParent: PControl ): PControl;
begin
{$IFDEF GRAPHCTL_XPSTYLES}
Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD {or
SS_LEFTNOWORDWRAP or SS_NOPREFIX }or SS_NOTIFY,
False , @LabelActions );
//Inc( Result.fIsStaticControl );
Result.fSizeRedraw := True;
//with Result.fBoundsRect do
// Bottom := Top + 64; //Right := Left + 64 {done in _NewControl};
Result.fClassicTransparent := Result.fTransparent;
Result.fControlClassName := 'obj_PAINT';
{$ELSE}
Result := NewLabel( AParent, '' );
with Result.fBoundsRect do
begin
Bottom := Top + 64; //Right := Left + 64 {done in NewLabel};
end;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function NewPaintbox( AParent: PControl ): PControl;
begin
Result := NewLabel( AParent, '' );
Result.Height := 64;
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[END NewPaintbox]
{$ENDIF USE_CONSTRUCTORS}
{$IFDEF WIN_GDI}
{$IFDEF _D2}
//[API SetBrushOrgEx]
function SetBrushOrgEx(DC: HDC; X, Y: Integer; PrevPt: PPoint): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external gdi32 name 'SetBrushOrgEx';
{$ENDIF}
//[FUNCTION WndProcDoEraseBkgnd]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION PAS_VERSION}
function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var DC: HDC;
R: TRect;
begin
Result := FALSE;
if Msg.message = WM_ERASEBKGND then
begin
Self_.CreateChildWindows;
if Self_.Transparent then Exit;
DC := Msg.wParam;
SetBkMode( DC, OPAQUE );
SetBkColor( DC, Color2RGB( Self_.fColor ) );
SetBrushOrgEx( DC, 0, 0, nil );
GetClientRect( Self_.fHandle, R );
Windows.FillRect( DC, R, Global_GetCtlBrushHandle( Self_ ) );
Rslt := 1;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcDoEraseBkgnd]
//[function WndProcImageShow]
function WndProcImageShow( Sender: PControl; var Msg: TMsg;
var Rslt: Integer ): Boolean;
var PaintStruct: TPaintStruct;
IL: PImageList;
OldPaintDC: HDC;
begin
Result := FALSE;
if (Msg.message = WM_PAINT) or (Msg.message = WM_PRINT) then
begin
OldPaintDC := Sender.fPaintDC;
Sender.fPaintDC := Msg.wParam;
if Sender.fPaintDC = 0 then
Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct );
IL := Sender.ImageListNormal;
if IL <> nil then
begin
IL.Draw( Sender.fCurIndex, Sender.fPaintDC, Sender.fClientLeft, Sender.fClientTop );
Result := TRUE;
end;
if Msg.wParam = 0 then
EndPaint( Sender.fHandle, PaintStruct );
Sender.fPaintDC := OldPaintDC;
Rslt := 0;
//Result := True;
Exit;
end;
end;
//[function NewImageShow]
function NewImageShow( AParent: PControl; AImgList: PImageList;
ImgIdx: Integer ): PControl;
var W, H: Integer;
begin
Result := NewLabel( AParent, '' );
Result.ImageListNormal := AImgList;
Result.AttachProc( WndProcImageShow );
Result.AttachProc( WndProcDoEraseBkgnd );
W := 32; H := 32;
if AImgList <> nil then
begin
W := AImgList.ImgWidth;
H := AImgList.ImgHeight;
end;
with Result.fBoundsRect do
begin
Right := Left + W;
Bottom := Top + H;
end;
end;
//[END NewImageShow]
//===================== Scrollbar ========================//
const
KSB_INITIALIZE = WM_USER + 10000;
KSB_KEY = $3232;
//[function WndProcScrollBarParent]
function WndProcScrollBarParent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var
Bar: PControl;
SI: TScrollInfo;
NewPos: Integer;
AllowChange: Boolean;
Cmd: Word;
begin
Result := False;
case Msg.message of
WM_HSCROLL, WM_VSCROLL:
if (Msg.lParam <> 0) then begin
{$IFDEF USE_PROP}
Bar := Pointer(GetProp(Msg.lParam, ID_SELF));
{$ELSE}
Bar := Pointer( GetWindowLong( Msg.lParam, GWL_USERDATA ) );
{$ENDIF}
if (Bar <> nil) then begin
FillChar(SI, SizeOf(SI), #0);
SI.cbSize := SizeOf(SI);
SI.fMask := SIF_RANGE or SIF_POS or SIF_TRACKPOS or SIF_PAGE;
Bar.SBGetScrollInfo(SI);
{Cmd := Msg.wParam and $0000FFFF;
case Cmd of
SB_BOTTOM: NewPos := SI.nMax;
SB_TOP: NewPos := SI.nMin;
SB_LINEDOWN: NewPos := SI.nPos + 1;
SB_LINEUP: NewPos := SI.nPos - 1;
SB_PAGEDOWN: NewPos := SI.nPos + Integer(SI.nPage);
SB_PAGEUP: NewPos := SI.nPos - Integer(SI.nPage);
SB_THUMBTRACK: NewPos := SI.nTrackPos;
else
Exit;
end;}
Cmd := Msg.wParam and $0000FFFF;
case Cmd of
SB_BOTTOM: NewPos := SI.nMax;
SB_TOP: NewPos := SI.nMin;
SB_LINEDOWN: NewPos := SI.nPos + 1;
SB_LINEUP: NewPos := SI.nPos - 1;
SB_PAGEDOWN: NewPos := SI.nPos + Integer(SI.nPage);
SB_PAGEUP: NewPos := SI.nPos - Integer(SI.nPage);
{!ecm}
SB_THUMBPOSITION,SB_THUMBTRACK: NewPos := SI.nTrackPos;
SB_ENDSCROLL: NewPos := SI.nPos;
{/!ecm}
else
Exit;
end;
if (NewPos > SI.nMax - Integer(SI.nPage) + 1) then
NewPos := SI.nMax - Integer(SI.nPage) + 1;
if (NewPos < SI.nMin) then
NewPos := SI.nMin;
AllowChange := True;
if Assigned(Bar.OnSBBeforeScroll) then
Bar.OnSBBeforeScroll(Bar, SI.nPos, NewPos, Cmd, AllowChange);
if AllowChange then
SI.nPos := NewPos
else
SI.nTrackPos := SI.nPos;
Bar.fSBPosition := SI.nPos;
Bar.fSBPosition := Bar.SBSetScrollInfo(SI);
if AllowChange and Assigned(Bar.OnSBScroll) then
Bar.OnSBScroll(Bar, Cmd);
end;
end;
end;
end;
//[END WndProcScrollBarParent]
//[function NewScrollBar]
function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl;
const SBS_Directions: array[ TScrollerBar ] of DWORD = ( SBS_HORZ {$ifndef wince} or SBS_BOTTOMALIGN{$endif wince},
SBS_VERT {$ifndef wince}or SBS_RIGHTALIGN{$endif wince} );
begin
Result := _NewCommonControl(
AParent,
'SCROLLBAR',
WS_VISIBLE or WS_CHILD or SBS_Directions[ BarSide ],
False,
nil
);
{!ecm}
Result.GetWindowHandle;
{/!ecm}
Result.DetachProc(WndProcCtrl);
Result.fLookTabKeys := [tkTab];
//#ecm Result.AttachProc(WndProcScrollBar);
AParent.AttachProc(WndProcScrollBarParent);
{$ifdef wince}
Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
{$endif wince}
end;
//[END NewScrollBar]
//===================== Scrollbox ========================//
//[function WndProcScrollBox]
function WndProcScrollBox( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
procedure DoScrollChildren;
var
OldNotifyProc: pointer;
begin
if Assigned( Sender.fScrollChildren ) then
begin
OldNotifyProc := @ Sender.fNotifyChild;
Sender.fNotifyChild := nil;
Sender.fScrollChildren( Sender );
Sender.fNotifyChild := OldNotifyProc;
end;
end;
var Bar: DWORD;
SI: TScrollInfo;
OldPos: integer;
begin
Result := FALSE;
case Msg.message of
WM_HSCROLL: Bar := SB_HORZ;
WM_VSCROLL: Bar := SB_VERT;
WM_SIZE: begin
if Assigned( Sender.fNotifyChild ) then
Sender.fNotifyChild( Sender, nil );
Exit;
end;
WM_SHOWWINDOW:
begin
if WordBool(Msg.wParam) then begin
Sender.fVisible:=False;
Sender.CreateChildWindows;
Sender.fVisible:=True;
if Assigned(Sender.fNotifyChild) then
Sender.fNotifyChild(Sender, nil);
end;
exit;
end;
else begin
Exit;
end;
end;
SI.cbSize := Sizeof( SI );
SI.fMask := SIF_RANGE or SIF_POS or SIF_PAGE or
{$IFDEF F_P}$10{$ELSE}SIF_TRACKPOS{$ENDIF};
{$IFDEF _D2}
GetScrollInfo( Sender.fHandle, Bar, SI );
{$ELSE}
GetScrollInfo( Sender.fHandle, Bar, SI );
{$ENDIF}
OldPos:=SI.nPos;
SI.fMask := SIF_POS;
case LoWord( Msg.wParam ) of
SB_BOTTOM: SI.nPos := SI.nMax;
SB_TOP: SI.nPos := SI.nMin;
SB_LINEDOWN: Inc( SI.nPos, Sender.FScrollLineDist[ Bar ] );
SB_LINEUP: Dec( SI.nPos, Sender.FScrollLineDist[ Bar ] );
SB_PAGEDOWN: Inc( SI.nPos, Max( SI.nPage, 1 ) );
SB_PAGEUP: Dec( SI.nPos, Max( SI.nPage, 1 ) );
SB_THUMBTRACK:SI.nPos := SI.nTrackPos;
end;
if SI.nPos > SI.nMax - Integer( SI.nPage ) + 1 then
SI.nPos := SI.nMax - Integer( SI.nPage ) + 1;
if SI.nPos < SI.nMin then
SI.nPos := SI.nMin;
if OldPos = SI.nPos then exit;
SetScrollInfo( Sender.fHandle, Bar, SI, TRUE );
DoScrollChildren;
end;
//[END WndProcScrollBox]
//[function NewScrollBox]
function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle;
Bars: TScrollerBars ): PControl;
const Edgestyles: array[ TEdgeStyle ] of DWORD = ( {$ifdef wince}WS_BORDER, WS_BORDER{$else}WS_DLGFRAME, SS_SUNKEN{$endif}, 0, 0 );
var SBFlag: Integer;
begin
SBFlag := EdgeStyles[ EdgeStyle ];
if sbHorizontal in Bars then
SBFlag := SBFlag or WS_HSCROLL;
if sbVertical in Bars then
SBFlag := SBFlag or WS_VSCROLL;
Result := _NewControl( AParent, 'ScrollBox', WS_VISIBLE or WS_CHILD or
SBFlag, EdgeStyle = esLowered, nil );
Result.AttachProc( WndProcForm ); //!!!
Result.AttachProc( WndProcScrollBox );
Result.AttachProc( WndProcDoEraseBkgnd );
Result.fIsControl := TRUE;
end;
//[END NewScrollBox]
//[function WndProcNotifyParentAboutResize]
function WndProcNotifyParentAboutResize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var P: PControl;
begin
if (Msg.message = WM_SIZE) or (Msg.message = WM_MOVE) or (Msg.message = CM_SHOW) then
begin
P := Sender.Parent;
if P <> nil then
if Assigned( P.fNotifyChild ) then
P.fNotifyChild( P, nil );
end
else
if (Msg.message = WM_SHOWWINDOW) and (Sender.Parent <> nil) and (Sender.Parent.Visible) then
PostMessage( Sender.fHandle, CM_SHOW, 0, 0 );
Result := FALSE;
end;
//[procedure CalcMinMaxChildren]
procedure CalcMinMaxChildren( Self_: PControl; var SzR: TRect );
var I: Integer;
C: PControl;
R: TRect;
begin
Szr := MakeRect( 0, 0, 0, 0 );
for I := 0 to Self_.fChildren.fCount - 1 do
begin
C := Self_.fChildren.fItems[ I ];
if C.ToBeVisible then
begin
R := C.BoundsRect;
if (SzR.Left = SzR.Right) or (R.Left < SzR.Left) or (R.Right > SzR.Right) then
begin
if SzR.Left = SzR.Right then
begin
SzR.Left := R.Left;
SzR.Right := R.Right;
end
else
begin
if R.Left < SzR.Left then SzR.Left := R.Left;
if R.Right > SzR.Right then SzR.Right := R.Right;
end;
end;
if (SzR.Top = SzR.Bottom) or (R.Top < SzR.Top) or (R.Bottom > SzR.Bottom) then
begin
if SzR.Top = SzR.Bottom then
begin
SzR.Top := R.Top;
SzR.Bottom := R.Bottom;
end
else
begin
if R.Top < SzR.Top then SzR.Top := R.Top;
if R.Bottom > SzR.Bottom then SzR.Bottom := R.Bottom;
end;
end;
end;
end;
Dec( SzR.Left, Self_.Border );
Inc( SzR.Right, Self_.Border - 1 );
Dec( SzR.Top, Self_.Border );
Inc( SzR.Bottom, Self_.Border - 1 );
end;
//[procedure NotifyScrollBox]
procedure NotifyScrollBox( Self_, Child: PControl );
var SI: TScrollInfo;
procedure GetSetScrollInfo( SBar: DWORD; WH, R_RightBottom, SzR_LeftTop, SzR_RightBottom: Integer );
{$IFDEF SBOX_OLDPOS} var OldPos: Double; {$ENDIF}
begin
{$IFDEF SBOX_OLDPOS} OldPos := 0; {$ENDIF}
if not GetScrollInfo( Self_.fHandle, SBar, SI ) then
begin
SI.nMin := 0;
SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );
end
else
begin
{$IFDEF SBOX_OLDPOS}
if SI.nMax > SI.nMin then
begin
OldPos := (SI.nPos - SI.nMin) / (SI.nMax - SI.nMin);
SI.nMin := 0;
SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );
if SzR_LeftTop < 0 then
SI.nMax := Max( R_RightBottom - SzR_LeftTop - 1, WH - 1 );
end
else
begin
SI.nMin := 0;
SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );
end;
{$ENDIF}
SI.nMin := 0; {!ecm}
SI.nMax := SzR_RightBottom - SzR_LeftTop; {!ecm}
end;
{$IFDEF SBOX_OLDPOS}
SI.nPos := SI.nMin + Round( (SI.nMax - SI.nMin) * OldPos );
{$ELSE}
SI.nPos := - SzR_LeftTop;
{$ENDIF}
SI.nPage := R_RightBottom;
SetScrollInfo( Self_.fHandle, SBar, SI, TRUE );
end;
var W, H: Integer;
SzR: TRect;
R: TRect;
begin
if Assigned( Child ) then
begin
Child.AttachProc( WndProcNotifyParentAboutResize );
Exit;
end;
CalcMinMaxChildren( Self_, SzR );
W := SzR.Right - SzR.Left;
H := SzR.Bottom - SzR.Top;
R := Self_.ClientRect;
if (R.Right = 0) or (R.Bottom = 0) then Exit; // for case when form is minimized
SI.cbSize := sizeof( SI );
SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS;
SI.cbSize := sizeof( SI );
SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS;
GetSetScrollInfo( SB_HORZ, W, R.Right, SzR.Left, SzR.Right );
{+ecm}R := Self_.ClientRect;{/+ecm}
GetSetScrollInfo( SB_VERT, H, R.Bottom, SzR.Top, SzR.Bottom );
{+ecm} if Assigned( Self_.fScrollChildren ) then Self_.fScrollChildren(Self_); {/+ecm}
end;
//[procedure ScrollChildren]
procedure ScrollChildren( _Self_: PControl );
var SzR, R: TRect;
I, Xpos, Ypos: Integer;
OldNotifyProc: Pointer;
C: PControl;
DeltaX, DeltaY: Integer;
begin
if not _Self_.Visible then exit;
CalcMinMaxChildren( _Self_, SzR );
Xpos := GetScrollPos( _Self_.fHandle, SB_HORZ );
Ypos := GetScrollPos( _Self_.fHandle, SB_VERT );
DeltaX := -Xpos - SzR.Left;
DeltaY := -Ypos - SzR.Top;
if (DeltaX <> 0) or (DeltaY <> 0) then
begin
OldNotifyProc := @ _Self_.fNotifyChild;
_Self_.fNotifyChild := nil;
for I := 0 to _Self_.fChildren.fCount - 1 do
begin
C := _Self_.fChildren.fItems[ I ];
R := C.BoundsRect;
OffsetRect( R, DeltaX, DeltaY );
C.BoundsRect := R;
{$ifndef wince}
C.Invalidate;
{$endif wince}
end;
_Self_.Update;
_Self_.fNotifyChild := OldNotifyProc;
(*
CalcMinMaxChildren( _Self_, R );
if //(SzR.Left <> R.Left) or (SzR.Top <> R.Top) or
//(Szr.Right <> R.Right) or (SzR.Bottom <> R.Bottom)
((SzR.Right - SzR.Left) <> (R.Right - R.Left)) or
((SzR.Bottom - SzR.Top) <> (R.Bottom - R.Top))
then
if Assigned( _Self_.fNotifyChild ) then
_Self_.fNotifyChild( _Self_, nil );
*)
end;
end;
//[function NewScrollBoxEx]
function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
begin
Result := NewScrollBox( AParent, EdgeStyle, [ ] );
Result.fNotifyChild := NotifyScrollBox;
Result.fScrollChildren := ScrollChildren;
Result.FScrollLineDist[ 0 ] := 16;
Result.FScrollLineDist[ 1 ] := 16;
end;
//[function WndProcOnScroll]
function WndProcOnScroll( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Bar: TScrollerBar;
begin
Bar := sbHorizontal; //0
if Msg.message = WM_VSCROLL then
Bar := sbVertical
else
if Msg.message <> WM_HSCROLL then
begin
Result := FALSE;
Exit;
end;
if Assigned( Sender.OnScroll ) then
Sender.OnScroll( Sender, Bar, LoWord( Msg.wParam ), HiWord( Msg.wParam ) );
Result := FALSE;
end;
//[procedure TControl.SetOnScroll]
procedure TControl.SetOnScroll(const Value: TOnScroll);
begin
FOnScroll := Value;
AttachProc( @ WndProcOnScroll );
end;
//===================== Groupbox ========================//
{$IFDEF USE_CONSTRUCTORS}
//[function NewGroupbox]
function NewGroupbox( AParent: PControl; const Caption: String ): PControl;
begin
new( Result, CreateGroupbox( AParent, Caption ) );
end;
//[END NewGroupbox]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewGroupbox]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := _NewControl( AParent, 'BUTTON',
WS_CHILD
or WS_CLIPSIBLINGS
or WS_CLIPCHILDREN
or WS_VISIBLE
or BS_GROUPBOX,
FALSE, @ButtonActions );
{$ifndef wince}
Result.fExStyle := Result.fExStyle or WS_EX_CONTROLPARENT;
{$endif wince}
Result.Caption := Caption;
with Result.fBoundsRect do
begin
Right := Left + 100;
Bottom := Top + 100;
end;
Result.fClientTop := {$ifdef wince}8{$else}22{$endif};
Result.fClientBottom := 2;
Result.fClientLeft := 2;
Result.fClientRight := 2;
Result.fTabstop := False;
Result.fIsGroupBox := TRUE;
Result.AttachProc( WndProcDoEraseBkgnd );
{$IFDEF GRAPHCTL_XPSTYLES}
Result.fClassicTransparent := Result.fTransparent;
//if AppTheming then
// Result.Style := Result.Style or BS_OWNERDRAW;
Attach_WM_THEMECHANGED(Result);
XP_Themes_For_GroupBox(Result);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END NewGroupbox]
{$ENDIF USE_CONSTRUCTORS}
//===================== Panel ========================//
{$IFDEF USE_CONSTRUCTORS}
//[function NewPanel]
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
begin
new( Result, CreatePanel( AParent, EdgeStyle ) );
end;
//[END NewPanel]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewPanel]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
{$ifdef win32}
const Edgestyles: array[ TEdgeStyle ] of DWORD = ( WS_DLGFRAME, SS_SUNKEN, 0, 0 );
{$endif win32}
begin
Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or SS_NOTIFY or
SS_LEFTNOWORDWRAP or SS_NOPREFIX, False, @LabelActions );
with Result.fBoundsRect do
begin
Right := Left + 100;
Bottom := Top + 100;
end;
{$ifdef wince}
if EdgeStyle in [esRaised, esLowered] then
Result.fStyle := Result.fStyle or WS_BORDER;
{$else}
Result.fStyle := Result.fStyle or Edgestyles[ EdgeStyle ];
Result.fExStyle := Result.fExStyle or WS_EX_CONTROLPARENT;
{$endif wince}
Result.fVerticalAlign := vaTop;
{$IFDEF GRAPHCTL_XPSTYLES}
Result.fClassicTransparent := Result.fTransparent;
if AppTheming then
Result.fStyle := Result.fStyle and (not Edgestyles[ EdgeStyle ]);
Result.SetEdgeStyle(EdgeStyle);
Attach_WM_THEMECHANGED(Result);
XP_Themes_For_Panel(Result);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END NewPanel]
{$ENDIF USE_CONSTRUCTORS}
//===================== Splitter ==============================//
//{$DEFINE USE_ASM_DODRAG}
{$IFNDEF USE_ASM_DODRAG}
{$DEFINE USE_PAS_DODRAG}
{$ENDIF}
{$IFNDEF ASM_VERSION}
{$DEFINE USE_PAS_DODRAG}
{$ENDIF}
{$IFDEF USE_PAS_DODRAG}
//[procedure DoDrag]
procedure DoDrag( Self_: PControl; Cancel: Boolean{$ifdef wince}; MousePos: TPoint{$endif});
var NewSize1, NewSize2: Integer;
{$ifndef wince}
MousePos: TPoint;
{$endif wince}
R: TRect;
Prev: PControl;
I, M : Integer;
begin
if Self_.fDragging then
begin
I := Self_.fParent.fChildren.IndexOf( Self_ );
Prev := Self_;
if I > 0 then
Prev := Self_.FParent.fChildren.fItems[ I - 1 ];
{$ifndef wince}
if Cancel then
MousePos := Self_.fSplitStartPos
else
GetCursorPos( MousePos );
{$endif wince}
M := 1;
if Self_.FAlign in [ caRight, caBottom ] then
M := -1;
if Self_.FAlign in [ caTop, caBottom ] then
begin
NewSize1 := (MousePos.y - Self_.fSplitStartPos.y)* M
+ Self_.fSplitStartSize;
NewSize2 := Self_.fParent.ClientHeight - NewSize1
- Self_.fBoundsRect.Bottom + Self_.fBoundsRect.Top
- Self_.fParent.fMargin * 4;
if Self_.fSecondControl <> nil then
begin
NewSize2 := Self_.fSecondControl.fBoundsRect.Bottom
- Self_.fSecondControl.fBoundsRect.Top;
if Self_.fSecondControl.FAlign = caClient then
NewSize2 := Self_.fSplitStartPos2.y
- (MousePos.y - Self_.fSplitStartPos.y)* M
- Self_.fParent.fMargin * 4;
end;
end
else
begin
NewSize1 := (MousePos.x - Self_.fSplitStartPos.x)* M
+ Self_.fSplitStartSize;
NewSize2 := Self_.fParent.ClientWidth - NewSize1
- Self_.fBoundsRect.Right + Self_.fBoundsRect.Left
- Self_.fParent.fMargin * 4;
if Self_.fSecondControl <> nil then
begin
NewSize2 := Self_.fSecondControl.fBoundsRect.Right
- Self_.fSecondControl.fBoundsRect.Left;
if Self_.fSecondControl.FAlign = caClient then
NewSize2 := Self_.fSplitStartPos2.x
- (MousePos.x - Self_.fSplitStartPos.x)* M
- Self_.fParent.Margin * 4;
end;
end;
if (NewSize1 < Self_.fSplitMinSize1) then
begin
Dec( NewSize2, Self_.fSplitMinSize1 - NewSize1 );
NewSize1 := Self_.fSplitMinSize1;
end;
if (NewSize2 < Self_.fSplitMinSize2) then
begin
Dec( NewSize1, Self_.fSplitMinSize2 - NewSize2 );
NewSize2 := Self_.fSplitMinSize2;
end;
if NewSize1 < Self_.fSplitMinSize1 then Exit;
if NewSize2 < Self_.fSplitMinSize2 then Exit;
if assigned( Self_.fOnSplit ) then
if not Self_.fOnSplit( Self_, NewSize1, NewSize2 ) then Exit;
R := Prev.BoundsRect;
case Self_.FAlign of
caTop: R.Bottom := R.Top + NewSize1;
caBottom: R.Top := R.Bottom - NewSize1;
caRight: R.Left := R.Right - NewSize1;
else R.Right := R.Left + NewSize1;
end;
Prev.BoundsRect := R;
{$IFDEF OLD_ALIGN}
Global_Align( Self_.fParent );
{$ELSE NEW_ALIGN}
Global_Align( Self_ );
{$ENDIF}
end;
end;
{$ENDIF}
const
chkLeft=2;
chkTop=4;
chkRight=8;
chkBott=16;
{$DEFINE USE!_ASM_DODRAG}
//[FUNCTION WndProcSplitter]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
Prev: PControl;
procedure FinDrag;
begin
KillTimer( Self_.fHandle, $7B );
Self_.fDragging := False;
ReleaseCapture;
end;
{$ifdef wince}
function GetMouseCursorPos(lParam: DWORD): TPoint;
begin
Result:=Self_.Client2Screen(MakePoint(SmallInt(LOWORD(Msg.lParam)), SmallInt(HIWORD(Msg.lParam))));
end;
{$endif wince}
begin
case Msg.message of
{$ifndef wince}
WM_NCHITTEST:
begin
Rslt := DefWindowProc( Self_.fHandle, Msg.message, Msg.wParam, Msg.lParam );
if Rslt > 0 then
Rslt := HTCLIENT;
Result := True;
Exit;
end;
{$endif wince}
WM_MOUSEMOVE:
begin
Windows.SetCursor( Self_.fCursor );
DoDrag( Self_, False {$ifdef wince},GetMouseCursorPos(Msg.lParam){$endif} );
end;
WM_LBUTTONDOWN:
begin
if Self_.fParent <> nil then
begin
I := Self_.fParent.fChildren.IndexOf( Self_ );
Prev := Self_;
if I > 0 then
Prev := Self_.FParent.fChildren.fItems[ I - 1 ];
if Self_.fAlign in [ caTop, caBottom ] then
Self_.fSplitStartSize := Prev.Height
else
Self_.fSplitStartSize := Prev.Width;
if Self_.fSecondControl <> nil then
Self_.fSplitStartPos2 :=
MakePoint( Self_.fSecondControl.Width, Self_.fSecondControl.Height );
SetCapture( Self_.fHandle );
Self_.fDragging := True;
SetTimer( Self_.fHandle, $7B, 100, nil );
{$ifdef wince}
Self_.fSplitStartPos:=GetMouseCursorPos(Msg.lParam);
{$else}
GetCursorPos( Self_.fSplitStartPos );
{$endif wince}
end;
end;
WM_LBUTTONUP:
begin
DoDrag( Self_, False {$ifdef wince},GetMouseCursorPos(Msg.lParam){$endif});
FinDrag;
end;
WM_TIMER:
if Self_.fDragging and (GetAsyncKeyState( VK_ESCAPE ) < 0) then
begin
DoDrag( Self_, True {$ifdef wince},Self_.fSplitStartPos{$endif});
FinDrag;
end;
end;
Result := False;
end;
{$ENDIF ASM_VERSION}
//[END WndProcSplitter]
//[function NewSplitter]
function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;
begin
Result := NewSplitterEx( AParent, MinSizePrev, MinSizeNext, esLowered );
end;
//[END NewSplitter]
{$IFDEF USE_CONSTRUCTORS}
//[function NewSplitterEx]
function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
EdgeStyle: TEdgeStyle ): PControl;
begin
new( Result, CreateSplitter( AParent, MinSizePrev, MinSizeNext, EdgeStyle ) );
end;
//[END NewSplitterEx]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewSplitterEx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
EdgeStyle: TEdgeStyle ): PControl;
var PrevCtrl: PControl;
Sz0: Integer;
begin
Result := NewPanel( AParent, EdgeStyle );
Result.fSplitMinSize1 := MinSizePrev;
Result.fSplitMinSize2 := MinSizeNext;
Result.fIsSplitter := TRUE;
Sz0 := 4;
with Result.fBoundsRect do
begin
Right := Left + Sz0;
Bottom := Top + Sz0;
end;
if AParent <> nil then
begin
if AParent.fChildren.fCount > 1 then
begin
PrevCtrl := AParent.fChildren.fItems[ AParent.fChildren.fCount - 2 ];
case PrevCtrl.FAlign of
caLeft, caRight:
begin
Result.fCursor := LoadCursor( 0, IDC_SIZEWE );
end;
caTop, caBottom:
begin
Result.fCursor := LoadCursor( 0, IDC_SIZENS );
end;
end;
Result.Align := PrevCtrl.FAlign;
end;
end;
Result.AttachProc( WndProcSplitter );
{$IFDEF GRAPHCTL_XPSTYLES}
Result.fClassicTransparent := Result.fTransparent;
Attach_WM_THEMECHANGED(Result);
XP_Themes_For_Splitter(Result);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END NewSplitterEx]
{$ENDIF USE_CONSTRUCTORS}
//===================== MDI client window control =============//
{$ifdef win32}
//[procedure DestroyMDIChildren]
procedure DestroyMDIChildren( Form: PControl );
var MDIClient: PControl;
I: Integer;
Ch: PControl;
begin
MDIClient := Form.fMDIClient;
MDIClient.fMDIDestroying := TRUE;
if MDIClient = nil then Exit;
if MDIClient.fMDIChildren <> nil then
for I := MDIClient.fMDIChildren.Count - 1 downto 0 do
begin
Ch := MDIClient.fMDIChildren.fItems[ I ];
if Ch.fHandle <> 0 then
MDIClient.Perform( WM_MDIDESTROY, Ch.fHandle, 0 );
end;
MDIClient.fMDIChildren.Free;
MDIClient.fMDIChildren := nil;
if Form.fMenu <> 0 then
begin
MDIClient.Perform( WM_MDISETMENU, 0, 0 );
MDIClient.Perform( WM_MDIREFRESHMENU, 0, 0 );
DrawMenuBar( Form.fHandle );
Form.fMenuObj.Free;
Form.fMenuObj := nil;
end;
Form.fMDIClient := nil;
MDIClient.Free;
end;
//[function ProcMDIAccel]
function ProcMDIAccel( Applet: PControl; var Msg: TMsg ): Boolean;
var Form: PControl;
begin
Result := FALSE;
if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
begin
Form := Applet.ActiveControl;
if Form <> nil then
begin
if Form.IsMDIChild then
Form := Form.Parent;
Form := Form.ParentForm;
if (Form <> nil) and (Form.MDIClient <> nil) then
Result := TranslateMDISysAccel( Form.MDIClient.fHandle, Msg );
end;
end;
end;
//[function CallDefFrameProc]
function CallDefFrameProc( Wnd: HWnd; Msg: Integer; wParam, lParam: Integer ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif};
var Form: PControl;
begin
{$IFDEF USE_PROP}
Form := Pointer( GetProp( Wnd, ID_SELF ) );
{$ELSE}
Form := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
{$ENDIF}
if Form <> nil then
Form := Form.ParentForm;
if (Form <> nil) and (Form.fMDIClient <> nil) then
Result := DefFrameProc( Wnd, Form.fMDIClient.fHandle, Msg, wParam, lParam )
else
Result := DefWindowProc( Wnd, Msg, wParam, lParam );
end;
//[function WndFuncMDIClient]
function WndFuncMDIClient( Wnd: HWnd; Msg, wParam, lParam: Integer ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif};
var C: PControl;
M: TMsg;
begin
{$IFDEF USE_PROP}
C := Pointer( GetProp( Wnd, ID_SELF ) );
{$ELSE}
C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
{$ENDIF}
if C <> nil then
begin
M.hwnd := Wnd;
M.message := Msg;
M.wParam := wParam;
M.lParam := lParam;
Result := C.WndProc( M );
end
else
Result := DefWindowProc( Wnd, Msg, wParam, lParam );
end;
//[function ShowMDIClientEdge]
function ShowMDIClientEdge( MDIClient: PControl ): Boolean;
var ShowEdge: Boolean;
I: Integer;
Ch: PControl;
ExStyle: Integer;
begin
Result := FALSE;
ShowEdge := TRUE;
if MDIClient.fMDIChildren.Count > 0 then
for I := 0 to MDIClient.fMDIChildren.Count-1 do
begin
Ch := MDIClient.fMDIChildren.fItems[ I ];
if IsZoomed( Ch.fHandle ) then
begin
ShowEdge := FALSE;
break;
end;
end;
ExStyle := MDIClient.ExStyle;
if ShowEdge then
if ExStyle and WS_EX_CLIENTEDGE = 0 then
ExStyle := ExStyle or WS_EX_CLIENTEDGE
else
Exit
else if ExStyle and WS_EX_CLIENTEDGE <> 0 then
ExStyle := ExStyle and not WS_EX_CLIENTEDGE
else
Exit;
MDIClient.ExStyle := ExStyle;
Result := TRUE;
end;
//[function WndProcMDIClient]
function WndProcMDIClient( MDIClient: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
if not MDIClient.fMDIDestroying then
case Msg.message of
$3f:
begin
PostMessage( MDIClient.fHandle, CM_MDIClientShowEdge, 0, 0 );
end;
CM_MDIClientShowEdge:
begin
ShowMDIClientEdge( MDIClient );
end;
WM_NCHITTEST: // not necessary though
begin
Rslt := DefWindowProc( MDIClient.fHandle, WM_NCHITTEST, Msg.wParam, Msg.lParam );
if Rslt = HTCLIENT then Rslt := HTTRANSPARENT;
end;
WM_WINDOWPOSCHANGING:
begin
MDIClient.Perform( WM_SETREDRAW, 0, 0 );
end;
WM_WINDOWPOSCHANGED:
begin
Global_Align( {$IFDEF OLD_ALIGN}MDIClient.Parent{$ELSE}MDIClient{$ENDIF} );
MDIClient.Invalidate;
MDIClient.Parent.Invalidate;
MDIClient.Perform( WM_SETREDRAW, 1, 0 );
PostMessage( MDIClient.fHandle, CM_INVALIDATE, 0, 0 );
end;
CM_INVALIDATE:
begin
MDIClient.InvalidateNC( TRUE );
MDIClient.InvalidateEx;
end;
end;
Result := FALSE;
end;
// function added by Thaddy de Koning to fix MDI behaviour
//[function WndProcParentNotifyMouseLDown]
function WndProcParentNotifyMouseLDown( Sender: PControl; var Msg: TMsg;
var Rslt: Integer ): Boolean;
begin
Result := FALSE;
if (Sender.IsMDIChild) and (Msg.message = WM_PARENTNOTIFY) and
(LOWORD(msg.wparam)=WM_LBUTTONDOWN) then
BringWindowToTop( Sender.Handle );
end;
//[function NewMDIClient]
function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl;
var F: PControl;
CCS: TClientCreateStruct;
PrntWin: HWnd;
begin
F := nil;
PrntWin := 0;
if AParent <> nil then
begin
F := AParent.ParentForm;
if F <> nil then
begin
F.Add2AutoFreeEx( TObjectMethod( MakeMethod( F, @ DestroyMDIChildren ) ) );
F.GetWindowHandle; // must be created before MDI client creation
F.fDefWndProc := @CallDefFrameProc;
end;
PrntWin := AParent.GetWindowHandle;
end;
Applet.fExMsgProc := ProcMDIAccel;
Result := _NewControl( AParent, 'MDICLIENT',
WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or
WS_VISIBLE or WS_TABSTOP or MDIS_ALLCHILDSTYLES, TRUE, nil );
Result.fMDIChildren := NewList;
Result.fExStyle := WS_EX_CLIENTEDGE;
CCS.hWindowMenu := WindowMenu;
CCS.idFirstChild := $FF00;
Result.fHandle := CreateWindowEx( WS_EX_CLIENTEDGE, 'MDICLIENT', nil,
WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or
WS_VISIBLE or WS_TABSTOP,
0, 0, 0, 0, PrntWin, 0, hInstance, @ CCS );
Result.fDefWndProc := Pointer( GetWindowLong( Result.fHandle, GWL_WNDPROC ) );
SetWindowLong( Result.fHandle, GWL_WNDPROC, Integer( @WndFuncMDIClient ) );
{$IFDEF USE_PROP}
SetProp( Result.fHandle, ID_SELF, Integer( Result ) );
{$ELSE}
SetWindowLong( Result.fHandle, GWL_USERDATA, Integer( Result ) );
{$ENDIF}
if F <> nil then
F.fMDIClient := Result;
Result.AttachProc( WndProcMDIClient );
Result.GetWindowHandle;
Applet.AttachProc( WndProcParentNotifyMouseLDown );
end;
//===================== MDI child window object ==============//
//[function MDIChildFunc]
function MDIChildFunc( Wnd: HWnd; Msg: DWord; wParam, lParam: Integer ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif};
var C: PControl;
M: TMsg;
begin
{$IFDEF USE_PROP}
C := Pointer( GetProp( Wnd, ID_SELF ) );
{$ELSE}
C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
{$ENDIF}
if C <> nil then
begin
M.hwnd := Wnd;
M.message := Msg;
M.wParam := wParam;
M.lParam := lParam;
Result := C.WndProc( M );
end
else
Result := DefMDIChildProc( Wnd, Msg, wParam, lParam );
end;
//[function Pass2DefMDIChildProc]
function Pass2DefMDIChildProc( Sender_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
if Sender_ = nil then Exit;
if Sender_.Parent = nil then Exit;
if Sender_.Parent.fDestroying then Exit;
if (Msg.message = WM_SYSCOMMAND) or (Msg.message = WM_CHILDACTIVATE) or
(Msg.message = WM_SETFOCUS) or (Msg.message = WM_SIZE) or
(Msg.message = WM_MOVE) or (Msg.message = WM_MENUCHAR) or
(Msg.message = WM_GETMINMAXINFO) {and IsZoomed( Sender_.fHandle ) and (Msg.hwnd = Sender_.fHandle) -- doesn't work -- } then
begin
Rslt := DefMDIChildProc( Msg.hwnd, Msg.message, Msg.lParam, Msg.wParam );
Result := TRUE;
end;
end;
//[function WndProcMDIChild]
function WndProcMDIChild( MDIChild: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var ClientWnd: HWnd;
MDIClient: PControl;
MDIForm: PControl;
begin
Result := FALSE;
MDIClient := MDIChild.Parent;
if MDIClient = nil then Exit;
ClientWnd := MDIClient.fHandle;
if ClientWnd = 0 then Exit;
case Msg.message of
WM_DESTROY:
begin
MDIClient.fMDIChildren.Remove( MDIChild );
MDIForm := MDIClient.ParentForm;
if MDIForm <> nil then
if MDIForm.fHandle <> 0 then
DrawMenuBar( MDIForm.fHandle );
MDIChild.Free;
Result := TRUE;
Exit;
end;
end;
if MDIChild.fNotAvailable then
begin
MDIChild.fNotAvailable := FALSE;
MDIChild.Invalidate;
end;
end;
//[procedure CreateMDIChildExt]
procedure CreateMDIChildExt( Sender: PControl );
var F: PControl;
begin
F := Sender.Parent;
if F <> nil then
F := F.ParentForm;
if F <> nil then
DrawMenuBar( F.fHandle );
end;
//[function NewMDIChild]
function NewMDIChild( AParent: PControl; const ACaption: String ): PControl;
var MDIClient: PControl;
begin
Assert( (AParent <> nil) and (AParent.ParentForm <> nil) and
(AParent.ParentForm.fMDIClient <> nil), 'Error creating MDI child' );
MDIClient := AParent.ParentForm.fMDIClient;
Result := NewForm( MDIClient, ACaption );
Result.fIsMDIChild := TRUE;
Result.fMenu := CtlIdCount;
Inc( CtlIdCount );
MDIClient.fMDIChildren.Add( Result );
Result.fExStyle := Result.fExStyle or WS_EX_MDICHILD;
Result.fWndFunc := @ MDIChildFunc;
Result.fDefWndProc := @DefMDIChildProc;
Result.fPass2DefProc := Pass2DefMDIChildProc;
Result.AttachProc( WndProcMDIChild );
Result.SubClassName := 'MDI_chld';
Result.fNotAvailable := TRUE;
Result.fCreateWndExt := CreateMDIChildExt;
end;
{$endif win32}
//===================== Gradient panel ========================//
{$IFDEF USE_CONSTRUCTORS}
//[function NewGradientPanel]
function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;
begin
new( Result, CreateGradientPanel( AParent, Color1, Color2 ) );
end;
//[END NewGradientPanel]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewGradientPanel]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;
begin
Result := NewLabel( AParent, '' );
Result.AttachProc( WndProcGradient );
Result.fColor2 := Color2;
Result.fColor1 := Color1;
with Result.fBoundsRect do
begin
Right := Left + 40;
Bottom := Top + 40;
end;
end;
{$ENDIF ASM_VERSION}
//[END NewGradientPanel]
{$ENDIF USE_CONSTRUCTORS}
{$IFDEF USE_CONSTRUCTORS}
//[function NewGradientPanelEx]
function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;
Style: TGradientStyle; Layout: TGradientLayout ): PControl;
begin
new( Result, CreateGradientPanelEx( AParent, Color1, Color2,
Style, Layout ) );
end;
//[END NewGradientPanelEx]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewGradientPanelEx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;
Style: TGradientStyle; Layout: TGradientLayout ): PControl;
begin
Result := NewLabel( AParent, '' );
Result.AttachProc( WndProcGradientEx );
Result.fColor2 := Color2;
Result.fColor1 := Color1;
Result.fGradientStyle := Style;
Result.fGradientLayout := Layout;
with Result.fBoundsRect do
begin
Right := Left + 40;
Bottom := Top + 40;
end;
end;
{$ENDIF ASM_VERSION}
//[END NewGradientPanelEx]
{$ENDIF USE_CONSTRUCTORS}
//===================== Edit box ========================//
const Editflags: array [ TEditOption ] of Integer = (
not (ES_AUTOHSCROLL or WS_HSCROLL),
not (es_AutoVScroll or WS_VSCROLL),
es_Lowercase, es_Multiline,
es_NoHideSel, es_OemConvert, es_Password, es_Readonly,
es_UpperCase, es_WantReturn, 0, es_Number );
{$IFDEF USE_CONSTRUCTORS}
//[function NewEditbox]
function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;
begin
new( Result, CreateEditbox( AParent, Options ) );
end;
//[END NewEditbox]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewEditBox]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;
var Flags: Integer;
begin
Flags := MakeFlags( @Options, EditFlags );
if not(eoMultiline in Options) then
Flags := Flags and not(WS_HSCROLL or WS_VSCROLL);
Result := _NewControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP
or WS_BORDER or Flags, True, @EditActions );
with Result.fBoundsRect do
begin
Right := Left + 100;
Bottom := Top + 22;
if eoMultiline in Options then
begin
Right := Right + 100;
Bottom := Top + 200;
Result.fIgnoreDefault := TRUE;
end;
end;
Result.fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ];
if eoMultiline in Options then
Result.fLookTabKeys := [ tkTab ];
if eoWantTab in Options then
Result.fLookTabKeys := Result.fLookTabKeys - [ tkTab ];
end;
{$ENDIF ASM_VERSION}
//[END NewEditBox]
{$ENDIF USE_CONSTRUCTORS}
//===================== List box ========================//
const ListFlags: array[TListOption] of Integer = (
LBS_DISABLENOScroll, not LBS_ExtendedSel,
LBS_MultiColumn or WS_HSCROLL,
LBS_MultiPLESel,
LBS_NoIntegralHeight, LBS_NoSel, LBS_Sort, LBS_USETabstops,
not LBS_HASSTRINGS, LBS_NODATA, LBS_OWNERDRAWFIXED,
LBS_OWNERDRAWVARIABLE, WS_HSCROLL );
{$IFDEF USE_CONSTRUCTORS}
//[function NewListbox]
function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
begin
new( Result, CreateListbox( AParent, Options ) );
end;
//[END NewListbox]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewListbox]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
var Flags: Integer;
begin
Flags := MakeFlags( @Options, ListFlags );
Result := _NewControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP
or WS_BORDER or WS_VSCROLL
or LBS_NOTIFY or Flags, True, @ListActions );
with Result.fBoundsRect do
begin
Right := Right + 100;
Bottom := Top + 200;
end;
Result.fColor := clWindow;
Result.fLookTabKeys := [ tkTab, tkLeftRight ];
end;
{$ENDIF ASM_VERSION}
//[END NewListbox]
{$ENDIF USE_CONSTRUCTORS}
//===================== Combo box ========================//
//[FUNCTION ComboboxDropDown]
{$IFNDEF USE_DROPDOWNCOUNT}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure ComboboxDropDown( Sender: PObj );
var
CB: PControl;
IC: Integer;
begin
CB := PControl( Sender );
IC := CB.Count;
if IC > 8 then IC := 8;
if IC < 1 then IC := 1;
{$ifdef wince}
SetWindowPos( CB.Handle, 0, 0, 0, CB.Width, CB.Height * (IC + 1) + 2,
SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or
SWP_SHOWWINDOW);
{$else}
SetWindowPos( CB.Handle, 0, 0, 0, CB.Width, CB.Height * (IC + 1) + 2,
SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_NOREDRAW +
SWP_HIDEWINDOW);
SetWindowPos( CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE
+ SWP_NOZORDER + SWP_NOACTIVATE
+ SWP_NOREDRAW + SWP_SHOWWINDOW);
{$endif wince}
if assigned( CB.fOnDropDown ) then
CB.fOnDropDown( CB );
end;
{$ENDIF ASM_VERSION}
{$ELSE newcode}
procedure ComboboxDropDown( Sender: PObj );
var
CB: PControl;
Count: Integer;
DropDownCount: Integer;
ItemHeight: Integer;
begin
CB := PControl(Sender);
Count := CB.Count;
DropDownCount := CB.DropDownCount;
if (Count > DropDownCount) then
Count := DropDownCount;
if (Count < 1) then
Count := 1;
ItemHeight := CB.Perform(CB_GETITEMHEIGHT, 0, 0);
{$ifdef wince}
SetWindowPos(
CB.Handle, 0, 0, 0, CB.Width, ItemHeight * Count + CB.Height + 2,
SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_SHOWWINDOW);
{$else}
SetWindowPos(
CB.Handle, 0, 0, 0, CB.Width, ItemHeight * Count + CB.Height + 2,
SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_HIDEWINDOW);
SetWindowPos(
CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER or
SWP_NOACTIVATE or SWP_NOREDRAW or SWP_SHOWWINDOW);
{$endif wince}
if Assigned(CB.fOnDropDown) then
CB.fOnDropDown(CB);
end;
{$ENDIF USE_DROPDOWNCOUNT}
//[END ComboboxDropDown]
//[function WndFuncCombo]
function WndFuncCombo( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
: Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
var Combo, Form: PControl;
ParentWnd : HWnd;
MsgStruct: TMsg;
PrevProc:Pointer; //********************************** Added By M.Gerasimov
begin
Combo := nil;
ParentWnd := GetParent( W );
if ParentWnd <> 0 then
{$IFDEF USE_PROP}
Combo := Pointer( GetProp( ParentWnd, ID_SELF ) );
{$ELSE}
Combo := Pointer( GetWindowLong( ParentWnd, GWL_USERDATA ) );
{$ENDIF}
if Combo <> nil then
begin
MsgStruct.hwnd := Combo.fHandle;
MsgStruct.message := Msg;
MsgStruct.wParam := wParam;
MsgStruct.lParam := lParam;
Form := Combo.ParentForm;
if fGlobalProcKeybd( Combo, MsgStruct, Result ) then Exit;
if W <> Combo.FHandle then
begin
if Assigned( Applet ) and Assigned( Applet.OnMessage ) then
if Applet.OnMessage( MsgStruct, Result ) then Exit;
if (Applet <> Form) and (Form <> nil) then
if Assigned( Form.OnMessage ) then
if Form.OnMessage( MsgStruct, Result ) then Exit;
end;
if //(GetFocus = W) and
(Msg = WM_KEYDOWN) or (Msg = WM_KEYUP) or (Msg = WM_CHAR) then
begin
Result := 0;
if (wParam = VK_TAB) then
begin
case Msg of
WM_KEYDOWN:
if Assigned( Combo.fGotoControl ) and
Combo.fGotoControl( Combo, wParam, FALSE ) then Exit;
else Exit;
end;
end
else
if (Msg = WM_CHAR) and ((wParam = VK_ESCAPE) or (wParam = VK_RETURN)) then
begin
if Combo.Perform( CB_GETDROPPEDSTATE, 0, 0 ) <> 0 then
begin
Combo.Perform( CB_SHOWDROPDOWN, 0, 0 );
if wParam = VK_ESCAPE then
Combo.Perform( CB_SETCURSEL, Combo.fCurIdxAtDrop, 0 );
Combo.fWndProcKeybd( Combo, MsgStruct, Result );
Exit;
end
{$IFDEF ESC_CLOSE_DIALOGS}
//---------------------------------Babenko Alexey--------------------------
else
if (wparam = VK_ESCAPE) then
if (combo.ParentForm.ExStyle and WS_EX_DLGMODALFRAME) <> 0 then begin
SendMessage(combo.ParentForm.Handle, WM_CLOSE, 0, 0);
exit;
end;
{$ENDIF}
end;
Combo.fWndProcKeybd( Combo, MsgStruct, Result );
end
else
if Msg = WM_SETFOCUS then
begin
if Form <> nil then Form.fCurrentControl := Combo;
end;
MsgStruct.hwnd := W;
//********************************************************* Added By M.Gerasimov
PrevProc:=Pointer(GetProp( W, ID_PREVPROC ));
if PrevProc <> Nil then
Result := CallWindowProc( PrevProc , W, MsgStruct.message,
MsgStruct.wParam, MsgStruct.lParam )
else
Result:=0;
//*********************************************************
end
else
Result := DefWindowProc( W, Msg, wParam, lParam );
end;
//[PROCEDURE CreateComboboxWnd]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
procedure CreateComboboxWnd( Combo: PControl );
var W : HWND;
PrevProc: DWORD;
begin
W := GetWindow( Combo.fHandle, GW_CHILD );
{if W <> 0 then
W := GetWindow( W, GW_HWNDNEXT );}
while W <> 0 do
begin
PrevProc :=
SetWindowLong( W, GWL_WNDPROC, Longint( @WndFuncCombo ) );
SetProp( W, ID_PREVPROC, PrevProc ); //
W := GetWindow( W, GW_HWNDNEXT );
end;
end;
{$ENDIF ASM_VERSION}
//[END CreateComboboxWnd]
//[procedure RemoveChldPrevProc]
procedure RemoveChldPrevProc( fHandle: HWnd );
var Chld: HWnd;
begin
Chld := GetWindow( fHandle, GW_CHILD );
while Chld <> 0 do
begin
if GetProp( Chld, ID_PREVPROC ) <> 0 then
RemoveProp(Chld, ID_PREVPROC);
Chld := GetWindow( Chld, GW_HWNDNEXT );
end;
end;
//[function WndProcCombo]
function WndProcCombo( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
if (Msg.message >= WM_CTLCOLORMSGBOX) and (Msg.message <= WM_CTLCOLORSTATIC) then
begin
Rslt := Sender.Perform( Msg.message + CN_BASE, Msg.wParam, Msg.lParam );
Result := TRUE;
end
else
if (Msg.message >= CN_CTLCOLORMSGBOX) and (Msg.message <= CN_CTLCOLORSTATIC) then
begin
if Sender.fTransparent then
case Msg.message of
CN_CTLCOLORLISTBOX:
begin
SetBkMode( Msg.wParam, Windows.OPAQUE );
SetBkColor(Msg.WParam, Color2RGB( Sender.fColor ) );
Rslt := Global_GetCtlBrushHandle( Sender );
Result := TRUE;
end;
end;
end
else
if Msg.message = CM_COMMAND then
begin
case HiWord( Msg.wParam ) of
CBN_DROPDOWN:
begin
Sender.fDropped := True;
Sender.fCurIdxAtDrop := Sender.CurIndex;
Sender.fDropDownProc( Sender );
end;
CBN_CLOSEUP:
begin
Sender.fDropped := False;
if Assigned( Sender.fOnCloseUp ) then Sender.fOnCloseUp( Sender );
end;
CBN_SELCHANGE:
begin
PostMessage( Sender.fHandle, CM_COMMAND, CM_CBN_SELCHANGE shl 16, 0 );
end;
end;
end
else
if Msg.message = WM_DESTROY then
RemoveChldPrevProc( Sender.Handle );
end;
const ComboFlags: array[ TComboOption ] of Integer = (
CBS_DROPDOWNLIST, not CBS_AUTOHScroll,
CBS_DISABLENOSCROLL, CBS_LowerCase, CBS_NoIntegralHeight,
CBS_OemConvert, CBS_Sort, CBS_UpperCase, {$ifndef wince}
CBS_OWNERDRAWFIXED, CBS_OWNERDRAWVARIABLE, CBS_SIMPLE {$else} 0,0,0 {$endif wince} );
{$IFDEF USE_CONSTRUCTORS}
//[function NewCombobox]
function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;
begin
new( Result, CreateCombobox( AParent, Options ) );
end;
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewCombobox]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;
var Flags: Integer;
begin
Flags := MakeFlags( @Options, ComboFlags );
{$ifndef wince}
if not LongBool( Flags and CBS_SIMPLE ) then
{$endif wince}
Flags := Flags or CBS_DROPDOWN;
Result := _NewControl( AParent, 'COMBOBOX',
WS_VISIBLE
or WS_CHILD
or WS_VSCROLL
or CBS_HASSTRINGS or WS_TABSTOP
or Flags
, True, @ComboActions );
//Result.fCannotDoubleBuf := TRUE;
Result.fCreateWndExt := CreateComboboxWnd;
Result.fDropDownProc := ComboboxDropDown;
Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS;
with Result.fBoundsRect do
begin
Right := Left + 100;
Bottom := Top + 22;
end;
Result.fLookTabKeys := [ tkTab ];
if coReadOnly in Options then
Result.fLookTabKeys := [ tkTab, tkLeftRight ];
Result.AttachProc( @ WndProcCombo );
{$IFDEF USE_DROPDOWNCOUNT}
Result.DropDownCount := 8;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[END NewCombobox]
{$ENDIF USE_CONSTRUCTORS}
//[FUNCTION WndProcResiz]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
C: PControl;
begin
if Msg.message = WM_SIZE then
begin
for I:= 0 to Self_.fChildren.fCount - 1 do
begin
C := Self_.fChildren.fItems[ I ];
C.Perform( CM_SIZE, 0, 0 );
end;
end;
Result := False; // don't stop further processing
end;
{$ENDIF ASM_VERSION}
//[END WndProcResiz]
//[FUNCTION WndProcParentResize]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := False;
case Msg.message of
CM_SIZE:
begin
Self_.Perform( WM_SIZE, 0, 0 );
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcParentResize]
//[procedure InitCommonControlCommonNotify]
procedure InitCommonControlCommonNotify( Ctrl: PControl );
var AParent: PControl;
begin
Ctrl.fIsCommonControl := True;
AParent := Ctrl.Parent;
if AParent <> nil then
begin
Ctrl.AttachProc( WndProcCommonNotify );
AParent.AttachProc( WndProcNotify );
end;
end;
//[procedure InitCommonControlSizeNotify]
procedure InitCommonControlSizeNotify( Ctrl: PControl );
var AParent: PControl;
begin
AParent := Ctrl.Parent;
if AParent <> nil then
begin
Ctrl.AttachProc( WndProcParentResize );
AParent.AttachProc( WndProcResize );
end;
end;
//[function _NewCommonControl]
function _NewCommonControl( AParent: PControl; ClassName: PKOLChar; Style: DWORD;
Ctl3D: Boolean; Actions: PCommandActions ): PControl;
begin
{*************} DoInitCommonControls( ICC_WIN95_CLASSES );
Result := _NewControl( AParent, ClassName, Style, Ctl3D, Actions );
InitCommonControlCommonNotify( Result );
end;
//==================== Progress bar ======================//
{$IFDEF USE_CONSTRUCTORS}
//[function NewProgressbar]
function NewProgressbar( AParent: PControl ): PControl;
begin
new( Result, CreateProgressbar( AParent ) );
end;
//[END NewProgressbar]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewProgressbar]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewProgressbar( AParent: PControl ): PControl;
begin
Result := _NewCommonControl( AParent, PROGRESS_CLASS,
WS_CHILD or WS_VISIBLE{$ifdef wince} or WS_BORDER{$endif}, True, nil );
with Result.fBoundsRect do
begin
Right := Left + 300;
Bottom := Top + 20;
end;
Result.fMenu := 0;
Result.fTextColor := clHighlight;
{$ifdef win32}
Result.fCommandActions.aSetBkColor := PBM_SETBKCOLOR;
{$endif win32}
//Result.fNCDestroyed := TRUE; // do not call DestroyWindow!
end;
{$ENDIF ASM_VERSION}
//[END NewProgressbar]
{$ENDIF USE_CONSTRUCTORS}
{$IFDEF USE_CONSTRUCTORS}
//[function NewProgressbarEx]
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
begin
new( Result, CreateProgressbarEx( AParent, Options ) );
end;
//[END NewProgressbarEx]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewProgressbarEx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
const ProgressBarFlags: array[ TProgressbarOption ] of Integer =
(PBS_VERTICAL, PBS_SMOOTH );
begin
Result := NewProgressbar( AParent );
Result.fStyle := Result.fStyle or DWORD( MakeFlags( @Options, ProgressBarFlags ) );
end;
{$ENDIF ASM_VERSION}
//[END NewProgressbarEx]
{$ENDIF USE_CONSTRUCTORS}
//===================== List view ========================//
//[FUNCTION WndProcNotify]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NMhdr: PNMHdr;
Child: PControl;
begin
Result := False;
if Msg.message = WM_NOTIFY then
begin
NMhdr := Pointer( Msg.lParam );
{$IFDEF USE_PROP}
Child := Pointer( GetProp( NMhdr.hwndFrom, ID_SELF ) );
{$ELSE}
Child := Pointer( GetWindowLong( NMhdr.hwndFrom, GWL_USERDATA ) );
{$ENDIF}
if Child <> nil then
begin
Msg.hwnd := Child.fHandle;
Result := EnumDynHandlers( Child, Msg, Rslt );
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcNotify]
//[FUNCTION WndProcCommonNotify]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NMhdr: PNMHdr;
begin
Result := False;
if Msg.message = WM_NOTIFY then
begin
NMHdr := Pointer( Msg.lParam );
case LongInt(NMHdr.code) of
NM_RCLICK,
NM_CLICK: if assigned( Self_.fOnClick ) then
begin
Self_.fRightClick := LongInt(NMHdr.code)=NM_RCLICK;
Self_.fOnClick( Self_ );
Result := TRUE;
end;
NM_KILLFOCUS: if assigned( Self_.fOnLeave ) then
Self_.fOnLeave( Self_ );
NM_RETURN,
NM_SETFOCUS: if assigned( Self_.fOnEnter ) then
Self_.fOnEnter( Self_ );
{$ifdef wince}
NM_RECOGNIZEGESTURE:
begin
Rslt:=1;
Result:=True;
end;
{$endif wince}
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcCommonNotify]
const ListViewStyles: array[ TListViewStyle ] of DWORD = ( LVS_ICON, LVS_SMALLICON,
LVS_LIST, LVS_REPORT, LVS_REPORT or LVS_NOCOLUMNHEADER );
ListViewFlags: array[ TListViewOption ] of Integer = ( LVS_ALIGNLEFT, LVS_AUTOARRANGE,
$400 {LVS_BUTTON}, LVS_EDITLABELS, LVS_NOLABELWRAP,
LVS_NOSCROLL, LVS_NOSORTHEADER,
not LVS_SHOWSELALWAYS, not LVS_SINGLESEL, LVS_SORTASCENDING,
LVS_SORTDESCENDING, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
LVS_OWNERDATA, LVS_OWNERDRAWFIXED );
ListViewExFlags: array[ TListViewOption ] of Integer = ( 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, LVS_EX_GRIDLINES,
LVS_EX_SUBITEMIMAGES, LVS_EX_CHECKBOXES, LVS_EX_TRACKSELECT,
LVS_EX_HEADERDRAGDROP, LVS_EX_FULLROWSELECT, LVS_EX_ONECLICKACTIVATE,
{$ifdef win32}LVS_EX_TWOCLICKACTIVATE, LVS_EX_FLATSB, LVS_EX_REGIONAL,
LVS_EX_INFOTIP, LVS_EX_UNDERLINEHOT, LVS_EX_MULTIWORKAREAS,{$else}
0, 0, 0, 0, 0, 0,{$endif win32}0, 0 );
//[FUNCTION ApplyImageLists2Control]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure ApplyImageLists2Control( Sender: PControl );
var IL: PImageList;
begin
if Sender.fCommandActions.aSetImgList = 0 then Exit;
IL := Sender.ImageListNormal;
if IL <> nil then
Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_NORMAL, IL.Handle );
IL := Sender.ImageListSmall;
if IL <> nil then
Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_SMALL, IL.Handle );
IL := Sender.ImageListState;
if IL <> nil then
Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_STATE, IL.Handle );
end;
{$ENDIF ASM_VERSION}
//[END ApplyImageLists2Control]
//[FUNCTION ApplyImageLists2ListView]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure ApplyImageLists2ListView( Sender: PControl );
var Flags: DWORD;
begin
Flags := MakeFlags( @Sender.fLVOptions, ListViewFlags );
Sender.Style := Sender.Style and not $403F
or Flags or ListViewStyles[ Sender.fLVStyle ];
Flags := MakeFlags( @Sender.fLVOptions, ListViewExFlags );
Sender.Perform( LVM_SETEXTENDEDLISTVIEWSTYLE, $3FFF, Flags );
ApplyImageLists2Control( Sender );
end;
{$ENDIF ASM_VERSION}
//[END ApplyImageLists2ListView]
{$IFDEF USE_CONSTRUCTORS}
//[function NewListView]
function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
begin
new( Result, CreateListView( AParent, Style, Options, ImageListSmall,
ImageListNormal, ImageListState ) );
end;
//[END NewListView]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewListView]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
begin
Result := _NewCommonControl( AParent, WC_LISTVIEW,
ListViewStyles[ Style ] or LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE
or WS_TABSTOP or WS_CLIPCHILDREN{$ifdef wince} or WS_BORDER{$endif}
or DWORD( MakeFlags( @Options, ListViewFlags ) ),
True, @ListViewActions );
Result.fLVOptions := Options;
Result.fLVStyle := Style;
Result.fCreateWndExt := ApplyImageLists2ListView;
with Result.fBoundsRect do
begin
Right := Left + 200;
Bottom := Top + 150;
end;
Result.ImageListSmall := ImageListSmall;
Result.ImageListNormal := ImageListNormal;
Result.ImageListState := ImageListState;
Result.fLVTextBkColor := clWindow;
Result.fLookTabKeys := [ tkTab ];
//Result.fMargin := 0;
{$ifdef wince}
Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
{$endif wince}
end;
{$ENDIF ASM_VERSION}
//[END NewListView]
{$ENDIF USE_CONSTRUCTORS}
//===================== Tree view ========================//
//[FUNCTION WndProcTreeView]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NM: PNMTreeView;
DI: PTVDispInfo;
P: TPoint;
S: KOL_String;
begin
if Msg.message = WM_NOTIFY then
begin
NM := Pointer( Msg.lParam );
case LongInt(NM.hdr.code) of
NM_RCLICK:
begin
GetCursorPos( P );
P := Self_.Screen2Client( P );
PostMessage( Self_.fHandle, WM_RBUTTONUP, MK_RBUTTON or GetShiftState,
(P.x and $FFFF) or (P.y shl 16) );
end;
(*{$IFNDEF UNICODE_CTRLS}
TVN_BEGINDRAGW, TVN_BEGINRDRAGW,
{$ENDIF}*)
TVN_BEGINDRAG {$IFDEF TV_DRAG_RBUTTON}, TVN_BEGINRDRAG{$ENDIF}:
if Assigned( Self_.fOnTVBeginDrag ) then
Self_.fOnTVBeginDrag( Self_, NM.itemNew.hItem );
TVN_BEGINLABELEDIT
(*{$IFNDEF UNICODE_CTRLS}, TVN_BEGINLABELEDITW{$ENDIF}*):
begin
if Self_.fDragging
{$ifdef wince}
or ((Self_.fAutoPopupMenu <> nil) and LongBool(PMenu(Self_.fAutoPopupMenu).Flags and $1000))
{$endif wince}
then
begin
Rslt := 1; // do not allow edit while dragging
Result := TRUE;
Exit;
end;
DI := Pointer( NM );
if Assigned( Self_.fOnTVBeginEdit ) then
begin
Rslt := Integer( not Self_.fOnTVBeginEdit( Self_, DI.item.hItem ) );
if Rslt = 0 then begin
Self_.fEditing := TRUE;
{$ifdef wince}
SHSipPreference(Self_.ParentForm.fHandle, SIP_UP);
{$endif wince}
end;
Result := TRUE;
Exit;
end;
end;
TVN_ENDLABELEDIT
(*{$IFNDEF UNICODE_CTRLS}, TVN_ENDLABELEDITW {$ENDIF}*):
begin
{$ifdef wince}
SHSipPreference(Self_.ParentForm.fHandle, SIP_DOWN);
{$endif wince}
DI := Pointer( NM );
if Assigned( Self_.fOnTVEndEdit ) then
begin
S := DI.item.pszText;
if (DI.item.pszText = nil) then
begin
Self_.fEditing := FALSE;
Result := True;
Exit;
end;
if Self_.fOnTVEndEdit( Self_, DI.item.hItem, S ) then Rslt := 1
else Rslt := 0;
//Self_.TVItemText[ DI.item.hItem ] := S; // MTsVN: Чтобы можно было подредактировать NewTxt в fOnTVEndEdit
// VK: это прекрасно можно сделать в обработчике пользователя, если ему это нужно. Я так всегда и делал.
end
else
Rslt := 1;
Self_.fEditing := FALSE;
Result := True;
Exit;
end;
TVN_ITEMEXPANDING
(*{$IFNDEF UNICODE_CTRLS}, TVN_ITEMEXPANDINGW {$ENDIF}*):
begin
if Assigned( Self_.fOnTVExpanding ) then
begin
Rslt := Integer( Self_.fOnTVExpanding( Self_, NM.itemNew.hItem,
NM.action = TVE_EXPAND ) );
Result := TRUE;
Exit;
end;
end;
TVN_ITEMEXPANDED
(*{$IFNDEF UNICODE_CTRLS}, TVN_ITEMEXPANDEDW {$ENDIF}*):
if Assigned( Self_.fOnTVExpanded ) then
Self_.fOnTVExpanded( Self_, NM.itemNew.hItem, NM.action=TVE_EXPAND );
TVN_SELCHANGING
(*{$IFNDEF UNICODE_CTRLS}, TVN_SELCHANGINGW {$ENDIF}*):
begin //------------------ TVN_SELCHANGING by Sergey Shisminzev
if Assigned( Self_.fOnTVSelChanging ) then
begin
Rslt := Integer( not Self_.fOnTVSelChanging( Self_, NM.itemOld.hItem, NM.itemNew.hItem ) );
Result := TRUE;
Exit;
end;
end; //----------------------------------------
TVN_SELCHANGED
(*{$IFNDEF UNICODE_CTRLS}, TVN_SELCHANGEDW {$ENDIF}*):
Self_.DoSelChange;
end;
end;
Result := False;
end;
{$ENDIF ASM_VERSION}
//[END WndProcTreeView]
//[function ProcTVDeleteItem]
function ProcTVDeleteItem( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NM: PNMTreeView;
begin
if Msg.message = WM_NOTIFY then
begin
NM := Pointer( Msg.lParam );
case LongInt(NM.hdr.code) of
TVN_DELETEITEM:
if Assigned( Self_.fOnTVDelete ) then
Self_.fOnTVDelete( Self_, NM.itemOld.hItem );
end;
end;
Result := FALSE;
end;
//[procedure ClearTreeView]
procedure ClearTreeView( TV: PControl );
begin
TV.TVDelete( TVI_ROOT );
end;
const
TreeViewFlags: array[ TTreeViewOption ] of Integer = ( not TVS_HASLINES, TVS_LINESATROOT,
not TVS_HASBUTTONS, TVS_EDITLABELS, not TVS_SHOWSELALWAYS,
not TVS_DISABLEDRAGDROP,
{$ifdef win32}TVS_NOTOOLTIPS, TVS_CHECKBOXES, TVS_TRACKSELECT, TVS_SINGLEEXPAND,
TVS_INFOTIP, TVS_FULLROWSELECT, TVS_NOSCROLL, TVS_NONEVENHEIGHT
{$else}0, TVS_CHECKBOXES, 0, TVS_SINGLEEXPAND, 0, 0, 0, 0
{$endif win32});
{$IFDEF USE_CONSTRUCTORS}
//[function NewTreeView]
function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
ImgListNormal, ImgListState: PImageList ): PControl;
begin
new( Result, CreateTreeView( AParent, Options, ImgListNormal, ImgListState ) );
end;
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewTreeView]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
ImgListNormal, ImgListState: PImageList ): PControl;
var Flags: Integer;
begin
Flags := MakeFlags( @Options, TreeViewFlags );
Result := _NewCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or
WS_CHILD or WS_TABSTOP{$ifdef wince} or WS_BORDER{$endif}, True, @TreeViewActions );
Result.fCreateWndExt := ApplyImageLists2Control;
Result.fColor := clWindow;
Result.AttachProc( WndProcTreeView );
with Result.fBoundsRect do
begin
Right := Left + 150;
Bottom := Top + 200;
end;
Result.ImageListNormal := ImgListNormal;
Result.ImageListState := ImgListState;
Result.fLookTabKeys := [ tkTab ];
{$ifdef wince}
Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
{$endif wince}
end;
{$ENDIF ASM_VERSION}
//[END NewTreeView]
{$ENDIF USE_CONSTRUCTORS}
//===================== Tab Control ========================//
//[FUNCTION WndProcTabControl]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Hdr: PNMHdr;
A: Integer;
R: TRect;
WasActive: Boolean;
I: Integer;
{$IFDEF OLD_ALIGN}
Page: PControl;
begin
case Msg.message of
WM_NOTIFY:
begin
Hdr := Pointer( Msg.lParam );
case LongInt(Hdr.code) of
TCN_SELCHANGING:
Self_.fCurIndex := Self_.GetCurIndex;
TCN_SELCHANGE:
begin
A := {Self_.????}Self_.GetCurIndex;
WasActive := Self_.fCurIndex = A;
Self_.fCurIndex := A;
for I := 0 to Self_.Count - 1 do
begin
Page := Self_.Pages[ I ];
Page.Visible := A = I;
if A = I then
Page.BringToFront;
end;
if not WasActive then
if Assigned( Self_.fOnSelChange ) then
Self_.fOnSelChange( Self_ );
if Assigned(Self_.fGotoControl) and not Self_.Focused then begin
Self_.ParentForm.fCurrentControl:=Self_;
Self_.fGotoControl(Self_, VK_TAB, False);
end;
end;
end;
end;
WM_SIZE:
begin
R:=Self_.TC_DisplayRect;
for I := 0 to Self_.Count - 1 do
begin
Page := Self_.Pages[ I ];
Page.BoundsRect := R;
end;
{$ELSE NEW_ALIGN}
begin
case Msg.message of
WM_NOTIFY:
begin
Hdr := Pointer( Msg.lParam );
case longint(Hdr.code) of
TCN_SELCHANGING:
Self_.fCurIndex := Self_.GetCurIndex;
TCN_SELCHANGE:
begin
A := Self_.GetCurIndex;
WasActive := Self_.fCurIndex = A;
if (not WasActive)and(Self_.fCurIndex>=0) then
Self_.Pages[Self_.fCurIndex].Visible := false;
Self_.fCurIndex := A;
Self_.Pages[Self_.fCurIndex].Visible := true;
Self_.Pages[Self_.fCurIndex].BringToFront;
if not WasActive then
if Assigned( Self_.fOnSelChange ) then
Self_.fOnSelChange( Self_ );
if Assigned(Self_.fGotoControl) and not Self_.Focused then begin
Self_.ParentForm.fCurrentControl:=Self_;
Self_.fGotoControl(Self_, VK_TAB, False);
end;
end;
end;
end;
WM_SIZE:
begin
GetClientRect( Self_.fHandle, R );
Self_.fClientRight := R.Right;
Self_.fClientBottom := R.Bottom;
Self_.Perform( TCM_ADJUSTRECT, 0, Integer( @R ) );
Self_.fClientLeft := R.Left;
Self_.fClientTop := R.Top;
Dec(Self_.fClientRight,R.Right);
Dec(Self_.fClientBottom,R.Bottom);
{$ifdef wince}
with Self_^ do begin
Dec(fClientTop, fMargin + 2);
Dec(fClientLeft, fMargin + 2);
Dec(fClientRight, fMargin + 2);
Dec(fClientBottom, fMargin);
end;
{$endif wince}
// This fixes anchoring problems on invisible tabs
A := Self_.CurIndex;
R:=Self_.ClientRect;
for I := 0 to Self_.Count - 1 do
if I <> A then
Self_.Pages[ I ].BoundsRect := R;
{$ENDIF}
end;
WM_SHOWWINDOW:
if WordBool(Msg.wParam) and Self_.Focused then
PostMessage(Self_.fHandle, WM_KEYDOWN, VK_TAB, 1);
end;
Result := False;
end;
{$ENDIF ASM_VERSION}
//[END WndProcTabControl]
{$IFDEF GRAPHCTL_XPSTYLES}
{$DEFINE RICHEDIT_XPBORDER}
{$ENDIF}
{$IFDEF RICHEDIT_XPBORDER}
function WndProc_RichEditXPBorder( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var ExStyle: DWORD;
DrawRect, EmptyRect: TRect;
DC: HDC;
Details: TThemedElementDetails;
begin
Result := FALSE;
if Msg.message = WM_NCPAINT then
begin
ExStyle := GetWindowLong(Self_.Handle, GWL_EXSTYLE);
if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then
begin
GetWindowRect(Self_.Handle, DrawRect);
OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top);
DC := GetWindowDC(Self_.Handle);
//try
EmptyRect := DrawRect;
with DrawRect do
ExcludeClipRect(DC, Left + 2, Top + 2, Right - 2, Bottom - 2);
//Details := GetElementDetails(teEditTextNormal);
Details.Element := teEdit;
Details.Part := 1 {EP_EDITTEXT};
Details.State := Ord(teEditTextNormal) - Ord(teEditTextNormal) + 1;
//DrawElement(DC, Details, DrawRect);
if not Assigned( DrawThemeBackground ) then
begin
ThemeLibrary := LoadLibrary(themelib);
DrawThemeBackground := GetProcAddress(ThemeLibrary, 'DrawThemeBackground');
OpenThemeData := GetProcAddress(ThemeLibrary, 'OpenThemeData');
end;
if Assigned( DrawThemeBackground ) then
begin
Result := TRUE;
Rslt := Self_.CallDefWndProc( Msg );
with Details do
DrawThemeBackground(OpenThemeData(0, 'edit'),
DC, Part, State, DrawRect, nil);
end;
//finally
ReleaseDC(Self_.Handle, DC);
//end;
end;
end;
end;
{$ENDIF RICHEDIT_XPBORDER}
const TabControlFlags: array[ TTabControlOption ] of Integer = ( TCS_BUTTONS,
TCS_FIXEDWIDTH, not TCS_FOCUSNEVER,
TCS_FIXEDWIDTH or TCS_FORCEICONLEFT, TCS_FIXEDWIDTH or TCS_FORCELABELLEFT,
TCS_MULTILINE, TCS_MULTISELECT, TCS_RIGHTJUSTIFY, TCS_SCROLLOPPOSITE,
TCS_BOTTOM, TCS_VERTICAL, TCS_FLATBUTTONS, TCS_HOTTRACK, 0, TCS_OWNERDRAWFIXED );
{$IFDEF USE_CONSTRUCTORS}
//[function NewTabControl]
function NewTabControl( AParent: PControl; Tabs: array of String; Options: TTabControlOptions;
ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
begin
new( Result, CreateTabControl( AParent, Tabs, Options, ImgList, ImgList1stIdx ) );
end;
//[END NewTabControl]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewTabControl]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function NewTabControl( AParent: PControl; const Tabs: array of KOLString; Options: TTabControlOptions;
ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
var I, II : Integer;
Flags: Integer;
begin
Flags := MakeFlags( @Options, TabControlFlags );
if tcoFocusTabs in Options then
Flags := Flags or TCS_FOCUSONBUTTONDOWN;
Result := _NewCommonControl( AParent, WC_TABCONTROL,
Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE or WS_TABSTOP{$ifdef wince} or WS_BORDER or TCS_BOTTOM{$endif}), True,
@TabControlActions );
{$ifndef wince}
if not( tcoBorder in Options ) then
begin
Result.fExStyle := Result.fExStyle and not WS_EX_CLIENTEDGE;
end;
{$endif wince}
Result.AttachProc( WndProcTabControl );
with Result.fBoundsRect do
begin
Right := Left + 100;
Bottom := Top + 100;
end;
{$ifdef wince}
Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
{$endif wince}
if ImgList <> nil then
Result.Perform( TCM_SETIMAGELIST, 0, ImgList.Handle );
II := ImgList1stIdx;
for I := 0 to High( Tabs ) do
begin
Result.TC_Insert( I, Tabs[ I ], II );
Inc( II );
end;
Result.fLookTabKeys := [ tkTab, tkUpDown ];
end;
{$ENDIF ASM_VERSION}
//[END NewTabControl]
{$IFNDEF OLD_ALIGN}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
//[FUNCTION NewTabEmpty]
function NewTabEmpty( AParent: PControl; Options: TTabControlOptions;
ImgList: PImageList ): PControl;
var Flags: Integer;
begin
Flags := MakeFlags( @Options, TabControlFlags );
if tcoFocusTabs in Options then
Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN);
Result := _NewCommonControl( AParent, WC_TABCONTROL,
Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE), True,
@TabControlActions );
if not( tcoBorder in Options ) then
Result.fExStyle := Result.fExStyle and not WS_EX_CLIENTEDGE;
Result.AttachProc( WndProcTabControl );
with Result.fBoundsRect do begin
Right := Left + 100;
Bottom := Top + 100;
end;
if ImgList <> nil then
Result.Perform( TCM_SETIMAGELIST, 0, ImgList.Handle );
Result.fLookTabKeys := [ tkTab ];
{$ifdef wince}
Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
{$endif wince}
end;
{$ENDIF ASM_VERSION}
//[END NewTabEmpty]
{$ENDIF}
{$ENDIF USE_CONSTRUCTORS}
//===================== Tool bar ========================//
//[FUNCTION WndProcToolbarCtr]
{$IFDEF ASM_noVERSION} //TTN_NEEDTEXTW
function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
asm
CMP word ptr [EDX].TMsg.message, WM_WINDOWPOSCHANGED
JNE @@chk_CM_COMMAND
MOV dword ptr [ECX], 0 // Rslt := 0
MOV ECX, [EAX].TControl.fOnResize.TMethod.Code
JECXZ @@ret_true
XCHG EDX, EAX // Sender := Self_
MOV EAX, [EDX].TControl.fOnResize.TMethod.Data
CALL ECX // Self_.fOnResize
XOR EAX, EAX // Result := FALSE
RET
@@chk_CM_COMMAND:
CMP word ptr [EDX].TMsg.message, CM_COMMAND
JNE @@chk_WM_NOTIFY
MOVZX ECX, word ptr [EDX].TMsg.wParam
MOV [EAX].TControl.fCurItem, ECX
PUSH EAX
PUSH 0
PUSH ECX
PUSH TB_COMMANDTOINDEX
PUSH EAX
CALL TControl.Perform
PUSH EAX
PUSH VK_RETURN
CALL GetKeyState
TEST EAX, EAX
SETL DL
POP ECX
POP EAX
MOV [EAX].TControl.fCurIndex, ECX
MOV [EAX].TControl.fRightClick, DL
@@ret_false:
XOR EAX, EAX
RET
@@chk_WM_NOTIFY:
CMP word ptr [EDX].TMsg.message, WM_NOTIFY
JNE @@ret_false
MOV EDX, [EDX].TMsg.lParam
MOV ECX, [EDX].TTooltipText.hdr.code
CMP ECX, TTN_NEEDTEXT
JNE @@chk_NM_RCLICK
PUSH EAX
PUSH EDX
MOV EDX, [EDX].TTooltipText.hdr.idFrom
MOV ECX, [EAX].TControl.fTBttCmd
OR EAX, -1
JECXZ @@idxReady
XCHG EAX, ECX
CALL TList.IndexOf
@@idxReady: // EAX = -1 or index of button tooltip
TEST EAX, EAX
POP EDX
LEA EDX, [EDX].TTooltipText.szText
MOV byte ptr [EDX], 0
POP ECX
JL @@ret_true
MOV ECX, [ECX].TControl.fTBttTxt
MOV ECX, [ECX].TStrList.fList
MOV ECX, [ECX].TList.fItems
MOV EAX, [ECX+EAX*4]
XCHG EAX, EDX
XOR ECX, ECX
MOV CL, 79
CALL StrLCopy
JMP @@ret_true
@@chk_NM_RCLICK:
CMP ECX, NM_RCLICK
JNE @@chk_NM_CLICK
OR [EAX].TControl.fRightClick, 1
MOV ECX, [EDX].TNMMouse.dwItemSpec
MOV [EAX].TControl.fCurItem, -1
PUSH EAX
PUSH 0
PUSH ECX
PUSH TB_COMMANDTOINDEX
PUSH EAX
CALL TControl.Perform
POP EDX
MOV [EDX].TControl.fCurIndex, EAX
XOR EAX, EAX
RET
@@chk_NM_CLICK:
CMP ECX, NM_CLICK
JNE @@chk_TBN_DROPDOWN
MOV [EAX].TControl.fRightClick, 0
OR [EAX].TControl.fCurItem, -1
OR [EAX].TControl.fCurIndex, -1
CMP [EDX].TTBNotify.iItem, -1
SETNZ AL
RET
@@chk_TBN_DROPDOWN:
CMP ECX, TBN_DROPDOWN
JNE @@ret_false
MOV EDX, [EDX].TTBNotify.iItem
MOV [EAX].TControl.fCurItem, EDX
PUSH EAX
CALL TControl.TBItem2Index
POP EDX
MOV [EDX].TControl.fCurIndex, EAX
MOV ECX, [EDX].TControl.fOnDropDown.TMethod.Code
JECXZ @@ret_z
MOV EAX, [EDX].TControl.fOnDropDown.TMethod.Data
CALL ECX
@@ret_z:
XOR EAX, EAX
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
{$ifdef win32}
var lpttt: PTooltipText;
idBtn, Idx: Integer;
{$endif win32}
var Notify: PTBNotify;
Mouse: PNMMouse;
{$ifdef win32}
{$IFNDEF _FPC}
{$IFNDEF _D2}
var Wstr: WideString;
{$ENDIF _D2}
{$ENDIF _FPC}
{$endif win32}
begin
Result := False;
if Msg.message = WM_WINDOWPOSCHANGED then
begin
if Assigned( Self_.fOnResize ) then
Self_.fOnResize( Self_ );
//Result := TRUE; // this prevents Align working for child controls of Toolbar !
Rslt := 0;
end
else if Msg.message = CM_COMMAND then
begin
Self_.fCurItem := Loword( Msg.wParam );
Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Loword( Msg.wParam ), 0 );
Self_.fRightClick := GetKeyState( VK_RBUTTON ) < 0;
end
else if Msg.message = WM_NOTIFY then
begin
{$ifdef win32}
lpttt := Pointer( Msg.lParam );
{$endif win32}
Notify := Pointer( Msg.lParam );
case LongInt(Notify.hdr.code) of
{$ifdef win32}
TTN_NEEDTEXT:
begin
Result := True;
idBtn := lpttt.hdr.idFrom;
Idx := -1;
if Self_.fTBttCmd <> nil then
Idx := Self_.fTBttCmd.IndexOf( Pointer( idBtn ) );
lpttt.szText[ 0 ] := #0;
if Idx >= 0 then
{$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
( lpttt.szText, Self_.fTBttTxt.fList.fItems[ Idx ], 79 );
Exit;
end;
{$IFNDEF _FPC}
{$IFNDEF _D2}
TTN_NEEDTEXTW: // for Windows XP
begin
Result := True;
idBtn := lpttt.hdr.idFrom;
Idx := -1;
if Self_.fTBttCmd <> nil then
Idx := Self_.fTBttCmd.IndexOf( Pointer( idBtn ) );
FillChar( lpttt.szText[ 0 ], 160, #0 );
if Idx >= 0 then
begin
WStr := Self_.fTBttTxt.Items[ Idx ];
if WStr <> '' then
Move( Wstr[ 1 ], lpttt.szText, Min( 158, (Length( WStr ) + 1) * 2 ) );
end;
Exit;
end;
{$ENDIF _D2}
{$ENDIF _FPC}
{$endif win32}
NM_RCLICK:
begin
Mouse := Pointer( Msg.lParam );
Self_.fCurItem := Mouse.dwItemSpec;
Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Mouse.dwItemSpec, 0 );
Self_.fRightClick := GetKeyState( VK_RBUTTON ) < 0;
Self_.fRightClick := True;
end;
NM_CLICK:
begin
Self_.fCurItem := -1; // return CurItem = -1
Self_.fCurIndex := -1;
Self_.fRightClick := False;
Result := Notify.iItem <> -1; // do not handle - if it will be handled in WM_COMMAND
Exit;
end;
TBN_DROPDOWN:
begin
Self_.fCurItem := Notify.iItem;
Self_.fCurIndex := Self_.TBItem2Index( Self_.fCurItem );
if assigned( Self_.fOnDropDown ) then
Self_.fOnDropDown( Self_ );
end;
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcToolbarCtr]
const ToolbarAligns: array[ TControlAlign ] of DWORD =
( CCS_NOPARENTALIGN {or CCS_NOMOVEY} {or CCS_NORESIZE} or CCS_NODIVIDER, CCS_TOP or CCS_VERT, CCS_TOP, CCS_BOTTOM or CCS_VERT, CCS_BOTTOM,
CCS_TOP );
ToolbarOptions: array[ TToolbarOption ] of Integer = ( TBSTYLE_LIST, not TBSTYLE_LIST,
TBSTYLE_FLAT, TBSTYLE_TRANSPARENT, TBSTYLE_WRAPABLE, CCS_NODIVIDER, 0,
TBSTYLE_CUSTOMERASE );
{$IFDEF USE_CONSTRUCTORS}
//[function NewToolbar]
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
Bitmap: HBitmap; Buttons: array of PChar;
BtnImgIdxArray: array of Integer ) : PControl;
begin
new( Result, CreateToolbar( AParent, Align, Options, Bitmap, Buttons, BtnImgIdxArray ) );
end;
//[END NewToolbar]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewToolbar]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
Bitmap: HBitmap; const Buttons: array of PKOLChar;
const BtnImgIdxArray: array of Integer ) : PControl;
var Flags: DWORD;
begin
if not( tboTextBottom in Options ) then
Options := Options + [ tboTextRight ];
if tboTextRight in Options then
Options := Options - [ tboTextBottom ];
Flags := MakeFlags( @Options, ToolbarOptions );
{$ifdef wince}
if tbo3DBorder in Options then
Flags:=Flags or WS_BORDER;
{$endif}
DoInitCommonControls( ICC_BAR_CLASSES );
Result := _NewCommonControl( AParent, TOOLBARCLASSNAME,
(ToolbarAligns[ Align ] or WS_CHILD or WS_VISIBLE or TBSTYLE_TOOLTIPS
or Flags and not (TBSTYLE_FLAT or TBSTYLE_TRANSPARENT)), {!ecm}
tbo3DBorder in Options, nil );
Result.fCommandActions.aClear := ClearToolbar;
Result.fCommandActions.aGetCount := TB_BUTTONCOUNT;
Result.fIsButton := TRUE;
Result.fIgnoreDefault := TRUE;
with Result.fBoundsRect do
begin
if Align in [ caNone ] then
begin
Bottom := Top + 26;
Right := Left + 1000;
end
else
begin
Left := 0; Right := 0;
Top := 0; Bottom := 0;
end;
end;
Result.AttachProc( WndProcToolbarCtrl );
Result.AttachProc( WndProcDoEraseBkgnd );
{$ifdef wince}
Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
{$endif wince}
{$ifdef win32}
Result.Perform(TB_SETEXTENDEDSTYLE, 0, Result.Perform(TB_GETEXTENDEDSTYLE, 0, 0) or
TBSTYLE_EX_DRAWDDARROWS);
{$endif win32}
Result.Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 );
Result.Perform( TB_SETINDENT, Result.fMargin, 0 );
with Result.fBoundsRect do
begin
if Align in [ caLeft, caRight ] then
Right := Left + 24
else if not (Align in [caNone]) then
Bottom := Top + 22;
end;
if Bitmap <> 0 then
Result.TBAddBitmap( Bitmap );
Result.TBAddButtons( Buttons, BtnImgIdxArray );
Result.Perform( WM_SIZE, 0, 0 );
Result.Style := Result.Style or Flags; {+ecm}
Result.fLookTabKeys := [ tkTab ];
end;
{$ENDIF ASM_VERSION}
//[END NewToolbar]
{$ENDIF USE_CONSTRUCTORS}
//================== DateTimePicker =====================//
function WndProcDateTimePickerNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NMhdr: PNMHdr;
D: TDateTime;
AllowChg: Boolean;
NMDTString: PNMDateTimeString;
begin
Result := False;
if Msg.message = WM_NOTIFY then
begin
NMHdr := Pointer( Msg.lParam );
CASE LongInt(NMHdr.code) OF
DTN_DROPDOWN: if Assigned( Self_.fOnDropDown ) then
Self_.fOnDropDown( Self_ );
DTN_CLOSEUP: if Assigned( Self_.fOnCloseUp ) then
Self_.fOnCloseUp( Self_ );
DTN_DATETIMECHANGE:
if Assigned( Self_.fOnChange ) then
Self_.fOnChange( Self_ );
DTN_USERSTRING:
if Assigned( Self_.fOnDTPUserString ) then
begin
NMDTString := Pointer( NMHdr );
D := Self_.DateTime;
AllowChg := TRUE;
Self_.fOnDTPUserString( Self_, NMDTString.pszUserString, D, AllowChg );
NMDTString.dwFlags := Integer( not AllowChg );
end;
END;
end;
end;
const
DateTimePickerOptions: array[ TDateTimePickerOption ] of Integer = (
DTS_TIMEFORMAT, DTS_LONGDATEFORMAT, DTS_UPDOWN, DTS_RIGHTALIGN,
DTS_SHOWNONE, DTS_APPCANPARSE );
function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions )
: PControl;
var Flags: DWORD;
const
CS_OFF = {$ifdef win32}CS_OWNDC or CS_CLASSDC or {$endif}CS_PARENTDC or CS_GLOBALCLASS or
CS_VREDRAW or CS_HREDRAW;
begin
DoInitCommonControls( ICC_DATE_CLASSES );
Flags := MakeFlags( @Options, DateTimePickerOptions );
Result := _NewCommonControl( AParent, DATETIMEPICK_CLASS,
(WS_CHILD or WS_VISIBLE or WS_TABSTOP or Flags{$ifdef wince} or WS_BORDER{$endif} {or DTS_APPCANPARSE}),
TRUE, nil );
Result.SetSize( 110, 24 );
Result.AttachProc( WndProcDateTimePickerNotify );
{$ifdef wince}
Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
{$endif wince}
end;
procedure TControl.SetDateTime(Value: TDateTime);
var ST: TSystemTime;
begin
if not IsNAN( Value ) then
DateTime2SystemTime( Value, ST );
Perform( DTM_SETSYSTEMTIME, Integer( IsNAN( Value ) ) , Integer( @ ST ) );
end;
function TControl.GetDateTime: TDateTime;
var ST: TSystemTime;
begin
if Perform( DTM_GETSYSTEMTIME, 0, Integer( @ ST ) ) = GDT_VALID then
SystemTime2DateTime( ST, Result )
else
Result := NAN;
end;
function TControl.Get_SystemTime: TSystemTime;
begin
if Perform( DTM_GETSYSTEMTIME, 0, Integer( @ Result ) ) <> GDT_VALID then
FillChar( Result, Sizeof( Result ), #0 );
end;
procedure TControl.Set_SystemTime(const Value: TSystemTime);
begin
Perform( DTM_SETSYSTEMTIME, Integer( Value.wYear = 0 ) , Integer( @ Value ) );
end;
function TControl.GetDate: TDateTime;
begin
Result := DateTime;
if not IsNAN( Result ) then
Result := Trunc( DateTime );
end;
function TControl.GetTime: TDateTime;
begin
Result := DateTime;
if not IsNAN( Result ) then
Result := Frac( Result );
end;
procedure TControl.SetDate(const Value: TDateTime);
begin
if IsNAN( Value ) then
DateTime := Value
else
if not IsNAN( DateTime ) then
DateTime := Trunc( Value ) + Frac( DateTime )
else
DateTime := Trunc( Value );
end;
procedure TControl.SetTime(const Value: TDateTime);
begin
if IsNAN( Value ) then
DateTime := Value
else
if not IsNAN( DateTime ) then
DateTime := Trunc( DateTime ) + Frac( Value )
else
DateTime := 1.0 + Frac( Value );
end;
function TControl.GetDateTimeRange: TDateTimeRange;
var ST_R: array[ 0..1 ] of TSystemTime;
begin
Perform( DTM_GETRANGE, 0, Integer( @ ST_R[ 0 ] ) );
SystemTime2DateTime( ST_R[ 0 ], Result.FromDate );
SystemTime2DateTime( ST_R[ 1 ], Result.ToDate );
end;
procedure TControl.SetDateTimeRange(Value: TDateTimeRange);
var ST_R: array[ 0..1 ] of TSystemTime;
begin
DateTime2SystemTime( Value.FromDate, ST_R[ 0 ] );
DateTime2SystemTime( Value.ToDate , ST_R[ 1 ] );
Perform( DTM_SETRANGE,
Integer( IsNAN( Value.FromDate ) ) or
(Integer( IsNAN( Value.ToDate ) ) shl 1),
Integer( @ ST_R[ 0 ] ) );
end;
function TControl.GetDateTimePickerColor( Index: TDateTimePickerColor): TColor;
begin
Result := Perform( DTM_GETMCCOLOR, Integer( Index ), 0 );
end;
procedure TControl.SetDateTimePickerColor(
Index: TDateTimePickerColor; Value: TColor);
begin
Perform( DTM_SETMCCOLOR, Integer( Index ), Color2RGB( Value ) );
end;
procedure TControl.SetDateTimeFormat(const Value: KOLString);
begin
Perform( DTM_SETFORMAT, 0, Integer( PKOLChar( Value ) ) );
end;
//===================== RichEdit ========================//
{$IFNDEF NOT_USE_RICHEDIT}
type PENLink = ^TENLink;
TENLink = {$ifndef wince}packed{$endif} record
hdr: TNMHDR;
msg: DWORD;
wParam: Integer;
lParam: Integer;
chrg: TCHARRANGE;
end;
TEXTRANGEA = {$ifndef wince}packed{$endif} record
chrg: TCharRange;
lpstrText: PAnsiChar;
end;
//[FUNCTION WndProc_RE_LinkNotify]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Link: PENLink;
Range: TextRangeA;
Buffer: array[ 0..1023 ] of Char;
begin
Result := False;
if (Msg.message = WM_NOTIFY) and (PNMHdr( Msg.lParam ).code = EN_LINK) then
begin
Link := Pointer( Msg.lParam );
Range.chrg := Link.chrg;
Range.lpstrText := @Buffer[ 0 ];
Buffer[ 0 ] := #0;
Self_.Perform( EM_GETTEXTRANGE, 0, Integer( @Range ) );
if (Buffer[ 1 ] = #0) and (Range.chrg.cpMax - Range.chrg.cpMin > 1) then
Self_.fREUrl := PWideChar( @ Buffer[ 0 ] )
else
Self_.fREUrl := Buffer;
case Link.msg of
WM_MOUSEMOVE:
if assigned( Self_.fOnREOverURL ) then
Self_.fOnREOverURL( Self_ );
WM_LBUTTONDOWN, WM_RBUTTONDOWN:
if assigned( Self_.fOnREUrlClick ) then
Self_.fOnREUrlClick( Self_ );
end;
Rslt := 0;
Result := TRUE;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProc_RE_LinkNotify]
//[FUNCTION WndProcRichEditNotify]
{$IFDEF ASM_noVERSION}
function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
const int_IDC_ARROW = integer( IDC_ARROW );
asm
CMP word ptr [EDX].TMsg.message, WM_NOTIFY
JNE @@chk_WM_DESTROY
MOV EDX, [EDX].TMsg.lParam
CMP [EDX].TNMHdr.code, EN_SELCHANGE
JNE @@ret_false
CALL TControl.DoSelChange
JMP @@ret_false
@@chk_WM_DESTROY:
CMP word ptr [EDX].TMsg.message, WM_DESTROY
JNZ @@ret_false
LEA EAX, [EAX].TControl.fREUrl
CALL @LStrClr
@@ret_false:
XOR EAX, EAX
RET
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NMhdr: PNMHdr;
begin
Result := False;
if Msg.message = WM_NOTIFY then
begin
NMHdr := Pointer( Msg.lParam );
case NMHdr.code of
EN_SELCHANGE:
begin
Self_.DoSelChange;
if Self_.fTransparent then
Self_.Invalidate;
end;
end;
end
else
if Msg.message = WM_DESTROY then
begin
Self_.fREURL := '';
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcRichEditNotify]
const RichEditflags: array [ TEditOption ] of Integer = (
not (es_AutoHScroll or WS_HSCROLL),
not (es_AutoVScroll or WS_VSCROLL),
0 {es_Lowercase - not supported},
0 {es_Multiline - RichEdit always multiline},
es_NoHideSel,
0 {es_OemConvert - not suppoted},
0 {es_Password - not supported},
es_Readonly,
0 {es_UpperCase - not supported},
es_WantReturn, 0, es_Number );
{$IFDEF USE_CONSTRUCTORS}
//[function NewRichEdit1]
function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;
begin
new( Result, CreateRichEdit1( AParent, Options ) );
end;
//[END NewRichEdit1]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewRichEdit1]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;
var Flags, I, d, Last, SaveErrMode: Integer;
label search_richedit;
begin
{$IFDEF INPACKAGE}
Log( '->NewRichEdit1' );
TRY
{$ENDIF INPACKAGE}
if FRichEditModule = 0 then
begin
search_richedit:
I := RichEditIdx;
Last := High( RichEditLibnames );
d := 1;
if RichEditIdx > 0 then
begin
I := Last;
Last := 0;
d := -1;
end;
SaveErrMode := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
while I <> Last + d do
begin
FRichEditModule := LoadLibrary( RichEditLibnames[ I ] );
RichEditClass := RichEditClasses[ I ];
if FRichEditModule > HINSTANCE_ERROR then break;
inc( I, d );
end;
if FRichEditModule <= HINSTANCE_ERROR then
FRichEditModule := 0;
SetErrorMode( SaveErrMode );
end;
Flags := MakeFlags( @Options, RichEditFlags );
{$IFDEF INPACKAGE}
Log( '//// calling _NewCommonControl' );
{$ENDIF INPACKAGE}
Result := _NewCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD
or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags,
True, @RichEditActions );
{$IFDEF INPACKAGE}
Log( '//// after _NewCommonControl called' );
{$ENDIF INPACKAGE}
Result.fIgnoreDefault := TRUE;
Result.fLookTabKeys := [ tkTab ];
if eoWantTab in Options then
Result.fLookTabKeys := [ ];
Result.AttachProc( WndProcRichEditNotify );
Result.fDoubleBuffered := False;
Result.fCannotDoubleBuf := True;
with Result.fBoundsRect do
begin
Right := Right + 100;
Bottom := Top + 200;
end;
{$IFDEF INPACKAGE}
Log( '//// before Perform' );
{$ENDIF INPACKAGE}
Result.Perform( EM_SETEVENTMASK, 0,
ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or
ENM_PROTECTED or $04000000 {ENM_LINK} or ENM_KEYEVENTS );
{$IFDEF INPACKAGE}
Log( '//// after Perform' );
{$ENDIF INPACKAGE}
Result.fColor := clWindow;
Result.Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(Result.fColor));
{$IFDEF RICHEDIT_XPBORDER}
Result.AttachProc( WndProc_RichEditXPBorder );
{$ENDIF}
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-NewRichEdit1' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF ASM_VERSION}
//[END NewRichEdit1]
{$ENDIF NOT_USE_RICHEDIT}
{$ENDIF USE_CONSTRUCTORS}
{$ifdef win32}
//[API OleInitialize]
function OleInitialize(pwReserved: Pointer): HResult; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'ole32.dll' name 'OleInitialize';
procedure OleUninitialize; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'ole32.dll' name 'OleUninitialize';
//[FUNCTION OleInit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function OleInit: Boolean;
begin
if OleInitCount = 0 then
begin
Result := False;
if OleInitialize( nil ) <> 0 then Exit;
end;
Inc( OleInitCount );
Result := True;
end;
{$ENDIF ASM_VERSION}
//[END OleInit]
//[PROCEDURE OleUnInit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure OleUnInit;
begin
if OleInitCount > 0 then
begin
Dec( OleInitCount );
if OleInitCount = 0 then
OleUninitialize;
end;
end;
{$ENDIF ASM_VERSION}
//[END OleUnInit]
//[API SysAllocStringLen]
function SysAllocStringLen(psz: PWideChar; len: Integer): PWideChar; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'oleaut32.dll' name 'SysAllocStringLen';
procedure SysFreeString( psz: PWideChar ); {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'oleaut32.dll' name 'SysFreeString';
{-}
//[function StringToOleStr]
function StringToOleStr(const Source: string): PWideChar;
var
SourceLen, ResultLen: Integer;
Buffer: array[0..1023] of WideChar;
begin
SourceLen := Length(Source);
if Length(Source) < SizeOf(Buffer) div 2 then
Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,
PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))
else
begin
ResultLen := MultiByteToWideChar(0, 0,
Pointer(Source), SourceLen, nil, 0);
Result := SysAllocStringLen(nil, ResultLen);
MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,
Result, ResultLen);
end;
end;
{+}
{$endif win32}
{$IFNDEF NOT_USE_RICHEDIT}
{$IFDEF USE_CONSTRUCTORS}
//[function NewRichEdit]
function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
begin
new( Result, CreateRichEdit( AParent, Options ) );
end;
//[END NewRichEdit]
{$ELSE not_USE_CONSTRUCTORS}
//[FUNCTION NewRichEdit]
{$IFDEF ASM_VERSION}
const RichEdit50W: array[0..11] of Char = ('R','i','c','h','E','d','i','t','5','0','W',#0 );
function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
const deltaChr = 24; // sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat );
deltaPar = sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat );
asm
PUSHAD
CALL OleInit
TEST EAX, EAX
POPAD
JZ @@new1
MOV [RichEditIdx], 0
CALL NewRichEdit1
MOV byte ptr [EAX].TControl.fCharFmtDeltaSz, deltaChr
MOV byte ptr [EAX].TControl.fParaFmtDeltaSz, deltaPar
RET
@@new1: CALL NewRichEdit1
end;
{$ELSE ASM_VERSION} //Pascal
function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
begin
{$ifdef win32}
{$IFDEF INPACKAGE}
Log( '->NewRichEdit' );
TRY
{$ENDIF INPACKAGE}
if OleInit then
begin
{$IFDEF INPACKAGE}
Log( '//// OleInit OK: call NewRichEdit1' );
{$ENDIF INPACKAGE}
RichEditIdx := 0;
Result := NewRichEdit1( AParent, Options );
Result.fCharFmtDeltaSz := 24; //sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat );
// sizeof( TCharFormat2 ) is calculated incorrectly
Result.fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat );
end
else
{$endif win32}
begin
{$IFDEF INPACKAGE}
Log( '//// OleInit failed: call NewRichEdit1' );
{$ENDIF INPACKAGE}
Result := NewRichEdit1( AParent, Options );
end;
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-NewRichEdit' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF ASM_VERSION}
//[END NewRichEdit]
{$ENDIF USE_CONSTRUCTORS}
{$ENDIF NOT_USE_RICHEDIT}
//=====================================================================//
{$ENDIF WIN_GDI}
{ TControl }
//[procedure TControl.Init]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.Init;
begin
{$IFDEF _D2orD3}
inherited; // nothing here for Delphi 4 and higher
{$ENDIF}
{$IFDEF USE_GRAPHCTLS}
fDoInvalidate := InvalidateWindowed;
{$ENDIF}
{$IFDEF GDI}
fOnDynHandlers := WndProcDummy;
fWndProcKeybd := WndProcDummy;
fWndProcResizeFlicks := WndProcDummy;
fPass2DefProc := WndProcDummy;
fWndFunc := @ WndFunc;
fCommandActions.aClear := ClearText;
fWindowed := True;
fControlClick := DummyObjProc;
fAutoSize := DummyObjProc;
fColor := {$ifdef wince}clWindow{$else}clBtnFace{$endif};
fTextColor := clWindowText;
{$ENDIF GDI}
fMargin := 2;
{$IFDEF GDI}
fCtl3D := True;
fCtl3Dchild := True;
fAlphaBlend := 255;
{$ENDIF GDI}
fChildren := NewList;
{$IFDEF GDI}
{$ifdef win32}
fClsStyle := CS_OWNDC;
fExStyle := WS_EX_CONTROLPARENT;
{$endif win32}
fStyle := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or WS_BORDER
{$ifdef win32} or WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or
WS_THICKFRAME {$endif};
{$ENDIF GDI}
fVisible := True;
fEnabled := True;
fDynHandlers := NewList;
end;
{$ENDIF ASM_VERSION}
//[PROCEDURE CallTControlInit]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.InitParented( AParent: PControl );
begin
Init;
if AParent <> nil then
fColor := AParent.fColor;
Parent := AParent;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.InitParented( AParent: PControl; widget: PGtkWidget;
need_eventbox: Boolean );
begin
Init;
fHandle := widget;
fCaptionHandle := fHandle;
fEventboxHandle := fHandle;
if need_eventbox then
begin
fEventboxHandle := gtk_event_box_new();
gtk_widget_set_events( fEventboxHandle, GDK_ALL_EVENTS_MASK );
//gtk_container_add( GTK_CONTAINER( AParent.fHandle ), fEventboxHandle );
gtk_widget_show( fEventboxHandle );
gtk_container_add( GTK_CONTAINER( fEventboxHandle ), fHandle );
end;
g_object_set_data( G_OBJECT( fEventboxHandle ), ID_SELF, @ Self );
if AParent <> nil then
fColor := AParent.fColor;
Parent := AParent;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[destructor TControl.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TControl.Destroy;
var I: Integer;
F: PControl;
Ico: HIcon;
begin
{$IFDEF USE_CUSTOMEXTENSIONS}
{$I CUSTOM_TCONTROL_DESTROY.INC}
{$ENDIF}
{$IFDEF USE_MHTOOLTIP}
{$DEFINE destroy}
{$I KOLMHToolTip.pas}
{$UNDEF destroy}
{$ENDIF USE_MHTOOLTIP}
{$IFDEF DEBUG}
TRY
F := ParentForm; // or Applet - for form ???
EXCEPT
asm
nop
end;
END;
{$ELSE}
F := ParentForm; // or Applet - for form ???
{$ENDIF}
if F <> nil then
if F.FCurrentControl = @Self then
F.FCurrentControl := nil;
if FHandle <> 0 then
ShowWindow( fHandle, SW_HIDE );
Final;
{$IFDEF USE_AUTOFREE4CHILDREN}
{$ELSE}
DestroyChildren;
{$ENDIF}
if not fDestroying then
begin
fDestroying := True;
if fCtlClsNameChg then
begin
FreeMem( fControlClassName );
fCtlClsNameChg := FALSE;
end;
{$IFDEF USE_AUTOFREE4CONTROLS}
{$ELSE}
fFont.Free;
fFont := nil;
fBrush.Free;
fBrush := nil;
{$ENDIF}
fCanvas.Free;
fCanvas := nil;
if fHandle <> 0 then
begin
{$IFNDEF NEW_MENU_ACCELL}
{$IFDEF USE_AUTOFREE4CONTROLS}
{$ELSE}
if fAccelTable <> 0 then
begin
DestroyAcceleratorTable( fAccelTable );
fAccelTable := 0;
end;
{$ENDIF}
{$ENDIF}
{$IFDEF USE_AUTOFREE4CONTROLS}
{$ELSE}
fMenuObj.Free;
while fImageList <> nil do
fImageList.Free;
{$ENDIF}
I := fHandle;
Ico := fIcon;
if (Ico <> 0) and (Ico <> HIcon(-1)) then
if not fIconShared then
DestroyIcon( Ico );
if IsWindow( I ) then
begin
// RemoveProp( I, ID_SELF ); //************** Remarked By M.Gerasimov
if not fNCDestroyed then
begin
{$IFDEF DEBUG_ENDSESSION}
if EndSession_Initiated then
LogFileOutput( GetStartDir + 'es_debug.txt',
'DESTROYING HWND:' + Int2Str( I ) );
{$ENDIF}
//if fIsForm then
{$IFDEF USE_PROP}
SetProp( I, ID_SELF, 0 );
{$ELSE}
SetWindowLong( I, GWL_USERDATA, 0 );
{$ENDIF}
DestroyWindow( I );
end;
end;
fHandle := 0;
end;
if fCustomData <> nil then
FreeMem( fCustomData );
fCustomData := nil;
fCustomObj.Free;
fCustomObj := nil;
if fTmpBrush <> 0 then
DeleteObject( fTmpBrush );
fTmpBrush := 0;
//if FCaption <> nil then FreeMem( FCaption );
fCaption := '';
if fStatusTxt <> nil then
FreeMem( fStatusTxt );
if fParent <> nil then
begin
fParent.fChildren.Remove( @Self );
{$IFDEF USE_AUTOFREE4CHILDREN}
fParent.RemoveFromAutoFree( @ Self );
{$ENDIF}
if fParent.fCurrentControl = @Self then
fParent.fCurrentControl := nil;
end;
fChildren.Free;
{$IFDEF USE_AUTOFREE4CONTROLS}
{$ELSE}
fTBttCmd.Free;
fTBttTxt.Free;
fTmpFont.Free;
{$ENDIF}
fDynHandlers.Free;
//fREUrl := '';
inherited;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF USE_MHTOOLTIP}
{$DEFINE code}
{$I KOLMHToolTip.pas}
{$UNDEF code}
{$ENDIF}
//[procedure TControl.SetEnabled]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetEnabled( Value: Boolean );
begin
if GetEnabled = Value then Exit;
fEnabled := Value;
if Value then
fStyle := fStyle and not WS_DISABLED
else
fStyle := fStyle or WS_DISABLED;
if fHandle <> 0 then
EnableWindow( fHandle, fEnabled );
Invalidate; // necessary for Graphic controls
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetParentWindow]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetParentWindow: HWnd;
begin
Result := 0;
if fParent = nil then Exit;
Result := fParent.GetWindowHandle;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetWindowHandle: HWnd;
begin
{$IFDEF INPACKAGE}
Log( '->TControl.GetWindowHandle' );
TRY
{$ENDIF INPACKAGE}
if fHandle = 0 then
begin
if not fCreateVisible then
begin
Set_Visible( False );
CreateWindow; //virtual!!!
fCreateHidden := True;
end
else
CreateWindow; //virtual!!!
end;
Result := fHandle;
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-TControl.GetWindowHandle' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF ASM_VERSION}
{-}
{$IFDEF _D7orHigher}
// may be it was a good idea to replace CreateWindowEx,
// but Inprise forget about {$ifdef wince}cdecl{$else}stdcall{$endif}... In result, asm-version became broken.
//[API CreateWindowEx]
{$IFNDEF UNICODE_CTRLS}
function CreateWindowEx(dwExStyle: DWORD; lpClassName: PChar;
lpWindowName: PChar; dwStyle: DWORD; X, Y, nWidth, nHeight: Integer;
hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: Pointer): HWND;
{$ifdef wince}cdecl{$else}stdcall{$endif}; external user32 name 'CreateWindowExA';
{$ENDIF}
{$ENDIF}
{$IFDEF DEBUG_CREATEWINDOW}
procedure Debug_CreateWindow1( _Self: PControl );
begin
{LogFileOutput( GetStartDir + 'Session.log', 'TControl.CreateWindow, ' +
' Self = ' + Int2Str( Integer( _Self ) ) +
' Caption = ' + _Self.fCaption +
' fChildren = ' + Int2Hex( Integer( _Self.fChildren ), 4 ) +
' ChildCount = ' + Int2Str( _Self.ChildCount ) );}
end;
procedure Debug_CreateWindow2( _Self: PControl; const Params: TCreateWndParams );
begin
LogFileOutput( GetStartDir + 'Session.log',
' ExStyle=' + Int2Hex( Params.ExStyle, 4 ) +
' WinClassName=' + Params.WinClassName +
' Caption=' + Params.Caption +
' Style=' + Int2Hex( Params.Style, 4 ) +
' X=' + Int2Str( Params.X ) +
' Y=' + Int2Str( Params.Y ) +
' Width=' + Int2Str( Params.Width ) +
' Height=' + Int2Str( Params.Height ) +
//' WndParent=' + Int2Str( Params.WndParent ) +
' Parent=' + Int2Hex( DWORD( _Self.Parent ), 6 ) +
' Menu=' + Int2Str( Params.Menu ) +
' hInstance=' + Int2Str( Params.WindowClass.hInstance ) +
' Param=' + Int2Str( Integer( Params.Param ) ) +
' WindowClass.style:' + Int2Str( Params.WindowClass.style ) +
' WindowClass.lpfnWndProc:' + Int2Str( DWORD( Pointer( Params.WindowClass.lpfnWndProc ) ) ) +
' WindowClass.cbClsExtra:' + Int2Str( DWORD( Params.WindowClass.cbClsExtra ) ) +
' WindowClass.cbWndExtra:' + Int2Str( DWORD( Params.WindowClass.cbWndExtra ) ) +
' WindowClass.hInstance:' + Int2Str( Params.WindowClass.hInstance ) +
' WindowClass.hIcon:' + Int2Str( Params.WindowClass.hIcon ) +
' WindowClass.hCursor:' + Int2Str( Params.WindowClass.hCursor ) +
' WindowClass.hbrBackground:' + Int2Str( Params.WindowClass.hbrBackground ) +
' WindowClass.lpszMenuName:' + Params.WindowClass.lpszMenuName +
' WindowClass.lpszClassName:' + Params.WindowClass.lpszClassName
);
end;
{$ENDIF DEBUG_CREATEWINDOW}
{+}
//[function TControl.CreateWindow]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TControl.CreateWindow: Boolean;
const
CS_OFF = {$ifdef win32}CS_OWNDC or CS_CLASSDC or {$endif} CS_PARENTDC or CS_GLOBALCLASS;
CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;
var TempClass: TWndClass;
Params: TCreateWndParams;
ClassRegistered: Boolean;
{$IFDEF _FPC}
SClassName: String;
{$ENDIF ASM_VERSION}
{$ifdef wince}
DR: TRect;
mbi: SHMENUBARINFO;
{$endif wince}
begin
{$IFDEF INPACKAGE}
Log( '->TControl.CreateWindow' );
TRY
{$ENDIF INPACKAGE}
{$IFDEF DEBUG_CREATEWINDOW}
Debug_CreateWindow1( @ Self );
{$ENDIF DEBUG_CREATEWINDOW}
Result := False;
if fParent <> nil then
if fParent.GetWindowHandle = 0 then
Exit;
if fHandle <> 0 then
begin
if fCreateHidden then
begin
CreateChildWindows;
Set_Visible( True );
fCreateHidden := False;
end
else
begin
CreateChildWindows;
end;
Result := True;
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit;
end;
{$IFDEF USE_GRAPHCTLS}
if not fWindowed then Exit;
{$ENDIF}
{$IFDEF INPACKAGE}
Log( '/// Filling Params' );
{$ENDIF INPACKAGE}
FillChar( Params, Sizeof( Params ), 0 );
{$ifndef wince}
Params.WindowClass.hCursor := LoadCursor( 0, IDC_ARROW );
{$endif wince}
Params.WindowClass.hInstance := hInstance;
Params.WindowClass.lpfnWndProc := fDefWndProc;
Params.WindowClass.style := fClsStyle;
{$IFDEF _FPC}
SClassName := SubClassName;
StrCopy( Params.WinClsNamBuf, @ SClassName[ 1 ] );
{$ELSE}
{$IFNDEF UNICODE_CTRLS}
StrCopy( Params.WinClsNamBuf, @ SubClassName[ 1 ] );
{$ELSE}
WStrCopy(Params.WinClsNamBuf, @SubClassName[1]);
{$ENDIF}
{$ENDIF}
Params.Param := nil;
Params.Inst := hInstance;
Params.Menu := fMenu;
Params.WndParent := GetParentWnd( TRUE );
Params.Height := fBoundsRect.Bottom - fBoundsRect.Top;
if Params.Height = 0 then
Params.Height := CW_UseDefault;
Params.Width := fBoundsRect.Right - fBoundsRect.Left;
if Params.Width = 0 then
Params.Width := CW_UseDefault;
Params.Y := fBoundsRect.Top;
Params.X := fBoundsRect.Left;
if not fIsControl and (fChangedPosSz and 3 = 0) then
begin
Params.Y := CW_UseDefault;
Params.X := CW_UseDefault;
end;
{$ifdef wince}
if fIsForm then begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @DR, 0);
if Params.X = Integer(CW_UseDefault) then
Params.X:=DR.Left;
if Params.Y = Integer(CW_UseDefault) then
Params.Y:=DR.Top;
if Params.Width = Integer(CW_UseDefault) then
Params.Width:=DR.Right - Params.X;
if Params.Height = Integer(CW_UseDefault) then
Params.Height:=ScreenHeight - Params.Y;
end;
{$endif wince}
Params.Style := fStyle;
Params.Caption := PKOLChar( fCaption );
Params.WinClassName := @ Params.WinClsNamBuf[ 0 ];
Params.ExStyle := fExStyle;
{$IFDEF INPACKAGE}
Log( '/// Getting class info' );
{$ENDIF INPACKAGE}
{$ifndef wince}
if fControlClassName <> nil then
begin
GetClassInfo( Params.Inst,fControlClassName,Params.WindowClass );
Params.WindowClass.hInstance := Params.Inst;
Params.WindowClass.style := Params.WindowClass.style and
not CS_OFF or CS_ON;
end;
{$endif wince}
if (fDefWndProc = nil) {$ifdef wince} and GetClassInfo(Params.Inst,fControlClassName,Params.WindowClass)
and (ptruint(@Params.WindowClass.lpfnWndProc) and $FFFFFF <> ptruint(@WndFunc)) {$endif}
then
fDefWndProc := {$ifdef FPC}@{$endif}Params.WindowClass.lpfnWndProc;
if Params.WndParent = 0 then
if Params.Style and WS_CHILD <> 0 then Exit;
ClassRegistered := GetClassInfo( Params.Inst,Params.WinClassName, TempClass );
{$IFDEF INPACKAGE}
Log( '/// Registering window class' );
{$ENDIF INPACKAGE}
if not ClassRegistered then
begin
Params.WindowClass.lpszClassName := Params.WinClassName;
Params.WindowClass.lpfnWndProc := @ WndFunc;
if RegisterClass( Params.WindowClass ) = 0 then Exit;
end;
{$IFDEF DEBUG_CREATEWINDOW}
Debug_CreateWindow2( @ Self, Params );
{$ENDIF}
{$ifdef wince}
if fDefWndProc = nil then
{$endif wince}
CreatingWindow := @Self;
{$IFDEF INPACKAGE}
Log( '/// Calling CreateWindowEx' );
{$ENDIF INPACKAGE}
{$IFNDEF UNICODE_CTRLS}
fHandle := CreateWindowEx( Params.ExStyle, Params.WinClassName,
Params.Caption, Params.Style, Params.X, Params.Y,
Params.Width, Params.Height, Params.WndParent,
Params.Menu, Params.Inst,
Params.Param );
{$ELSE}
fHandle := CreateWindowExW( Params.ExStyle{ or WS_EX_RTLREADING}, Params.WinClassName,
Params.Caption, Params.Style, Params.X, Params.Y,
Params.Width, Params.Height, Params.WndParent,
Params.Menu, Params.Inst,
Params.Param );
{$ENDIF}
{$IFDEF INPACKAGE}
Log( '/// CreateWindowEx called' );
{$ENDIF INPACKAGE}
{$ifdef wince}
if fDefWndProc <> nil then
SetWindowLong(fHandle, GWL_WNDPROC, LongInt(@WndFunc));
if not fIsControl then
if fMenuObj <> nil then
CeSetMenu(fHandle, PMenu(fMenuObj))
else
if CePlatform <> cpSmartphone then begin
FillChar(mbi, SizeOf(mbi), 0);
with mbi do begin
cbSize:=SizeOf(mbi);
hwndParent:=fHandle;
dwFlags:=SHCMBF_EMPTYBAR;
end;
if SHCreateMenuBar(@mbi) then begin
GetWindowRect(mbi.hwndMB, DR);
if Params.Y + Params.Height > DR.Top then
SetWindowPos(fHandle, 0, 0, 0, Params.Width, DR.Top - Params.Y, SWP_NOZORDER or SWP_NOREPOSITION or SWP_NOMOVE);
end;
end;
if fStyle and WS_VISIBLE <> 0 then
Perform(WM_SHOWWINDOW, 1, 0);
{$endif wince}
{$IFDEF DEBUG_CREATEWINDOW}
if fHandle = 0 then
begin
MessageBox(0,
PKOLChar(SysErrorMessage(GetLastError)),
'Error creating window',mb_iconhand);
Exit;
end;
{$ENDIF}
{$IFDEF INPACKAGE}
Log( '/// SendMessage WM_UPDATEUISTATE' );
{$ENDIF INPACKAGE}
{$ifndef wince}
SendMessage( fHandle, $0128 {WM_UPDATEUISTATE},
2 {UIS_CLEAR} or (1 {UISF_HIDEFOCUS} shl 16),0);
{$endif wince}
{$IFDEF USE_PROP}
if GetProp(FHandle,ID_SELF) = 0 then
begin
CreatingWindow := nil;
SetProp(FHandle, ID_SELF, THandle(@Self));
end;
{$ELSE}
CreatingWindow := nil;
SetWindowLong( FHandle, GWL_USERDATA, Integer(@Self) );
{$ENDIF}
//***
{$IFDEF INPACKAGE}
Log( '/// Perform WM_SETICON' );
{$ENDIF INPACKAGE}
{$IFDEF SMALLEST_CODE}
{$ELSE}
{$ifndef wince}
if not fIsControl then
Perform( WM_SETICON, 1 {ICON_BIG}, GetIcon );
{$endif wince}
{$ENDIF}
if Assigned( FCreateWndExt ) then
FCreateWndExt( @Self );
{$IFDEF INPACKAGE}
Log( '/// ApplyFont2Wnd' );
{$ENDIF INPACKAGE}
ApplyFont2Wnd;
{$IFDEF INPACKAGE}
Log( '/// CreateChildWindows' );
{$ENDIF INPACKAGE}
CreateChildWindows;
{$IFDEF INPACKAGE}
Log( '/// CreateChildWindows called OK' );
{$ENDIF INPACKAGE}
Result := True;
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-TControl.CreateWindow' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF}
{$ENDIF WIN_GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.VisualizyWindow;
var i: Integer;
C: PControl;
begin
if fHandle = nil then Exit;
if not fIsApplet and FVisible then
begin
for i := 0 to ChildCount-1 do
begin
C := Children[ i ];
if C.fVisible then
C.VisualizyWindow;
end;
gtk_widget_show( fHandle );
end;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//-
//[procedure TControl.CreateSubclass]
procedure TControl.CreateSubclass(var Params: TCreateParams;
ControlClassName: PKOLChar);
const
CS_OFF = {$ifdef win32}CS_OWNDC or CS_CLASSDC or {$endif} CS_PARENTDC or CS_GLOBALCLASS;
CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;
var
SaveInstance: THandle;
begin
if fControlClassName <> nil then
with Params do
begin
SaveInstance := WindowClass.hInstance;
// {$IFNDEF UNICODE_CTRLS}
if not GetClassInfo(HInstance, fControlClassName, WindowClass) and
not GetClassInfo(0, fControlClassName, WindowClass)
then
GetClassInfo(WindowClass.hInstance, fControlClassName, WindowClass);
// {$ELSE}
// if not GetClassInfoW(HInstance, pWideChar(fControlClassName), WindowClass) and
// not GetClassInfoW(0, pWidechar(fControlClassName), WindowClass)
// then
// GetClassInfoW(WindowClass.hInstance, pWideChar(fControlClassName), WindowClass);
// {$ENDIF}
WindowClass.hInstance := SaveInstance;
WindowClass.style := WindowClass.style and not CS_OFF or CS_ON;
end;
end;
//[FUNCTION WndProcMouse]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcMouse(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var MouseData: TMouseEventData;
begin
Result := False;
if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= $20A {WM_MOUSELAST}) then
with MouseData do
begin
Shift := Msg.wParam;
if GetKeyState( VK_MENU ) < 0 then
Shift := Shift or MK_ALT;
X := LoWord( Msg.lParam );
Y := HiWord( Msg.lParam );
//Button := TMouseButton(Msg.wParam);
// not possible: wParam can contain a combination of flags
// MK_CONTROL, MK_LBUTTON, MK_RBUTTON, MK_MBUTTON, MK_SHIFT, MK_XBUTTON1, MK_XBUTTON2
// So, Shift must be tested.
Button := mbNone;
StopHandling := FALSE;
Rslt := 0; // needed ?
case Msg.message of
WM_LBUTTONDOWN:
if Assigned( Self_.OnMouseDown ) then
begin
Button := mbLeft;
Self_.OnMouseDown( Self_, MouseData );
end;
WM_RBUTTONDOWN:
if Assigned( Self_.OnMouseDown ) then
begin
Button := mbRight;
Self_.OnMouseDown( Self_, MouseData );
end;
WM_MBUTTONDOWN:
if Assigned( Self_.OnMouseDown ) then
begin
Button := mbMiddle;
Self_.OnMouseDown( Self_, MouseData );
end;
WM_LBUTTONUP:
if Assigned( Self_.OnMouseUp ) then
begin
Button := mbLeft;
Self_.OnMouseUp( Self_, MouseData );
end;
WM_RBUTTONUP:
if Assigned( Self_.OnMouseUp ) then
begin
Button := mbRight;
Self_.OnMouseUp( Self_, MouseData );
end;
WM_MBUTTONUP:
if Assigned( Self_.OnMouseUp ) then
begin
Button := mbMiddle;
Self_.OnMouseUp( Self_, MouseData );
end;
WM_MOUSEMOVE:
if Assigned( Self_.OnMouseMove ) then
Self_.OnMouseMove( Self_, MouseData );
WM_LBUTTONDBLCLK:
if Assigned( Self_.OnMouseDblClk ) then
begin
Button := mbLeft;
Self_.OnMouseDblClk( Self_, MouseData );
end;
WM_RBUTTONDBLCLK:
if Assigned( Self_.OnMouseDblClk ) then
begin
Button := mbRight;
Self_.OnMouseDblClk( Self_, MouseData );
end;
WM_MBUTTONDBLCLK:
if Assigned( Self_.OnMouseDblClk ) then
begin
Button := mbMiddle;
Self_.OnMouseDblClk( Self_, MouseData );
end;
$020A {WM_MOUSEWHEEL}:
if Assigned( Self_.OnMouseWheel ) then
Self_.OnMouseWheel( Self_, MouseData );
else
Exit; //Result := False;
end;
Result := StopHandling;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcMous]
//[FUNCTION WndProcKeybd]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function WndProcKeybd(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var C : KOLChar;
begin
Result := True;
case Msg.message of
WM_KEYDOWN, WM_SYSKEYDOWN:
if assigned( Self_.fOnKeyDown ) then
Self_.fOnKeyDown( Self_, Msg.wParam, GetShiftState );
WM_KEYUP, WM_SYSKEYUP:
if assigned( Self_.fOnKeyUp ) then
Self_.fOnKeyUp( Self_, Msg.wParam, GetShiftState );
WM_CHAR, WM_SYSCHAR:
if assigned( Self_.fOnChar ) then
begin
C := KOLChar( Msg.wParam );
Self_.fOnChar( Self_, C, GetShiftState );
Msg.wParam := Integer( C );
end;
{$IFDEF SUPPORT_ONDEADCHAR}
WM_DEADCHAR, WM_SYSDEADCHAR:
if assigned( Self_.fOnDeadChar ) then
begin
C := KOLChar( Msg.wParam );
Self_.fOnDeadChar( Self_, C, GetShiftState );
Msg.wParam := Integer( C );
end;
{$ENDIF SUPPORT_ONDEADCHAR}
else begin
Result := False;
Exit;
end;
end;
if Msg.wParam <> 0 then
Result := False;
end;
{$ENDIF ASM_VERSION}
//[END WndProcKeybd]
//[function WndProcDummy]
function WndProcDummy(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
begin
Result := False;
end;
const
MM_MCINOTIFY = $3B9;
function WndProcOnClose( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
var Accept: Boolean;
begin
Result := FALSE;
if Msg.message = WM_CLOSE then
begin
{$IFDEF NEW_MODAL}
// version of code by Alexander Pravdin
begin
Accept := True;
if Assigned( Sender.fOnClose ) then begin
Sender.fOnClose( Sender, Accept );
if AppletRunning then
if Accept then
if Sender.fModal > 0 then begin
if Sender.ModalResult = 0 then
Sender.fModalResult := Integer($80000000);
Msg.message := 0;
Exit;
end
else
Sender.fOnClose := nil
else begin
Rslt := 0;
Sender.fModalResult := 0;
Result := TRUE;
end
else
Sender.fOnClose := nil;
end
else begin
if Sender.fModal > 0 then begin
if Sender.ModalResult = 0 then
Sender.fModalResult := Integer($80000000);
Exit;
end;
end;
if Accept then begin
if Sender.IsMainWindow or ( Applet = Sender ) then
begin
{if Assigned( Applet ) and ( Applet <> Sender ) then
Applet.Perform( WM_CLOSE, 0, 0 );}
PostQuitMessage( 0 );
Rslt := 0;
end
else
Exit; // Default;
end;
end;
{$ELSE}
begin
Accept := True;
if Assigned( Sender.fOnClose ) then
begin
Sender.fOnClose( Sender, Accept );
if (not Accept) and (AppletRunning) then
begin
Rslt := 0;
Result := TRUE;
end
else //+-+
Sender.fOnClose := nil;
end;
if Accept then
begin
if Sender.IsMainWindow or (Applet = Sender) then
begin
{if Assigned( Applet ) and (Applet <> Sender) then
Applet.Perform( WM_CLOSE, 0, 0 );}
PostQuitMessage( 0 );
Rslt := 0;
end
else
Exit; //Default;
end;
end;
{$ENDIF}
end;
end;
procedure TControl.SetOnClose(const AOnClose: TOnEventAccept);
begin
fOnClose := AOnClose;
AttachProc( WndProcOnClose );
end;
function WndProcFormOnClick( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_LBUTTONDBLCLK) or
(Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_RBUTTONDBLCLK) or
(Msg.message = WM_MBUTTONDOWN) or (Msg.message = WM_MBUTTONDBLCLK)
then
begin
Sender.fRightClick := (Msg.message = WM_RBUTTONDOWN) or
(Msg.message = WM_RBUTTONDBLCLK);
if Assigned( Sender.fOnClick ) then
Sender.fOnClick( Sender );
end;
end;
procedure TControl.SetFormOnClick(const AOnClick: TOnEvent);
begin
fOnClick := AOnClick;
AttachProc( WndProcFormOnClick );
end;
{$IFDEF ASM_VERSION}//------------------
{$DEFINE ASM_LOCAL}
{$IFDEF NEW_MODAL}
{$UNDEF ASM_LOCAL}
{$ENDIF}
{$ELSE}//-------------------------------
{$IFDEF ASM_LOCAL}
{$UNDEF ASM_LOCAL}
{$ENDIF}
{$ENDIF}//------------------------------
{$IFDEF USE_GRAPHCTLS}
{$UNDEF ASM_LOCAL}
{$ENDIF}
//[function TControl.WndProc]
{$IFDEF ASM_LOCAL}
{$ELSE ASM_LOCAL} //Pascal
{$IFDEF DEBUG_CREATEWINDOW}
var DbgCWCount: Integer = 0;
{$ENDIF DEBUG_CREATEWINDOW}
function TControl.WndProc( var Msg: TMsg ): Integer;
var C : PControl;
F: HWnd;
PassFun: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
procedure Default;
begin
Result := CallDefWndProc( Msg );
end;
begin
{$IFDEF INPACKAGE}
Log( '->TControl.WndProc' );
TRY
{$ENDIF INPACKAGE}
{$IFDEF DEBUG_CREATEWINDOW}
Inc( DbgCWCount );
if DbgCWCount < 10 then
LogFileOutput( GetStartDir + 'Session.log', 'TControl.WndProc: ' +
' Msg.hwnd=' + Int2Str( Msg.hwnd ) +
' Msg.message=' + Int2Hex( Msg.message, 2 ) +
' Msg.wParam=' + Int2Str( Msg.wParam ) + '=$' + Int2Hex( Msg.wParam, 4 ) +
' Msg.lParam=' + Int2Str( Msg.lParam ) + '=$' + Int2Hex( Msg.lParam, 4 ) );
{$ENDIF DEBUG_CREATEWINDOW}
if (Msg.hwnd <> 0) and (fHandle = 0)
{$IFDEF USE_GRAPHCTLS} and fWindowed {$ENDIF} then
fHandle := Msg.hwnd;
{$IFDEF DEBUG_MCK} mck_Log( '01' ); {$ENDIF}
PassFun := fPass2DefProc;
{$IFDEF DEBUG_MCK} mck_Log( '01' ); {$ENDIF}
if not (AppletRunning and (Applet <> @Self) and Assigned( Applet ) and
Assigned( Applet.OnMessage ) and Applet.OnMessage( Msg, Result )) then
begin {$IFDEF DEBUG_MCK} mck_Log( '02' ); {$ENDIF}
if not (Assigned( OnMessage ) and OnMessage( Msg, Result )) then
begin {$IFDEF DEBUG_MCK} mck_Log( '03' ); {$ENDIF}
if not fOnDynHandlers( @Self, Msg, Result ) then
begin {$IFDEF DEBUG_MCK} mck_Log( '04' ); {$ENDIF}
if not fWndProcResizeFlicks( @Self, Msg, Result ) then
begin {$IFDEF DEBUG_MCK} mck_Log( '05' ); {$ENDIF}
case Msg.message of
WM_CLOSE:
begin // handler by default - simple:
if (Applet = @ Self) or IsMainWindow then begin
PostQuitMessage( 0 );
{$ifdef wince}
Result:=0;
exit;
{$endif wince}
end;
Default;
end;
{$IFDEF USE_PROP}
WM_NCDESTROY:
begin
RemoveProp( fHandle, ID_SELF ); //********* Added By M.Gerasimov
end;
{$ENDIF}
WM_DESTROY:
begin
fBeginDestroying := TRUE;
Default;
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit;
end;
{$ifdef wince}
WM_WINDOWPOSCHANGED:
begin
Default;
{ In case of subclassing, DefWindowProc must be called on wince
to generate WM_SIZE and WM_MOVE messages }
if fDefWndProc <> nil then
Result:=DefWindowProc(Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam);
exit;
end;
{$endif wince}
WM_SIZE: begin
{$IFDEF INPACKAGE}
Log( 'WM_SIZE >>> Default' );
{$ENDIF INPACKAGE}
Default;
{$IFDEF INPACKAGE}
Log( '//// Default called' );
{$ENDIF INPACKAGE}
fWindowState := TWindowState( Msg.wParam );
{$IFDEF OLD_ALIGN}
if not fIsForm then
Global_Align( fParent );
{$ENDIF}
{$IFDEF INPACKAGE}
Log( '//// Before Global_Align' );
{$ENDIF INPACKAGE}
Global_Align( @Self );
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit;
end;
{$ifndef wince}
WM_SysCommand:
begin
if ((Msg.wParam and $FFF0) = SC_MINIMIZE) and
IsMainWindow and (@Self <> Applet) then
begin
PostMessage( Applet.Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0 );
Result := 0;
end
else Default;
end;
{$endif wince}
WM_SETFOCUS:
begin
if not DoSetFocus then
begin
Result := 0;
end
else
begin
Inc( fClickDisabled );
Default;
Dec( fClickDisabled );
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit;
end;
end;
WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
begin
Result := SendMessage(Msg.LParam, CN_BASE + Msg.message, Msg.WParam, Msg.LParam);
end;
WM_COMMAND:
begin
{$IFDEF USE_PROP}
C := Pointer( GetProp( Msg.lParam, ID_SELF ) );
{$ELSE}
C := Pointer( GetWindowLong( Msg.lParam, GWL_USERDATA ) );
{$ENDIF}
if C <> nil then
begin
Result := SendMessage( Msg.lParam, CM_COMMAND, Msg.wParam, Msg.lParam );
end
else Default;
end;
WM_KEYFIRST..WM_KEYLAST:
begin
F := GetFocus;
if (F <> fFocusHandle) and (F <> fHandle)
{$IFDEF USE_GRAPHCTLS} and fWindowed {$ENDIF}
{$IFDEF KEY_PREVIEW}
and not (fKeyPreviewing (*and
((Msg.Message=WM_KEYDOWN) {or (Msg.message = WM_CHAR) )*))
{$ENDIF}
then
begin
Result := 0;
// Jump to PassFun here. Prevents beep in case when WM_KEYDOWN
// called another form and focus is changed, so WM_KEYUP failed
// to handle.
end
else
begin
{$IFDEF KEY_PREVIEW}
fkeypreviewing:=false; //ADDITION JUST FOR CORRECT KEYPREVIEWING
{$ENDIF}
if fGlobalProcKeybd( @Self, Msg, Result ) then
begin
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit; //??????????????????
end;
if fWndProcKeybd( @Self, Msg, Result ) then
begin
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit; //???????????????????
end;
if ((GetKeystate( VK_CONTROL ) or GetKeyState( VK_MENU )) >= 0) then
begin
//+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
if (Msg.message <> WM_CHAR) // v1.02 Tabulate AND " in EditBox fix
//+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
then
begin
C := ParentForm;
if (C <> nil) and Assigned(C.fGotoControl) and
C.fGotoControl( @Self, Msg.wParam,
(Msg.message <> WM_KEYDOWN) and
(Msg.message <> WM_SYSKEYDOWN) ) then
begin
Msg.wParam := 0;
Result := 0;
end
else Default;
end
//+++++++++++++++++++++++++++++++++++++++++++++//
else //
if Msg.wParam = 9 then // prevent system beep //
begin //
Msg.wParam := 0; //
Result := 0; //
end //
//+++++++++++++++++++++++++++++++++++++++++++++//
else Default;
end
else Default;
end;
end;
else begin
{$IFDEF DEBUG_MCK} mck_Log( 'else' ); {$ENDIF}
Default; //+-+
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit; //+-+
end;
end;
end;
end;
end;
end;
{$IFDEF DEBUG_MCK} mck_Log( '06' ); {$ENDIF}
if not AppletTerminated and not fNCDestroyed then
begin {$IFDEF DEBUG_MCK} mck_Log( '07' ); {$ENDIF}
PassFun( @Self, Msg, Result ); //+-+
{$IFDEF DEBUG_MCK} mck_Log( '08' ); {$ENDIF}
end;
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-TControl.WndProc' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF ASM_LOCAL}
//[END TContro]
{$UNDEF ASM_LOCAL}
{$ENDIF WIN_GDI}
//[procedure SetMouseEvent]
{$IFDEF GDI}
procedure SetMouseEvent( Self_: PControl );
begin
Self_.AttachProc( WndProcMouse );
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function mouse_events_handler( Obj: PGtkWidget; var Event: TGdkEventAny ): Boolean; cdecl;
var Sender: PControl;
M: TMouseEventData;
procedure PrepareMouseEvent( const Evt: TGdkEventMotion );
begin
M.Button := mbNone;
if Evt.state and GDK_BUTTON1_MASK <> 0 then M.Button := mbLeft
else
if Evt.state and GDK_BUTTON2_MASK <> 0 then M.Button := mbRight
else
if Evt.state and GDK_BUTTON3_MASK <> 0 then M.Button := mbMiddle;
M.Shift := 0;
if Evt.state and GDK_SHIFT_MASK <> 0 then M.Shift := MK_SHIFT;
if Evt.state and GDK_CONTROL_MASK <> 0 then M.Shift := M.Shift or MK_CONTROL;
if Evt.state and GDK_LOCK_MASK <> 0 then M.Shift := M.Shift or MK_LOCK;
if Evt.state and GDK_BUTTON1_MASK <> 0 then M.Shift := M.Shift or MK_LBUTTON;
if Evt.state and GDK_BUTTON2_MASK <> 0 then M.Shift := M.Shift or MK_RBUTTON;
if Evt.state and GDK_BUTTON3_MASK <> 0 then M.Shift := M.Shift or MK_MBUTTON;
if Evt.state and GDK_LOCK_MASK <> 0 then M.Shift := M.Shift or MK_LOCK;
M.X := Round( Evt.x );
M.Y := Round( Evt.y );
end;
var scrl: PGdkEventScroll;
z: SmallInt;
begin
Result := FALSE;
//Sender := Pointer( Event.window );
Sender := g_object_get_data( G_OBJECT( Obj ), ID_SELF );
CASE Event._type OF
GDK_MOTION_NOTIFY,
GDK_BUTTON_PRESS,
GDK_2BUTTON_PRESS,
GDK_3BUTTON_PRESS, // тройной клик мыши - считать как двойной?
GDK_BUTTON_RELEASE,
GDK_SCROLL: ;
else Exit;
END;
PrepareMouseEvent( PGdkEventMotion( @ Event )^ );
CASE Event._type OF
GDK_MOTION_NOTIFY :
begin
if Assigned( Sender.fOnMouseMove ) then
begin
Sender.fOnMouseMove( Sender, M );
Result := TRUE;
end;
end;
GDK_BUTTON_PRESS :
begin
if Assigned( Sender.fOnMouseDown ) then
begin
Sender.fOnMouseDown( Sender, M );
Result := TRUE;
end;
end;
GDK_2BUTTON_PRESS,
GDK_3BUTTON_PRESS :
begin
if Assigned( Sender.fOnMouseDblClk ) then
begin
Sender.f3ButtonPress := Event._type = GDK_3BUTTON_PRESS;
Sender.fOnMouseDblClk( Sender, M );
Result := TRUE;
end;
end;
GDK_BUTTON_RELEASE :
begin
if Assigned( Sender.fOnMouseUp ) then
begin
Sender.fOnMouseUp( Sender, M );
Result := TRUE;
end;
if Assigned( Sender.fOnClick ) then
Sender.fOnClick( Sender );
end;
GDK_SCROLL :
begin
if Assigned( Sender.fOnMouseWheel ) then
begin
scrl := @ Event;
if scrl.direction = GDK_SCROLL_UP then
z := 120
else if scrl.direction = GDK_SCROLL_DOWN then
z := -120 //todo: direction and value?
else
z := 0;
M.Shift := M.Shift or DWord(z shl 16);
Sender.fOnMouseWheel( Sender, M );
Result := TRUE;
end;
end;
END;
end;
procedure SetMouseEvent( Self_: PControl; event_name: PChar );
begin
gtk_signal_connect( GTK_OBJECT( Self_.fEventboxHandle ), event_name,
@mouse_events_handler, Self_ );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TControl.SetOnMouseDown]
{$IFDEF GDI}
procedure TControl.SetOnMouseDown(const Value: TOnMouse);
begin
fOnMouseDown := Value;
SetMouseEvent( @Self );
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetOnMouseDown(const Value: TOnMouse);
begin
fOnMouseDown := Value;
SetMouseEvent( @Self, 'button_press_event' );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
//[procedure TControl.SetOnMouseMove]
procedure TControl.SetOnMouseMove(const Value: TOnMouse);
begin
fOnMouseMove := Value;
SetMouseEvent( @Self );
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetOnMouseMove(const Value: TOnMouse);
begin
fOnMouseMove := Value;
SetMouseEvent( @Self, 'motion_notify_event' );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TControl.SetOnMouseUp]
{$IFDEF GDI}
procedure TControl.SetOnMouseUp(const Value: TOnMouse);
begin
fOnMouseUp := Value;
SetMouseEvent( @Self );
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetOnMouseUp(const Value: TOnMouse);
begin
fOnMouseUp := Value;
SetMouseEvent( @Self, 'button_release_event' );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TControl.SetOnMouseDblClk]
{$IFDEF GDI}
procedure TControl.SetOnMouseDblClk(const Value: TOnMouse);
begin
fOnMouseDblClk := Value;
SetMouseEvent( @Self );
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetOnMouseDblClk(const Value: TOnMouse);
begin
fOnMouseDblClk := Value;
SetMouseEvent( @Self, 'button_press_event' );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TControl.SetOnMouseWheel]
{$IFDEF GDI}
procedure TControl.SetOnMouseWheel(const Value: TOnMouse);
begin
fOnMouseWheel := Value;
SetMouseEvent( @Self );
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetOnMouseWheel(const Value: TOnMouse);
begin
fOnMouseWheel := Value;
SetMouseEvent( @Self, 'scroll_event' );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[procedure TControl.SetClsStyle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetClsStyle( Value: DWord );
begin
if fClsStyle = Value then Exit;
fClsStyle := Value;
if fHandle = 0 then Exit;
SetClassLong( fHandle, GCL_STYLE, Value );
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetStyle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetStyle( Value: DWord );
begin
if fStyle = Value then Exit;
fStyle := Value;
if fHandle = 0 then Exit;
SetWindowLong( fHandle, GWL_STYLE, Value );
SetWindowPos( fHandle, 0, 0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or
SWP_NOZORDER or SWP_FRAMECHANGED );
Invalidate;
end;
{$ENDIF ASM_VERSION}
{$IFDEF GRAPHCTL_XPSTYLES}
procedure TControl.SetEdgeStyle( Value: TEdgeStyle );
begin
if fedgeStyle = Value then Exit;
fedgeStyle := Value;
if fHandle = 0 then Exit;
case Value of
esRaised:
begin
Style := Style and (not SS_SUNKEN);
ExStyle := ExStyle and (not WS_EX_STATICEDGE);
ExStyle := ExStyle or WS_EX_WINDOWEDGE;
Style := Style or WS_DLGFRAME;
end;
esLowered:
begin
Style := Style and (not WS_DLGFRAME);
ExStyle := ExStyle or WS_EX_WINDOWEDGE;
ExStyle := ExStyle or WS_EX_STATICEDGE;
Style := Style or SS_SUNKEN;
end;
else
Style := Style and (not SS_SUNKEN) and (not WS_DLGFRAME);
ExStyle := ExStyle and (not WS_EX_STATICEDGE) or WS_EX_WINDOWEDGE;
end;
Invalidate;
end;
{$ENDIF}
//[procedure TControl.SetExStyle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetExStyle( Value: DWord );
begin
if fExStyle = Value then Exit;
fExStyle := Value;
if fHandle = 0 then Exit;
SetWindowLong( fHandle, GWL_EXSTYLE, Value );
SetWindowPos( fHandle, 0, 0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or
SWP_NOZORDER or SWP_FRAMECHANGED );
Invalidate;
end;
{$ENDIF ASM_VERSION}
function WndProcSetCursor( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Cur: HCursor;
begin
Result := FALSE;
if Msg.message = WM_SETCURSOR then
begin
if (GetCapture = 0) and
(LOWORD( Msg.lParam ) = HTCLIENT) then
begin
if ScreenCursor <> 0 then //YS
Cur := ScreenCursor //YS
else //YS
Cur := Self_.fCursor; //YS
if Cur <> 0 then //YS
begin //YS
Windows.SetCursor( Cur ); //YS
Rslt := 1; //YS
Result := TRUE;
end;
end;
end;
end;
//[procedure TControl.SetCursor]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetCursor( Value: HCursor );
var P: TPoint;
begin
AttachProc( WndProcSetCursor );
if fCursor = Value then Exit;
fCursor := Value;
if (fHandle = 0) or (fCursor = 0) then Exit; //YS
if ScreenCursor <> 0 then Exit;
GetCursorPos( P );
P := Screen2Client( P );
if PointInRect( P, ClientRect ) then
Windows.SetCursor( Value );
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.CursorLoad]
procedure TControl.CursorLoad(Inst: Integer; ResName: PKOLChar);
begin
Cursor := LoadCursor( Inst, ResName );
fCursorShared := TRUE;
end;
//[procedure TControl.SetIcon]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetIcon( Value: HIcon );
var OldIco: HIcon;
begin
if fIcon = Value then Exit;
fIcon := Value;
if Value = THandle(-1) then
Value := 0;
OldIco := Perform( WM_SETICON, 1 {ICON_BIG}, Value );
if OldIco <> 0 then
DestroyIcon( OldIco );
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetMenu]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetMenu( Value: HMenu );
begin
if fMenu = Value then Exit;
if fMenuObj <> nil then
begin
{$IFDEF USE_AUTOFREE4CONTROLS}
RemoveFromAutoFree( fMenuObj );
{$ENDIF}
Free_And_Nil(fMenuObj);
end;
if fMenu <> 0 then
DestroyMenu( fMenu );
fMenu := Value;
if fHandle = 0 then Exit;
{$ifdef wince}
if Value = 0 then
CeSetMenu(fHandle, nil);
{$else}
Windows.SetMenu( fHandle, Value );
{$endif wince}
end;
{$ENDIF ASM_VERSION}
//[procedure CallWinHelp]
procedure CallWinHelp( Context: Integer; CtxCtl: PControl );
{$ifdef wince}
begin
{$else}
var Cmd: Integer;
Form: PControl;
Popup: Boolean;
begin
Cmd := HELP_CONTEXT;
if CtxCtl <> nil then
begin
Form := CtxCtl.ParentForm;
if Form <> nil then
if Assigned( Form.OnHelp ) then
begin
Popup := FALSE;
Form.OnHelp( CtxCtl, Context, Popup );
if Popup then
Cmd := HELP_CONTEXTPOPUP;
if CtxCtl = nil then Exit;
end;
end
else
if Context = 0 then
Cmd := HELP_CONTENTS;
WinHelp( Applet.Handle, PKOLChar( Applet.GetHelpPath ), Cmd, Context );
{$endif wince}
end;
var HHCtrl: THandle;
HtmlHelp: procedure( Wnd: HWnd; Path: PChar; Cmd, Data: Integer ); {$ifdef wince}cdecl{$else}stdcall{$endif};
//[procedure HtmlHelpCommand]
procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: String; Cmd, Data: Integer );
begin
if HHCtrl = 0 then
HHCtrl := LoadLibrary( 'HHCTRL.OCX' );
if HHCtrl = 0 then Exit;
if not Assigned( HtmlHelp ) then
HtmlHelp := GetProcAddress( HHCtrl, 'HtmlHelpA' );
if not Assigned( HtmlHelp ) then Exit;
HtmlHelp( Wnd, PChar( HelpFilePath ), Cmd, Data );
end;
//[procedure CallHtmlHelp]
procedure CallHtmlHelp( Context: Integer; CtxCtl: PControl );
var Cmd: Integer;
Form: PControl;
Popup: Boolean;
Ids: array[ 0..2 ] of DWORD;
begin
Cmd := $F; // HH_HELP_CONTEXT;
if CtxCtl <> nil then
begin
Form := CtxCtl.ParentForm;
if Form <> nil then
if Assigned( Form.OnHelp ) then
begin
Popup := FALSE;
Form.OnHelp( CtxCtl, Context, Popup );
if Popup then
begin
Cmd := $10; //HH_TP_HELPCONTEXTMENU;
Ids[ 0 ] := CtxCtl.fMenu;
Ids[ 1 ] := Context;
Ids[ 2 ] := 0;
Context := Integer( @ Ids );
end;
if CtxCtl = nil then Exit;
end;
end
else
if Context = 0 then
Cmd := 1; // HH_DISPLAY_TOC;
//ShowMessage( Int2Str( Cmd ) + ' ' + Int2Str( Context ) );
HtmlHelpCommand( {$IFDEF HTMLHELP_NOTOP} 0 {$ELSE} Applet.Handle {$ENDIF},
HelpFilePath, Cmd, Context );
end;
var
Global_HelpProc: procedure( Context: Integer; CtxCtl: PControl ) = CallWinHelp;
//[function WndProcHelp]
function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var HI: PHelpInfo;
Ctx: Integer;
Ctl: PControl;
begin
Result := FALSE;
if Msg.message = WM_HELP then
begin
Ctx := 0;
Ctl := nil;
HI := Pointer( Msg.lParam );
if HI.iContextType = HELPINFO_WINDOW then
begin
{$IFDEF USE_PROP}
Ctl := Pointer( GetProp( HI.hItemHandle, ID_SELF ) );
{$ELSE}
Ctl := Pointer( GetWindowLong( HI.hItemHandle, GWL_USERDATA ) );
{$ENDIF}
while Ctl <> nil do
begin
Ctx := Ctl.fHelpContext;
if Ctx <> 0 then break;
Ctl := Ctl.Parent;
end;
end
else
{$ifdef win32}Ctx := GetMenuContextHelpID( HI.hItemHandle ){$endif};
Applet.CallHelp( Ctx, Ctl );
Rslt := 1;
Result := TRUE;
end
{$IFDEF AUTO_CONTEXT_HELP}
else
if (Msg.message = WM_CONTEXTMENU) then
begin
{$IFDEF USE_PROP}
Ctl := Pointer( GetProp( Msg.wParam, ID_SELF ) );
{$ELSE}
Ctl := Pointer( GetWindowLong( Msg.wParam, GWL_USERDATA ) );
{$ENDIF}
if (Ctl <> nil) and (Ctl.fHelpContext <> 0) then
begin
Applet.CallHelp( Ctl.fHelpContext, Ctl );
Rslt := 1;
Result := TRUE;
end;
end
{$ENDIF};
end;
//[procedure TControl.SetHelpContext]
procedure TControl.SetHelpContext(Value: Integer);
var F: PControl;
begin
fHelpContext := Value;
F := ParentForm;
if F = nil then Exit;
F.AttachProc( WndProcHelp );
{$ifdef win32}
SetWindowContextHelpId( GetWindowHandle, Value );
{$endif win32}
end;
//[function TControl.AssignHelpContext]
function TControl.AssignHelpContext(Context: Integer): PControl;
begin
SetHelpContext( Context );
Result := @ Self;
end;
//[procedure AssignHtmlHelp]
procedure AssignHtmlHelp( const HtmlHelpPath: KOLString );
begin
Assert( (HtmlHelpPath <> '') and (Applet <> nil), 'Error parameters' );
if HelpFilePath <> '' then
FreeMem( HelpFilePath );
GetMem( HelpFilePath, (Length( HtmlHelpPath ) + 1) * Sizeof( KOLChar ) );
StrCopy( HelpFilePath, @ HtmlHelpPath[ 1 ] );
Global_HelpProc := CallHtmlHelp;
Applet.AttachProc( WndProcHelp );
end;
//[procedure TControl.CallHelp]
procedure TControl.CallHelp(Context: Integer; CtxCtl: PControl {; CtlID: Integer} );
begin
Global_HelpProc( Context, CtxCtl {, CtlID} );
end;
//[function TControl.GetHelpPath]
function TControl.GetHelpPath: KOLString;
begin
Result := HelpFilePath;
if Result = '' then
begin
Result := ParamStr( 0 );
Result := ReplaceFileExt( Result, '.hlp' );
end;
end;
//[procedure TControl.SetHelpPath]
procedure TControl.SetHelpPath(const Value: KOLString);
begin
Assert( Value <> '', 'Error parameter' );
if HelpFilePath <> '' then
FreeMem( HelpFilePath );
GetMem( HelpFilePath, (Length( Value ) + 1)*Sizeof( KOLChar ) );
StrCopy( HelpFilePath, @ Value[ 1 ] );
end;
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}
{$ELSE}
procedure TControl.DoAutoSize;
begin
if Assigned( fAutoSize ) then
fAutoSize( @Self );
end;
{$ENDIF}
{$IFDEF GDI}
{$IFDEF ASM_UNICODE}
//[function TControl.GetCaption]
function TControl.GetCaption: KOLString;
asm
PUSH EBX
PUSH EDI
XCHG EBX, EAX
MOV EDI, EDX
CMP [EBX].fIgnoreWndCaption, 0
JNZ @@getFCaption
MOV ECX, [EBX].fHandle
JECXZ @@getFCaption
@@getWndCaption:
PUSH ECX
CALL GetWindowTextLength
PUSH EAX
XCHG EDX, EAX
LEA EAX, [EBX].fCaption
CALL System.@LStrSetLength
POP ECX
JECXZ @@getFCaption
INC ECX
PUSH ECX
PUSH [EBX].fCaption
PUSH [EBX].fHandle
CALL GetWindowText
@@getFCaption:
MOV EDX, [EBX].fCaption
XCHG EAX, EDI
{$IFNDEF UNICODE_CTRLS}
CALL System.@LStrAsg
{$ELSE}
CALL System.@WStrFromPChar
{$ENDIF}
@@exit:
POP EDI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TControl.GetCaption: KOLString;
var Sz: Integer;
begin
if not fIgnoreWndCaption and (FHandle <> 0) then
begin
Sz := GetWindowTextLength( FHandle );
SetLength( fCaption, Sz );
if Sz > 0 then
begin
{$IFNDEF UNICODE_CTRLS}
GetWindowText( FHandle, @ fCaption[ 1 ], Sz + 1 );
{$ELSE}
GetWindowTextW( FHandle, @ fCaption[ 1 ], Sz + 1 );
{$ENDIF}
end;
end;
Result := FCaption;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TControl.GetCaption: KOLString;
begin
if not fIgnoreWndCaption {and (FHandle <> 0)} then
FCaption := fGetCaption(@Self);
Result := FCaption;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
//[procedure TControl.SetCaption]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetCaption( const Value: KOLString );
begin
fCaption := Value;
if fHandle <> 0 then
SendMessage( fHandle, WM_SETTEXT,
0, Integer( PKOLChar( Value ) ) );
if fIsStaticControl <> 1 then
Invalidate;
DoAutoSize;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetCaption( const Value: KOLString );
begin
fCaption := Value;
if Assigned( fSetCaption ) then fSetCaption( @Self, Value );
DoAutoSize;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[function TControl.GetVisible]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION}
function TControl.GetVisible: Boolean;
begin
if (fHandle <> 0) then
fVisible := IsWindowVisible( fHandle )
else
fVisible := (FStyle and WS_VISIBLE) <> 0;
Result := fVisible;
end;
{$ENDIF ASM_VERSION}
//[function TControl.Get_Visible]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} // Pascal
function TControl.Get_Visible: Boolean;
begin
if (fHandle <> 0) and not fIsControl then
fVisible := IsWindowVisible( fHandle );
Result := fVisible;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.Set_Visible]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} // Pascal
procedure TControl.Set_Visible( Value: Boolean );
{$IFDEF OLD_ALIGN}
var CmdShow: DWORD;
begin
//if Get_Visible <> Value then // commented to allow to set up controls visibility
begin // on invisible form (Vladimir Piven)
if Value then
begin
fStyle := fStyle or WS_VISIBLE;
CmdShow := SW_SHOW;
end
else
begin
fStyle := fStyle and not WS_VISIBLE;
CmdShow := SW_HIDE;
end;
fVisible := Value;
if fHandle = 0 then Exit;
{$ifdef wince}
Perform(WM_SHOWWINDOW, WPARAM(WordBool(Value)), 0);
{$endif wince}
ShowWindow( fHandle, CmdShow );
Global_Align( fParent );
if Value then
Global_Align( @Self );
end;
if not Value and (fHandle <> 0) then
fCreateHidden := FALSE; // { +++ }
{$ELSE NEW_ALIGN}
begin
fStyle := fStyle and not WS_VISIBLE;
if Value then
fStyle := fStyle or WS_VISIBLE;
fVisible := Value;
if fHandle = 0 then Exit;
{$ifdef wince}
Perform(WM_SHOWWINDOW, WPARAM(WordBool(Value)), 0);
{$endif wince}
if Value then begin
Global_Align( @Self );
ShowWindow( fHandle, SW_SHOW );
end else begin
fCreateHidden := FALSE; // { +++ }
ShowWindow( fHandle, SW_HIDE );
Global_Align( @Self );
end;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetVisible]
procedure TControl.SetVisible( Value: Boolean );
begin
fCreateVisible := TRUE;
Set_Visible( Value );
end;
{$ENDIF WIN_GDI}
//[function TControl.GetBoundsRect]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetBoundsRect: TRect;
var W: PControl;
P: TPoint;
begin
Result := fBoundsRect;
if fHandle <> 0 then
begin
GetWindowRect( fHandle, Result );
if fIsControl or fIsMDIChild then
begin
W := fParent; // WindowedParent;
if W <> nil then
begin
P.x := 0; P.y := 0;
P := W.Client2Screen( P );
OffsetRect( Result, -P.x, -P.y );
end;
end;
{$IFDEF TEST_BOUNDSRECT}
if not CompareMem( @ fBoundsRect, @ Result, Sizeof( TRect ) ) then
{$ENDIF}
fBoundsRect := Result;
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TControl.GetBoundsRect: TRect;
var R: TRect;
window: PGtkWindow;
requisition: TGtkRequisition;
begin
//if fHandle <> nil then
begin
if fIsControl then
begin
R.Left := fBoundsRect.Left;
R.Top := fBoundsRect.Top;
gtk_widget_get_size_request( fEventboxHandle, @ R.Right, @ R.Bottom );
gtk_widget_size_request( fHandle, @ requisition );
if R.Right < 0 then R.Right := requisition.width;
if R.Bottom < 0 then R.Bottom := requisition.height;
end
else
begin
window := GTK_WINDOW( fHandle );
gtk_window_get_position(window, @ R.Left, @ R.Top);
gtk_window_get_size(window, @ R.Right, @ R.Bottom);
end;
inc( R.Right, R.Left );
inc( R.Bottom, R.Top );
fBoundsRect := R;
end;
Result := fBoundsRect;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
//[procedure TControl.SetBoundsRect]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetBoundsRect( const Value: TRect );
var Rect: TRect;
Flags: DWORD;
cx, cy: integer;
begin
Rect := GetBoundsRect;
if RectsEqual( Value, Rect ) then Exit;
{$ifdef wince}
if fIsForm and (fChangedPosSz = 0) then
Style:=Style or WS_BORDER or WS_CAPTION or WS_SYSMENU;
fChangedPosSz := fChangedPosSz or $C;
{$endif wince}
if Value.Left <> fBoundsRect.Left then fChangedPosSz := fChangedPosSz or 1;
if Value.Top <> fBoundsRect.Top then fChangedPosSz := fChangedPosSz or 2;
{$IFDEF USE_GRAPHCTLS}
if not fWindowed then
Invalidate;
{$ENDIF}
fBoundsRect := Value;
if fHandle <> 0 then
with fBoundsRect do begin
Flags:=SWP_NOZORDER or SWP_NOACTIVATE;
cx:=Right - Left;
cy:=Bottom - Top;
if (Rect.Right - Rect.Left = cx) and (Rect.Bottom - Rect.Top = cy) then
Flags:=Flags or SWP_NOSIZE
else
if (Left = Rect.Left) and (Top = Rect.Top) then
Flags:=Flags or SWP_NOMOVE;
SetWindowPos( fHandle, 0, Left, Top, cx, cy, Flags );
if fSizeRedraw and (Flags and SWP_NOSIZE = 0) then
Invalidate;
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetBoundsRect( const Value: TRect );
var Rect: TRect;
window: PGtkWindow;
begin
Rect := GetBoundsRect;
if RectsEqual( Value, Rect ) then Exit;
if Value.Left <> fBoundsRect.Left then fChangedPosSz := fChangedPosSz or 1;
if Value.Top <> fBoundsRect.Top then fChangedPosSz := fChangedPosSz or 2;
fBoundsRect := Value;
Rect := Value;
if fIsControl then
begin
//gtk_widget_set_uposition( fHandle, Rect.Left, Rect.Top );
if fParent <> nil then
fParent.fChildSetPos( fParent, @ Self, Rect.Left, Rect.Top );
if (Rect.Right > Rect.Left) and (Rect.Bottom > Rect.Top) then
gtk_widget_set_size_request( fEventboxHandle,
Rect.Right - Rect.Left, Rect.Bottom - Rect.Top );
end
else
begin
window := GTK_WINDOW( fHandle );
gtk_window_move( window, Rect.Left, Rect.Top );
gtk_window_resize( window, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top );
end;
//if fSizeRedraw then
// Invalidate;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
const
WindowStateShowCommands: array[TWindowState] of Byte =
(SW_SHOWNOACTIVATE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
//[procedure TControl.SetWindowState]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetWindowState( Value: TWindowState );
begin
if fWindowState <> Value then
begin
fWindowState := Value;
ShowWindow(GetWindowHandle, WindowStateShowCommands[Value]);
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.Show]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.Show;
begin
CreateWindow;
SetVisible( True );
SetForegroundWindow( Handle );
DoSetFocus;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.Hide]
procedure TControl.Hide;
begin
SetVisible( False );
end;
//[function TControl.Client2Screen]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.Client2Screen( const P: TPoint ): TPoint;
begin
Result := P;
if fHandle <> 0 then
Windows.ClientToScreen( fHandle, Result );
end;
{$ENDIF ASM_VERSION}
//[function TControl.Screen2Client]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.Screen2Client( const P: TPoint ): TPoint;
begin
Result := P;
if Handle <> 0 then
Windows.ScreenToClient( Handle, Result );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[function TControl.ClientRect]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.ClientRect: TRect;
begin
Result := fBoundsRect;
GetWindowHandle;
if (fHandle <> 0) then
GetClientRect( fHandle, Result );
Inc( Result.Top, fClientTop );
Dec( Result.Bottom, fClientBottom );
Inc( Result.Left, fClientLeft );
Dec( Result.Right, fClientRight );
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TControl.ClientRect: TRect; //todo: implement exact, now for PaintBox only
begin
Result := fBoundsRect;
OffsetRect( Result, -Result.Left, -Result.Top );
Inc( Result.Top, fClientTop );
Dec( Result.Bottom, fClientBottom );
Inc( Result.Left, fClientLeft );
Dec( Result.Right, fClientRight );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TControl.Invalidate]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE PAS_VERSION}
procedure TControl.Invalidate;
begin
{$IFDEF USE_GRAPHCTLS}
fDoInvalidate;
{$ELSE}
if fHandle <> 0 then
InvalidateRect( fHandle, nil, TRUE );
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.Invalidate;
begin
gtk_widget_queue_draw_area( fHandle, 0, 0, Width, Height );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
{$IFDEF USE_GRAPHCTLS}
procedure TControl.InvalidateNonWindowed;
var R: TRect;
begin
R := BoundsRect;
if fParent.fHandle <> 0 then
InvalidateRect( fParent.fHandle, @ R, TRUE );
end;
//[procedure TControl.InvalidateWindowed]
{$IFDEF ASM_VERSION}
{$ELSE PAS_VERSION}
procedure TControl.InvalidateWindowed;
begin
if fHandle <> 0 then
InvalidateRect( fHandle, nil, TRUE );
end;
{$ENDIF ASM_VERSION}
{$ENDIF USE_GRAPHCTLS}
//[function TControl.GetIcon]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetIcon: HIcon;
begin
Result := fIcon;
if Result = THandle( -1 ) then
begin
Result := 0;
Exit;
end;
if Result = 0 then
if (Assigned( Applet )) and
(@Self <> Applet) then
begin
Result := Applet.Icon;
{$ifdef wince}
fIconShared := TRUE;
{$else}
if Result <> 0 then
Result := CopyImage( Result, IMAGE_ICON, 0, 0, 0 );
{$endif}
end
else
begin
Result := LoadIcon( hInstance,
{$IFDEF CUSTOM_APPICON}
{$I CusomAppIconRsrcName_PAS.inc} // create such file with 'your icon rsrc name'
{$ELSE} 'MAINICON' {$ENDIF} );
end;
fIcon := Result;
end;
{$ENDIF ASM_VERSION}
//*
//[procedure TControl.IconLoad]
procedure TControl.IconLoad(Inst: Integer; ResName: PKOLChar);
begin
Icon := LoadIcon( Inst, ResName );
fIconShared := TRUE;
end;
//[procedure TControl.IconLoadCursor]
procedure TControl.IconLoadCursor(Inst: Integer; ResName: PKOLChar);
begin
Icon := LoadCursor( Inst, ResName );
fIconShared := TRUE;
end;
//[function TControl.CallDefWndProc]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.CallDefWndProc(var Msg: TMsg): Integer;
begin
{$IFDEF INPACKAGE}
Log( '->TControl.CallDefWndProc FHandle = ' + Int2Str( FHandle ) +
', Msg.hwd = ' + Int2Str( Msg.hwnd ) );
TRY
{$ENDIF INPACKAGE}
if FDefWndProc <> nil then
begin
{$IFDEF INPACKAGE}
Log( '//// CallWindowProc, FDefWndProc = ' + Int2Hex( DWORD( FDefWndProc ), 6 ) );
TRY
TRY
{$ENDIF INPACKAGE}
Result := CallWindowProc( FDefWndProc, FHandle, Msg.message, Msg.wParam, Msg.lParam );
{$IFDEF INPACKAGE}
EXCEPT on E: Exception do
Log( '*** Exception in CallWindowProc, msg = ' + E.Message );
END;
EXCEPT
Log( '*** Exception handled' );
END;
{$ENDIF INPACKAGE}
end
else
begin
{$IFDEF INPACKAGE}
Log( '//// DefWindowProc' );
{$ENDIF INPACKAGE}
Result := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam );
end;
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-TControl.CallDefWndProc' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetWindowState]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetWindowState: TWindowState;
begin
Result := fWindowState;
{$ifdef win32}
if Handle <> 0 then
begin
if IsIconic( Handle ) then
Result := wsMinimized
else
if IsZoomed( Handle ) then
Result := wsMaximized
else
Result := wsNormal;
fWindowState := Result;
end;
{$endif win32}
end;
{$ENDIF ASM_VERSION}
//[function TControl.DoSetFocus]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.DoSetFocus: Boolean;
begin
Result := False;
if Enabled and (fTabstop or (fStyle and WS_TABSTOP <> 0)) then
begin
Inc( fClickDisabled );
SetFocus( fHandle );
Dec( fClickDisabled );
Result := True;
end;
end;
{$ENDIF ASM_VERSION}
//[function TControl.HandleAllocated]
function TControl.HandleAllocated: Boolean;
begin
Result := FHandle <> 0;
end;
//[function TControl.GetEnabled]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetEnabled: Boolean;
begin
if FHandle = 0 then
Result := (Style and WS_DISABLED) = 0
else
Result := IsWindowEnabled( FHandle );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[function TControl.IsMainWindow]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.IsMainWindow: Boolean;
begin
if Applet = nil then
Result := not IsControl
else if not AppButtonUsed then
Result := @ Self = Applet
else
Result := Applet.Children[ 0 ] = @ Self;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[function TControl.get_ClassName]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TControl.get_ClassName: KOLString;
begin
{$ifndef wince}
if not fCtlClsNameChg then
Result := 'obj_' + fControlClassName
else
{$endif wince}
Result := fControlClassName;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.set_ClassName]
procedure TControl.set_ClassName(const Value: KOLString);
begin
if fCtlClsNameChg then
FreeMem( fControlClassName );
GetMem( fControlClassName, (Length( Value ) + 1) * Sizeof( KOLChar ) );
{$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
( fControlClassName, @ Value[ 1 ] );
fCtlClsNameChg := TRUE;
end;
//[function WndProcQueryEndSession]
function WndProcQueryEndSession( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Accept: Boolean;
begin
Result := FALSE;
if Msg.message = WM_QUERYENDSESSION then
begin
if Assigned( Sender.fOnQueryEndSession ) then
begin
Accept := TRUE;
Sender.fCloseQueryReason := qShutdown;
if LongBool(Msg.lParam and {ENDSESSION_LOGOFF} DWORD($80000000)) then
Sender.fCloseQueryReason := qLogoff;
Sender.fOnQueryEndSession( Sender, Accept );
Sender.fCloseQueryReason := qClose;
Rslt := Integer( Accept );
// Добавить. Нужно для того, чтобы отменилось завершение сеанса,
// если Accept установлен в False и сеанс завершился при Accept = True
// Add (YS). To cancel ending session if Accept=FALSE but allow ending
// session if Accept=TRUE.
Result := True; // {YS}: no further processing
end;
end;
end;
//[procedure TControl.SetOnQueryEndSession]
procedure TControl.SetOnQueryEndSession(const Value: TOnEventAccept);
begin
AttachProc( WndProcQueryEndSession );
fOnQueryEndSession := Value;
end;
//[function WndProcMinMaxRestore]
function WndProcMinMaxRestore( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
if Msg.message = WM_SYSCOMMAND then
begin
case Msg.wParam and not 15 of
SC_MINIMIZE: if Assigned( Sender.fOnMinimize ) then
Sender.fOnMinimize( Sender );
SC_MAXIMIZE: if Assigned( Sender.fOnMaximize ) then
Sender.fOnMaximize( Sender );
SC_RESTORE: if Assigned( Sender.fOnRestore ) then
Sender.fOnRestore( Sender );
end;
end;
end;
//[procedure TControl.SetOnMinMaxRestore]
procedure TControl.SetOnMinMaxRestore(const Index: Integer;
const Value: TOnEvent);
type POnEvent = ^TOnEvent;
{$IFDEF F_P}
var Ptr1: Pointer;
{$ELSE DELPHI}
var Ev: POnEvent;
{$ENDIF F_P/DELPHI}
begin
AttachProc( WndProcMinMaxRestore );
{$IFDEF F_P}
Ptr1 := Self;
asm
MOV EAX, [Ptr1]
LEA EAX, [EAX].TControl.fOnMinimize
ADD EAX, [Index]
MOV EDX, [Value]
MOV [EAX], EDX
MOV EDX, [Value+4]
MOV [EAX+4], EDX
end [ 'EAX', 'EDX' ];
{$ELSE DELPHI}
Ev := Pointer( cardinal( @ TMethod( fOnMinimize ).Code ) + cardinal(Index) );
Ev^ := Value;
{$ENDIF}
end;
procedure TControl.SetOnMinimize(const Value: TOnEvent);
begin
SetOnMinMaxRestore( 0, Value );
end;
procedure TControl.SetOnMaximize(const Value: TOnEvent);
begin
SetOnMinMaxRestore( 8, Value );
end;
procedure TControl.SetOnRestore(const Value: TOnEvent);
begin
SetOnMinMaxRestore( 16, Value );
end;
{$IFDEF F_P}
//[function TControl.GetOnMinMaxRestore]
function TControl.GetOnMinMaxRestore(const Index: Integer): TOnEvent;
begin
CASE Index OF
0: Result := fOnMinimize;
8: Result := fOnMaximize;
16: Result := fOnRestore;
END;
end;
{$ENDIF F_P}
{$IFDEF INPACKAGE}
{$IFDEF ASM_LOCAL}
{$UNDEF ASM_LOCAL}
{$ENDIF}
{$ELSE}
{$IFDEF ASM_VERSION}
{$DEFINE ASM_LOCAL}
{$ENDIF}
{$ENDIF}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
//[procedure TControl.SetParent]
{$IFDEF ASM_LOCAL}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetParent( Value: PControl );
begin
if Value = fParent then Exit;
if fParent <> nil then
begin
{$IFDEF USE_GRAPHCTLS}
Invalidate; // necessary for graphic controls
{$ENDIF}
{$IFDEF DEBUG_MCK}
if Assigned( fParent.fChildren ) then
begin
mck_Log( 'remove from old parent children 1st' );
fParent.fChildren.Remove( @Self );
mck_Log( 'removed ok' );
end;
{$ELSE not DEBUG_MCK}
fParent.fChildren.Remove( @Self );
{$IFDEF NOT_USE_AUTOFREE4CONTROLS}
{$ELSE}
fParent.RemoveFromAutoFree( @Self );
{$ENDIF}
if Assigned( fParent.fNotifyChild ) then
fParent.fNotifyChild( fParent, nil );
{$ENDIF not DEBUG_MCK}
end;
fParent := Value;
if fParent <> nil then
begin
fParent.fChildren.Add( @Self );
{$IFDEF USE_AUTOFREE4CHILDREN}
fParent.Add2AutoFree( @ Self );
{$ENDIF}
{$IFNDEF INPACKAGE} //-----------------------------------------------------
if FHandle <> 0 then
Windows.SetParent( FHandle, Value.GetWindowHandle );
{$ENDIF not INPACKAGE} //--------------------------------------------------
if Assigned( fParent.fNotifyChild ) then
fParent.fNotifyChild( fParent, @ Self );
if Assigned( fNotifyChild ) then
fNotifyChild( fParent, @ Self );
{$IFDEF USE_GRAPHCTLS}
Invalidate; // necessary for graphic controls
{$ENDIF}
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetParent( Value: PControl );
begin
if Value = fParent then Exit;
if fParent <> nil then
begin
fParent.fChildren.Remove( @Self );
{$IFDEF NOT_USE_AUTOFREE4CONTROLS}
{$ELSE}
fParent.RemoveFromAutoFree( @Self );
{$ENDIF}
end;
fParent := Value;
if fParent <> nil then
begin
fParent.fChildren.Add( @Self );
{$IFDEF USE_AUTOFREE4CHILDREN}
fParent.Add2AutoFree( @ Self );
{$ENDIF}
end;
fParent.fGetClientArea( fParent );
fParent.fChildPut( fParent, @ Self, fBoundsRect.Left, fBoundsRect.Top );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[function TControl.ChildIndex]
function TControl.ChildIndex(Child: PControl): Integer;
begin
Result := fChildren.IndexOf( Child );
end;
//*
//[procedure TControl.MoveChild]
procedure TControl.MoveChild(Child: PControl; NewIdx: Integer);
var I: Integer;
begin
I := ChildIndex( Child );
Assert( I>=0, 'TControl.MoveChild: index out of bounds' );
fChildren.MoveItem( I, NewIdx );
end;
{$IFDEF WIN_GDI}
//[procedure TControl.EnableChildren]
procedure TControl.EnableChildren(Enable, Recursive: Boolean);
var I: Integer;
C: PControl;
begin
for I := 0 to ChildCount-1 do
begin
C := Children[ I ];
C.Enabled := Enable;
if Recursive then
C.EnableChildren( Enable, TRUE );
end;
end;
{$ENDIF WIN_GDI}
//[constructor TControl.CreateParented]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
constructor TControl.CreateParented(AParent: PControl);
begin
InitParented( AParent ); // because InitParented is virtual, but CreateParented
end; // can not be virtual (as an _object_ - not a class - constructor)
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
constructor TControl.CreateParented(AParent: PControl; widget: PGtkWidget;
need_eventbox: Boolean);
begin
InitParented( AParent, widget, need_eventbox );
// because InitParented is virtual, but CreateParented
end; // can not be virtual (as an _object_ - not a class - constructor)
{$ENDIF GTK}
{$ENDIF _X_}
//[function TControl.GetLeft]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetLeft: Integer;
begin
Result := BoundsRect.Left;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetLeft]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetLeft( Value: Integer );
var R: TRect;
begin
R := BoundsRect;
R.Left := Value;
R.Right := Value + Width;
SetBoundsRect( R );
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetTop]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetTop: Integer;
begin
Result := BoundsRect.Top;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetTop]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetTop( Value: Integer );
var R: TRect;
begin
R := BoundsRect;
R.Top := Value;
R.Bottom := Value + Height;
SetBoundsRect( R );
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetWidth]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetWidth: Integer;
begin
with BoundsRect do
Result := Right - Left;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetWidth]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetWidth( Value: Integer );
var R: TRect;
begin
R := BoundsRect;
with R do
Right := Left + Value;
SetBoundsRect( R );
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetHeight]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetHeight: Integer;
begin
with BoundsRect do
Result := Bottom - Top;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetHeight]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetHeight( Value: Integer );
var R: TRect;
begin
R := BoundsRect;
with R do
Bottom := Top + Value;
SetBoundsRect( R );
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetPosition]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetPosition: TPoint;
begin
Result.x := BoundsRect.Left;
Result.y := BoundsRect.Top;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.Set_Position]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.Set_Position( Value: TPoint );
var R: TRect;
begin
R.Top := Value.y;
R.Left := Value.x;
R.Right := R.Left + Width;
R.Bottom := R.Top + Height;
BoundsRect := R;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[function WndProcConstraints]
function WndProcConstraints( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var MMI: PMinMaxInfo;
begin
Result := FALSE;
if Msg.message = WM_GETMINMAXINFO then
begin
Rslt := Sender.CallDefWndProc( Msg );
MMI := Pointer( Msg.lParam );
if Sender.FMaxWidth > 0 then
begin
MMI.ptMaxSize.x := Sender.FMaxWidth;
MMI.ptMaxTrackSize.x := Sender.FMaxWidth;
end;
if Sender.FMaxHeight > 0 then
begin
MMI.ptMaxSize.y := Sender.FMaxHeight;
MMI.ptMaxTrackSize.y := Sender.FMaxHeight;
end;
MMI.ptMinTrackSize := MakePoint( Sender.FMinWidth, Sender.FMinHeight );
Rslt := 0;
Result := TRUE;
end;
end;
{$IFDEF USE_MHTOOLTIP}
{$DEFINE implementation}
{$I KOLMHToolTip.pas}
{$UNDEF implementation}
{$ENDIF}
//[procedure TControl.SetConstraint]
procedure TControl.SetConstraint(const Index, Value: Integer);
begin
AttachProc( WndProcConstraints );
case Index of
0: FMinWidth := Value;
1: FMinHeight := Value;
2: FMaxWidth := Value;
3: FMaxHeight := Value;
end;
end;
{$IFDEF F_P}
//[function TControl.GetConstraint]
function TControl.GetConstraint(const Index: Integer): Integer;
begin
CASE Index OF
0: Result := FMinWidth;
1: Result := FMinHeight;
2: Result := FMaxWidth;
3: Result := FMaxHeight;
END;
end;
{$ENDIF F_P}
//*
//[function TControl.ControlRect]
function TControl.ControlRect: TRect;
var C: PControl;
R: TRect;
begin
Result := BoundsRect;
C := Parent;
if C <> nil then
begin
if not C.fIsControl then Exit;
R := C.ControlRect;
OffsetRect( Result, R.Left, R.Top );
if C.fChildren <> nil then
if C.FChildren.IndexOf( @Self ) >= C.MembersCount then
begin
R := C.ClientRect;
Dec( R.Top, C.fClientTop );
Dec( R.Left, C.fClientLeft );
OffsetRect( Result, R.Left, R.Top );
end;
end;
end;
//*
//[function TControl.ControlAtPos]
function TControl.ControlAtPos( X, Y: Integer;
IgnoreDisabled: Boolean ): PControl;
var I: Integer;
C: PControl;
CR, VR: TRect;
begin
Result := nil;
CR := ControlRect;
if Windowed then
CR := MakeRect( 0, 0, 0, 0 );
X := X + CR.Left; // - R.Left;
Y := Y + CR.Top; // - R.Top;
for I := ChildCount { + MembersCount } - 1 downto 0 do
begin
C := Children[ I ]; //Members[ I ];
if C.Visible then
if (not IgnoreDisabled) or IgnoreDisabled and C.Enabled then
begin
VR := C.ControlRect;
if (X >= VR.Left) and (X < VR.Right) and
(Y >= VR.Top) and (Y < VR.Bottom) then
begin
Result := C;
Exit;
end;
end;
end;
end;
{$ENDIF WIN_GDI}
//[PROCEDURE DefaultPaintBackground]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );
{$IFDEF GDI} var B: HBrush; {$ENDIF GDI}
begin
{$IFDEF GDI}
B := CreateSolidBrush( Color2Rgb( Sender.Color ) );
Windows.FillRect( DC, Rect^, B );
DeleteObject( B );
{$ENDIF GDI}
end;
{$ENDIF ASM_VERSION}
//[END DefaultPaintBackground]
{$IFDEF WIN_GDI}
//[procedure TControl.PaintBackground]
procedure TControl.PaintBackground( DC: HDC; Rect: PRect );
begin
Global_OnPaintBkgnd( @Self, DC, Rect );
end;
{$ENDIF WIN_GDI}
//[procedure TControl.SetCtlColor]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetCtlColor( Value: TColor );
begin
{$IFNDEF INPACKAGE}
if GetWindowHandle <> 0 then
{$ELSE}
if fHandle <> 0 then
{$ENDIF}
if fCommandActions.aSetBkColor <> 0 then
Perform( fCommandActions.aSetBkColor, 0, Color2RGB( Value ) );
if fColor = Value then Exit;
fColor := Value;
if fTmpBrush <> 0 then
begin
DeleteObject( fTmpBrush );
fTmpBrush := 0;
end;
if fBrush <> nil then
fBrush.Color := Value;
Invalidate;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetCtlColor( Value: TColor );
var gcolor: TGdkColor;
i: Integer;
begin
if fColor = Value then Exit;
fColor := Value;
//oldfontdesc := PGtkWidget( _Self.fHandle ).style.font_desc;
gcolor := Color2GdkColor( Value );
for i := 0 to 4 do
begin
gtk_widget_modify_bg( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor );
gtk_widget_modify_base( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor );
end;
//if Assigned( _Self.fFont ) then
{begin
_Self.fHandle.style.font_desc :=
pango_font_description_copy( _Self.fFont.GetPangoFontDesc );
if oldfontdesc <> nil then
pango_font_description_free( oldfontdesc );
end;}
//Invalidate;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[function TControl.GetParentWnd]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetParentWnd( NeedHandle: Boolean ): HWnd;
var C: PControl;
begin
Result := 0;
C := fParent; // WindowedParent;
if C <> nil then
begin
if NeedHandle then
C.GetWindowHandle;
Result := C.fHandle;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.CreateChildWindows]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.CreateChildWindows;
var I: Integer;
C: PControl;
begin
{$IFDEF INPACKAGE}
Log( '->TControl.CreateChildWindows' );
TRY
{$ENDIF INPACKAGE}
for I := 0 to fChildren.Count - 1 do
begin
{$IFDEF INPACKAGE}
Log( Int2Str( I ) );
{$ENDIF INPACKAGE}
C := fChildren.fItems[ I ];
C.CreateWindow; //virtual!!!
end;
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-TControl.CreateChildWindows' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[function TControl.GetMembers]
function TControl.GetMembers(Idx: Integer): PControl;
begin
Result := fChildren.Items[ Idx ];
// Important: .Items but not .fItems - when fChildren.Count=0, nil is returned
end;
{$IFDEF WIN_GDI}
//[procedure TControl.DestroyChildren]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.DestroyChildren;
var I: Integer;
W: PControl;
begin
for I := fChildren.fCount - 1 downto 0 do
begin
W := fChildren.fItems[ I ];
W.Free;
end;
fChildren.Clear;
end;
{$ENDIF ASM_VERSION}
{//-
//[function TControl.WindowedParent]
function TControl.WindowedParent: PControl;
begin
Result := fParent;
end;}
//[function TControl.ProcessMessage]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.ProcessMessage: Boolean;
begin
Result := InternalProcessMessage(nil);
end;
{$ENDIF ASM_VERSION}
function TControl.InternalProcessMessage(AMsg: PMsg): Boolean;
var Msg: TMsg;
begin
Result := False;
if AMsg <> nil then
Msg:=AMsg^
else
if not PeekMessage( Msg, 0, 0, 0, PM_REMOVE ) then
exit;
Result := Msg.message <> 0;
if (Msg.message = WM_QUIT) then
begin
AppletTerminated := True;
{$IFDEF PROVIDE_EXITCODE}
ExitCode := Msg.wParam;
{$ENDIF PROVIDE_EXITCODE}
end
else
begin
if not(Assigned( fExMsgProc ) and fExMsgProc( @Self, Msg )) then
begin
TranslateMessage( Msg );
DispatchMessage( Msg );
{$IFDEF PSEUDO_THREADS}
if Assigned( MainThread ) then
MainThread.NextThread;
{$ENDIF}
end;
end;
end;
procedure TControl.WaitAndProcessMessages;
var Msg: TMsg;
begin
GetMessage(Msg, 0, 0, 0);
InternalProcessMessage(@Msg);
while InternalProcessMessage(nil) do ;
end;
//[procedure TControl.ProcessMessages]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.ProcessMessages;
begin
while ProcessMessage do ;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.ProcessMessagesEx]
procedure TControl.ProcessMessagesEx;
begin
PostMessage( GetWindowHandle, CM_PROCESS, 0, 0 );
ProcessMessages;
end;
//-
//[procedure TControl.ProcessPendingMessages]
procedure TControl.ProcessPendingMessages;
var Msg: TMsg;
begin
if LOWORD( GetQueueStatus( QS_ALLINPUT ) ) <> 0 then
if PeekMessage( Msg, 0, 0, 0, PM_NOREMOVE {or PM_NOYIELD} )
or PeekMessage( Msg, HWnd(-1), 0, 0, PM_NOREMOVE {or PM_NOYIELD} )
then
Applet.ProcessMessages;
end;
//[procedure TControl.ProcessPaintMessages]
procedure TControl.ProcessPaintMessages;
var Msg: TMsg;
begin
while PeekMessage( Msg, Handle, 15, 15, PM_NOREMOVE ) do
Applet.ProcessMessage;
end;
//[FUNCTION WndProcForm]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcForm(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
{$IFDEF ENDSESSION_HALT}
var App: PControl;
{$ENDIF}
begin
Result := True;
with Self_{-}^{+} do
case Msg.message of
{$IFDEF ENDSESSION_HALT}
WM_ENDSESSION:
begin
if Msg.wParam <> 0 then
begin
Self_.RefDec;
{ Normally, WM_ENDSESSION is sent to a main form, not to Applet.
Since we do not plan further working after handling this message,
we decrease RefCount for the form (in was increased in EnumDynHandlers
to prevent object destroying while its message processing is not
finished). }
App := Applet;
//Rslt := 0; { We will not return any result at all. }
{$IFDEF DEBUG_ENDSESSION}
EndSession_Initiated := TRUE;
LogFileOutput( GetStartDir + 'es_debug.txt',
'Self_=' + Int2Hex( DWORD( Self_ ), 8 ) +
' Self_.Handle=' + Int2Str( Self_.FHandle ) );
{$ENDIF}
AppletTerminated := TRUE;
AppletRunning := FALSE;
Applet := nil;
App.Free; { We provide OnDestroy handlers to be called for any objects here }
Halt; { Stop further executing. }
end else Result := FALSE;
end;
{$ENDIF ENDSESSION_HALT}
WM_SETFOCUS:
begin
{$IFDEF NEW_MODAL}
if fModalForm <> nil then
SetFocus( fModalForm.fHandle )
else if ( FCurrentControl <> nil ) and not ( fCurrentControl.IsForm xor fIsApplet ) then
{$ELSE not NEW_MODAL}
if FCurrentControl <> nil then
{$ENDIF}
begin
if FCurrentControl.CreateWindow then
SetFocus( FCurrentControl.fHandle );
end
else
Result := False;
if assigned( Applet ) and (Applet <> Self_) then
Applet.FCurrentControl := Self_;
end;
{$IFDEF SNAPMOUSE2DFLTBTN}
WM_INITDIALOG:
begin
asm
nop
end;
Result := FALSE;
end;
{$ENDIF}
else Result := False;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcForm]
{$ENDIF WIN_GDI}
//[FUNCTION GetPrevCtrlBoundsRect]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean;
var Idx: Integer;
begin
Result := False;
if P.FParent = nil then Exit;
Idx := P.FParent.ChildIndex( P ) - 1;
if Idx < 0 then Exit;
Result := True;
R := P.FParent.Children[ Idx ].BoundsRect;
end;
{$ENDIF ASM_VERSION}
//[END GetPrevCtrlBoundsRect]
//[function TControl.PlaceUnder]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.PlaceUnder: PControl;
var R: TRect;
begin
Result := @Self;
if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;
Top := R.Bottom + fParent.fMargin;
Left := R.Left;
end;
{$ENDIF ASM_VERSION}
//[function TControl.PlaceDown]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.PlaceDown: PControl;
var R: TRect;
begin
Result := @Self;
if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;
Top := R.Bottom + fParent.fMargin;
end;
{$ENDIF ASM_VERSION}
//[function TControl.PlaceRight]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.PlaceRight: PControl;
var R: TRect;
begin
Result := @Self;
if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;
Top := R.Top;
Left := R.Right + fParent.fMargin;
end;
{$ENDIF ASM_VERSION}
//[function TControl.SetSize]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.SetSize(W, H: Integer): PControl;
var R: TRect;
begin
R := BoundsRect;
if W > 0 then R.Right := R.Left + W;
if H > 0 then R.Bottom := R.Top + H;
SetBoundsRect( R );
Result := @Self;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[function TControl.SetClientSize]
function TControl.SetClientSize(W, H: Integer): PControl;
begin
if W > 0 then ClientWidth := W;
if H > 0 then ClientHeight := H;
Result := @Self;
end;
//[function TControl.AlignLeft]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.AlignLeft(P: PControl): PControl;
begin
Result := @Self;
Left := P.Left;
end;
{$ENDIF ASM_VERSION}
//[function TControl.AlignTop]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.AlignTop(P: PControl): PControl;
begin
Result := @Self;
Top := P.Top;
end;
{$ENDIF ASM_VERSION}
{$IFDEF KEY_PREVIEW}
{$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
{$ENDIF}
{$IFDEF ESC_CLOSE_DIALOGS}
{$IFNDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
{$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
{$ENDIF}
{$ENDIF}
//[FUNCTION WndProcCtrl]
{$IFDEF ASM_VERSION} // see addition for combobox in pas version
function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
asm //cmd //opd
PUSH EBX
XCHG EBX, EAX
PUSH ESI
PUSH EDI
MOV EDI, EDX
MOV EDX, [EDI].TMsg.message
SUB DX, CN_CTLCOLORMSGBOX
CMP DX, CN_CTLCOLORSTATIC-CN_CTLCOLORMSGBOX
JA @@chk_CM_COMMAND
@@2:
PUSH ECX
MOV EAX, [EBX].TControl.fTextColor
CALL Color2RGB
XCHG ESI, EAX
PUSH ESI
PUSH [EDI].TMsg.wParam
CALL SetTextColor
CMP [EBX].TControl.fTransparent, 0
JZ @@opaque
PUSH Windows.TRANSPARENT
PUSH [EDI].TMsg.wParam
CALL SetBkMode
PUSH NULL_BRUSH
CALL GetStockObject
JMP @@ret_rslt
@@opaque:
MOV EAX, [EBX].TControl.fColor
CALL Color2RGB
XCHG ESI, EAX
PUSH OPAQUE
PUSH [EDI].TMsg.wParam
CALL SetBkMode
PUSH ESI
PUSH [EDI].TMsg.wParam
CALL SetBkColor
MOV EAX, EBX
CALL Global_GetCtlBrushHandle
@@ret_rslt:
XCHG ECX, EAX
@@tmpbrushready:
POP EAX
MOV [EAX], ECX
@@ret_true:
MOV AL, 1
JMP @@ret_EAX
@@chk_CM_COMMAND:
CMP word ptr [EDI].TMsg.message, CM_COMMAND
JNE @@chk_WM_SETFOCUS
PUSH ECX
MOVZX ECX, word ptr [EDI].TMsg.wParam+2
CMP CX, [EBX].TControl.fCommandActions.aClick
JNE @@chk_aEnter
CMP [EBX].TControl.fClickDisabled, 0
JG @@calldef
MOV EAX, EBX
MOV DL, 1
CALL TControl.SetFocused
MOV EAX, EBX
CALL TControl.DoClick
JMP @@calldef
@@chk_aEnter:
LEA EAX, [EBX].TControl.fOnEnter
CMP CX, [EBX].TControl.fCommandActions.aEnter
JE @@goEvent
LEA EAX, [EBX].TControl.fOnLeave
CMP CX, [EBX].TControl.fCommandActions.aLeave
JE @@goEvent
LEA EAX, [EBX].TControl.fOnChange
CMP CX, [EBX].TControl.fCommandActions.aChange
JNE @@chk_aSelChange
@@goEvent:
MOV ECX, [EAX].TMethod.Code
JECXZ @@2calldef
MOV EAX, [EAX].TMethod.Data
MOV EDX, EBX
CALL ECX
@@2calldef:
JMP @@calldef
@@chk_aSelChange:
CMP CX, [EBX].TControl.fCommandActions.aSelChange
JNE @@chk_WM_SETFOCUS_1
MOV EAX, EBX
CALL TControl.DoSelChange
@@calldef:
XCHG EAX, EBX
MOV EDX, EDI
CALL TControl.CallDefWndProc
JMP @@ret_rslt
@@chk_WM_SETFOCUS_1:
POP ECX
@@chk_WM_SETFOCUS:
XOR EAX, EAX
CMP word ptr [EDI].TMsg.message, WM_SETFOCUS
JNE @@chk_WM_KEYDOWN
MOV [ECX], EAX
MOV EAX, EBX
CALL TControl.ParentForm
TEST EAX, EAX
JZ @@ret_true
PUSH EAX
MOV ECX, [EAX].TControl.FCurrentControl
JECXZ @@a1
CMP ECX, EBX
JZ @@a1
XCHG EAX, ECX
MOV ECX, [EAX].TControl.fLeave.TMethod.Code
JECXZ @@a1
XCHG EDX, EAX
MOV EAX, [EDX].TControl.fLeave.TMethod.Data
CALL ECX
@@a1: POP EAX
MOV [EAX].TControl.FCurrentControl, EBX
XOR EAX, EAX
PUSH EDX
@@2ret_EAX:
POP EDX
@@chk_WM_KEYDOWN:
{$IFDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
CMP word ptr [EDI].TMsg.message, WM_KEYDOWN
{$IFDEF KEY_PREVIEW}
JNE @@chk_other_KEYMSGS
{$ELSE}
JNE @@ret0
{$ENDIF}
{$IFDEF KEY_PREVIEW}
MOV EAX, EBX
CALL TControl.ParentForm
CMP EAX, EBX
JE @@kp_end
CMP [EAX].TControl.fKeyPreview, 0
JZ @@kp_end
MOV [EAX].TControl.fKeyPreviewing, 1
INC [EAX].TControl.fKeyPreviewCount
PUSH EAX
PUSH [EDI].TMsg.lParam
PUSH [EDI].TMsg.wParam
PUSH WM_KEYDOWN
PUSH EAX
CALL TControl.Perform
POP EAX
DEC [EAX].TControl.fKeyPreviewCount
@@kp_end:
{$ENDIF}
{$IFDEF ESC_CLOSE_DIALOGS}
MOV EAX, EBX
CALL TControl.ParentForm
TEST [EAX].TControl.fExStyle, WS_EX_DLGMODALFRAME
JZ @@ecd_end
CMP [EDI].TMsg.wParam, 27
JNE @@ecd_end
PUSH 0
PUSH 0
PUSH WM_CLOSE
PUSH EAX
CALL TControl.Perform
@@ecd_end:
{$ENDIF}
@@ret0:
XOR EAX, EAX
{$IFDEF KEY_PREVIEW}
JMP @@ret_EAX
@@chk_other_KEYMSGS:
MOVZX EAX, word ptr [EDI].TMsg.message
SUB AX, WM_KEYDOWN
JB @@ret0
CMP AX, 6
JA @@ret0
// all WM_KEYUP=$101, WM_CHAR=$102, WM_DEADCHAR=$103, WM_SYSKEYDOWN=$104,
// WM_SYSKEYUP=$105, WM_SYSCHAR=$106, WM_SYSDEADCHAR=$107
MOV EAX, EBX
CALL TControl.ParentForm
CMP EAX, EBX
JE @@ret0
MOV [EAX].TControl.fKeyPreviewing, 1
INC [EAX].TControl.fKeyPreviewCount
PUSH EAX
PUSH [EDI].TMsg.lParam
PUSH [EDI].TMsg.wParam
PUSH [EDI].TMsg.message
PUSH EAX
CALL TControl.Perform
POP EAX
DEC [EAX].TControl.fKeyPreviewCount
XOR EAX, EAX
{$ENDIF KEY_PREVIEW}
{$ENDIF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
@@ret_EAX:
POP EDI
POP ESI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var F: PControl;
Cmd : DWORD;
begin
Result := FALSE;
with Self_{-}^{+} do
case Msg.message of
CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
begin
SetTextColor(Msg.WParam, Color2RGB(fTextColor));
if fTransparent then
begin
SetBkMode( Msg.wParam, Windows.TRANSPARENT );
Rslt := GetStockObject( NULL_BRUSH );
end
else
begin
SetBkMode( Msg.wParam, Windows.OPAQUE );
SetBkColor(Msg.WParam, Color2RGB( fColor ) );
Rslt := Global_GetCtlBrushHandle( Self_ );
end;
Result := TRUE;
end;
CM_COMMAND:
begin
Result := True;
Cmd := HiWord( Msg.wParam );
if Cmd = fCommandActions.aClick then
begin
if Integer( fClickDisabled ) <= 0 then
begin
Focused := TRUE;
DoClick;
end;
end else
if Cmd = fCommandActions.aEnter then
begin
if Assigned( fOnEnter ) then fOnEnter( Self_ );
end else
if Cmd = fCommandActions.aLeave then
begin
if Assigned( fOnLeave ) then fOnLeave( Self_ );
end else
if Integer(Cmd) = fCommandActions.aChange then
begin
if Assigned( fOnChange ) then fOnChange( Self_ );
end else
if Integer(Cmd) = fCommandActions.aSelChange then
begin
DoSelChange;
end
else Result := False;
if Result then
Rslt := CallDefWndProc( Msg );
end;
WM_SETFOCUS:
begin
Rslt := 0;
Result := TRUE;
F := ParentForm;
if F <> nil then
begin
if (F.fCurrentControl <> nil) and (F.fCurrentControl <> Self_) and
Assigned( F.fCurrentControl.fLeave ) then
F.fCurrentControl.fLeave( F.fCurrentControl );
F.fCurrentControl := Self_;
Result := False; // go further handling
end;
end;
{$IFDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
WM_KEYDOWN:
begin
{$IFDEF KEY_PREVIEW}
//--------------------------------Truf-------------------------------------
if ParentForm <> Self_ then
begin
if ParentForm.KeyPreview then begin
ParentForm.KeyPreviewing := TRUE;
inc( ParentForm.FKeyPreviewCount );
ParentForm.Perform(WM_KEYDOWN,msg.wParam,msg.lParam);
dec( ParentForm.FKeyPreviewCount );
end;
end;
//--------------------------------Truf-------------------------------------
{$ENDIF KEY_PREVIEW}
{$IFDEF ESC_CLOSE_DIALOGS}
//---------------------------------Babenko Alexey--------------------------
begin
if (Self_.ParentForm.fExStyle and WS_EX_DLGMODALFRAME) <> 0 then
if Msg.wParam = 27 then
Self_.ParentForm.Perform(WM_CLOSE, 0, 0);
end;
//---------------------------------Babenko Alexey--------------------------
{$ENDIF ESC_CLOSE_DIALOGS}
end;
{$IFDEF KEY_PREVIEW}
WM_SYSKEYDOWN,
WM_KEYUP, WM_SYSKEYUP,
WM_CHAR, WM_SYSCHAR:
if ParentForm <> Self_ then
begin
if ParentForm.KeyPreview then
begin
ParentForm.KeyPreviewing := TRUE;
ParentForm.Perform(Msg.message,msg.wParam,msg.lParam);
end;
end;
{$ENDIF KEY_PREVIEW}
{$ENDIF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcCtrl]
{$ifdef win32}
//[FUNCTION WndProcTransparent]
{$IFDEF OLD_TRANSPARENT}
function WndProcTransparent( Sender: PControl; var Msg: TMsg;
var Rslt: Integer ): Boolean;
var DC, PDC, BLTDC: HDC;
Save: integer;
OLDp: THANDLE;
L, T: SmallInt;
TP, ParentClient: TPoint;
TR, Margins: TRect;
Wnd: HWND;
tRgn: HRgn;
C: PControl;
begin
Result := FALSE;
{$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED}
if AppletTerminated or not Sender.ToBeVisible then
begin
Exit;
end;
{$ENDIF}
case Msg.message of
WM_HSCROLL, WM_VSCROLL:
begin
Sender.Invalidate;
exit;
end;
WM_SETTEXT:
begin
if Sender.fIsStaticControl = 0 then exit;
Sender.Invalidate;
Rslt := DefWindowProc
( Sender.fHandle, WM_SETTEXT, Msg.wParam, Msg.lParam );
Result := TRUE;
exit;
end;
WM_NCPAINT:
begin
if Sender.fTransparent then
Result := TRUE;
exit;
end;
end;
if Sender.fTransparent and (not Sender.fParent.fDoubleBuffered) then
Sender.fTransparent := FALSE;
if not (Sender.fTransparent or Sender.fDoubleBuffered) then exit;
if Sender.fSelfRequirePaint then exit;
case Msg.message of
WM_ERASEBKGND:
begin
Result := TRUE;
end;
WM_PAINT:
begin
ValidateRect(Sender.fHandle, nil); //???--brandys???
if (Sender.fTransparent) and (not Sender.fParentRequirePaint) then begin
InvalidateRect(Sender.fParent.Handle, nil, FALSE);
Result := TRUE;
exit;
end;
GetClientRect(Msg.hwnd, Margins);
OLDp := 0;
if not Sender.fParentRequirePaint then begin
Sender.fDblExcludeRgn := CreateRectRgn(0, 0, Margins.Right, Margins.Bottom);
DC := GetDC(0);
PDC := CreateCompatibleDC( DC );
OLDp := SelectObject(PDC,
CreateCompatibleBitmap(DC, Margins.Right, Margins.Bottom) );
ReleaseDC(0, DC);
Sender.fParentCoordX := 0;
Sender.fParentCoordy := 0;
end else begin
PDC := Msg.wParam;
Sender.fDblExcludeRgn := Sender.fParent.fDblExcludeRgn;
end;
Sender.fSelfRequirePaint := TRUE;
Sender.fPaintDC := PDC;
if (not Sender.fParentRequirePaint) or Sender.fDoubleBuffered then
Sender.Perform(WM_ERASEBKGND, PDC, 0);
Sender.Perform(WM_PAINT, PDC, 0);
Wnd := GetWindow( Sender.fHandle, GW_CHILD );
Wnd := GetWindow( Wnd, GW_HWNDLAST);
while Wnd <> 0 do begin
if IsWindowVisible(Wnd) then begin
{$IFDEF USE_PROP}
C := Pointer( GetProp( Wnd, ID_SELF ) );
{$ELSE}
C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
{$ENDIF}
with C{-}^{+} do begin
if (C <> nil) and (fTransparent or fDoubleBuffered) then begin
Save := SaveDC( PDC );
fParentRequirePaint := TRUE;
L := Sender.fParentCoordX + Left;
T := Sender.fParentCoordY + Top;
SetWindowOrgEx(PDC, -L, -T, nil);
SendMessage(Wnd, WM_PRINT, PDC, PRF_NONCLIENT);
TP.x := 0; TP.Y := 0;
ClientToScreen(fHandle, TP);
GetWindowRect(fHandle, TR);
fParentCoordX := L + TP.X - TR.Left;
fParentCoordY := T + TP.Y - TR.Top;
SetWindowOrgEx(PDC, -fParentCoordX, -fParentCoordY, nil);
GetClientRect(Wnd, TR);
IntersectClipRect(PDC, 0, 0, TR.Right, TR.Bottom);
SendMessage(Wnd, WM_PAINT, PDC, 0);
fParentRequirePaint := FALSE;
RestoreDC( PDC, Save );
end else begin
GetWindowRect(Wnd, TR);
TP.X := 0; TP.Y := 0;
ClientToScreen(Sender.fHandle, TP);
TP.X := TR.Left - TP.X + Sender.fParentCoordX;
TP.Y := TR.Top - TP.Y + Sender.fParentCoordY;
TR.Left := TR.Right - TR.Left;
TR.Top := TR.Bottom - TR.Top;
tRgn := CreateRectRgn(TP.X, TP.Y, TP.X+TR.Left, TP.Y+TR.Top);
CombineRgn(Sender.fDblExcludeRgn, Sender.fDblExcludeRgn, tRgn, RGN_DIFF);
DeleteObject(tRgn);
end;
end;
end;
Wnd := GetWindow( Wnd, GW_HWNDPREV );
end;
Sender.fPaintDC := 0;
Sender.fSelfRequirePaint := FALSE;
if not Sender.fParentRequirePaint then begin
BLTDC := GetWindowDC(Sender.fHandle);
GetWindowRect( Sender.fHandle, TR );
ParentClient.x := 0; ParentClient.y := 0;
ClientToScreen( Sender.fHandle, ParentClient );
SetWindowOrgEx(BLTDC, TR.Left - ParentClient.x, TR.Top - ParentClient.y, nil);
OffsetRgn(Sender.fDblExcludeRgn, ParentClient.x - TR.Left, ParentClient.y - TR.Top);
ExtSelectClipRgn(BLTDC, Sender.fDblExcludeRgn, RGN_AND);
BitBlt( BLTDC, 0, 0, Margins.Right, Margins.Bottom, PDC, 0, 0, SRCCOPY );
ReleaseDC(Sender.fHandle, BLTDC);
DeleteObject(SelectObject( PDC, OLDp ));
DeleteObject(Sender.fDblExcludeRgn);
DeleteDC( PDC );
end;
//ValidateRect(Sender.fHandle, nil); //???++brandys???//
Result := TRUE;
end;
end;
end;
{$ELSE NEW_TRANSPARENT} // by Alexander Karpinsky a.k.a. homm
function WndProcTransparent( Sender: PControl; var Msg: TMsg;
var Rslt: Integer ): Boolean;
function SetRectRgnInderect(tRgn: HRGN; const TR: TRect): BOOL;
begin
Result := SetRectRgn(tRgn, TR.Left, TR.Top, TR.Right, TR.Bottom);
end;
var
DC, PDC, BLTDC: HDC;
Save: integer;
OLDp: THANDLE;
L, T: SmallInt;
TP: TPoint;
TR, Margins: TRect;
Wnd: HWND;
C: PControl;
ChildRgn: HRGN;
PS: TPaintStruct;
begin
Result := FALSE;
{$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED}
if AppletTerminated or not Sender.ToBeVisible then
begin
Exit;
end;
{$ENDIF}
if Sender.fTransparent and (not Sender.fParent.fDoubleBuffered) then
Sender.fTransparent := FALSE;
if not (Sender.fTransparent or Sender.fDoubleBuffered) then exit;
case Msg.message of
WM_HSCROLL, WM_VSCROLL:
begin
Sender.Invalidate;
exit;
end;
WM_SETTEXT:
begin
if Sender.fIsStaticControl = 0 then exit;
Sender.Invalidate;
Rslt := DefWindowProc ( Sender.fHandle, WM_SETTEXT, Msg.wParam, Msg.lParam );
Result := TRUE;
exit;
end;
WM_PAINT,
WM_ERASEBKGND:;
WM_NCPAINT:
if not Sender.fTransparent then
exit;
else exit;
end;
if Sender.fSelfRequirePaint then begin
exit;
end;
Result := TRUE;
if Sender.fTransparent and (not Sender.fParentRequirePaint) then
begin
TR := Sender.BoundsRect;
InvalidateRect(Sender.fParent.fHandle, @TR, true);
ValidateRect(Sender.fHandle, nil); //???--brandys???+
exit;
end;
if Msg.message = WM_PAINT then begin
OLDp := 0;
if not Sender.fParentRequirePaint then begin
Sender.fDblExcludeRgn := CreateRectRgn(0, 0, 0, 0);
if GetUpdateRgn(Sender.fHandle, Sender.fDblExcludeRgn, TRUE) <= NULLREGION then
begin
DeleteObject(Sender.fDblExcludeRgn);
exit;
end;
DC := BeginPaint(Sender.fHandle, PS);
PDC := CreateCompatibleDC( DC );
GetClientRect(Msg.hwnd, Margins);
OLDp := SelectObject(PDC, CreateCompatibleBitmap(DC, Margins.Right, Margins.Bottom) );
Sender.fParentCoordX := 0;
Sender.fParentCoordy := 0;
end else begin
PDC := Msg.wParam;
Sender.fDblExcludeRgn := Sender.fParent.fDblExcludeRgn;
end;
Sender.fSelfRequirePaint := TRUE;
Sender.fPaintDC := PDC;
if (not Sender.fParentRequirePaint) or Sender.fDoubleBuffered then
Sender.Perform(WM_ERASEBKGND, PDC, 0);
Sender.Perform(WM_PAINT, PDC, 0);
Wnd := GetWindow( Sender.fHandle, GW_CHILD );
Wnd := GetWindow( Wnd, GW_HWNDLAST);
while Wnd <> 0 do begin
if IsWindowVisible(Wnd) then begin
ChildRgn := CreateRectRgn(0, 0, 0, 0);
if GetWindowRgn(WND, ChildRgn) <= NULLREGION then begin
GetWindowRect(WND, TR);
TP.X := 0; TP.Y := 0;
ClientToScreen(Sender.fHandle, TP);
OffsetRect(TR, -TP.X , -TP.Y);
SetRectRgnInderect(ChildRgn, TR);
end;
OffsetRgn(ChildRgn, Sender.fParentCoordX, Sender.fParentCoordY);
{$IFDEF USE_PROP}
C := Pointer( GetProp( Wnd, ID_SELF ) );
{$ELSE}
C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
{$ENDIF}
if CombineRgn(ChildRgn, ChildRgn, Sender.fDblExcludeRgn, RGN_AND) >= SIMPLEREGION then begin
with C{-}^{+} do begin
if (C <> nil) and fTransparent then begin
Save := SaveDC( PDC );
fParentRequirePaint := TRUE;
L := Sender.fParentCoordX + Left;
T := Sender.fParentCoordY + Top;
SetWindowOrgEx(PDC, -L, -T, nil);
SendMessage(Wnd, WM_PRINT, PDC, PRF_NONCLIENT);
TP.x := 0; TP.Y := 0;
ClientToScreen(fHandle, TP);
GetWindowRect(fHandle, TR);
fParentCoordX := L + TP.X - TR.Left;
fParentCoordY := T + TP.Y - TR.Top;
SetWindowOrgEx(PDC, -fParentCoordX, -fParentCoordY, nil);
GetClientRect(Wnd, TR);
IntersectClipRect(PDC, 0, 0, TR.Right, TR.Bottom);
SendMessage(Wnd, WM_PAINT, PDC, 0);
fParentRequirePaint := FALSE;
RestoreDC( PDC, Save );
end else begin
CombineRgn(Sender.fDblExcludeRgn, Sender.fDblExcludeRgn, ChildRgn, RGN_DIFF);
end;
end;
end; // if Save >= SIMPLEREGION then begin
DeleteObject(ChildRgn);
end;
Wnd := GetWindow( Wnd, GW_HWNDPREV );
end;
Sender.fPaintDC := 0;
Sender.fSelfRequirePaint := FALSE;
if not Sender.fParentRequirePaint then begin
BLTDC := GetDCEx(Sender.fHandle, 0, DCX_CACHE or DCX_CLIPSIBLINGS);
ExtSelectClipRgn(BLTDC, Sender.fDblExcludeRgn, RGN_AND);
BitBlt(BLTDC, 0, 0, Margins.Right, Margins.Bottom, PDC, 0, 0, SRCCOPY );
ReleaseDC(Sender.fHandle, BLTDC);
DeleteObject(SelectObject( PDC, OLDp ));
DeleteObject(Sender.fDblExcludeRgn);
DeleteDC( PDC );
EndPaint(Sender.fHandle, PS);
end;
end;
end;
{$ENDIF}
//[END WndProcTransparent]
{$endif win32}
//[FUNCTION WndProcPaint]
{$IFDEF ASM_noVERSION}
function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
const szPaintStruct = sizeof(TPaintStruct);
asm
CMP word ptr [EDX].TMsg.message, WM_PRINT
JE @@print
CMP word ptr [EDX].TMsg.message, WM_PAINT
JNE @@ret_false
@@print:
CMP word ptr [EAX].TControl.fOnPaint.TMethod.Code+2, 0
JE @@ret_false
PUSH EBX
PUSH ESI
XCHG EBX, EAX
MOV ESI, EDX
XOR EAX, EAX
PUSH ECX
PUSH EAX
PUSH EAX
PUSH EAX
PUSH EAX
CALL CreateRectRgn
MOV [EBX].TControl.fUpdRgn, EAX
MOVSX EDX, [EBX].TControl.fEraseUpdRgn
PUSH EDX
PUSH EAX
PUSH [EBX].TControl.fHandle
CALL GetUpdateRgn
CMP EAX, 1
JA @@collectUpdRgn
XOR EAX, EAX
XCHG EAX, [EBX].TControl.fUpdRgn
PUSH EAX
CALL DeleteObject
@@collectUpdRgn:
MOV ECX, [EBX].TControl.fCollectUpdRgn
JECXZ @@asg_fPaintDC
XCHG EAX, ECX
MOV ECX, [EBX].TControl.fUpdRgn
JECXZ @@asg_fPaintDC
PUSH RGN_OR
PUSH ECX
PUSH EAX
PUSH EAX
CALL CombineRgn
DEC EAX
JNZ @@invalidateRgn
ADD ESP, -16
PUSH ESP
PUSH [EBX].TControl.fHandle
CALL Windows.GetClientRect
PUSH [EBX].TControl.fCollectUpdRgn
CALL DeleteObject
CALL CreateRectRgn
MOV [EBX].TControl.fCollectUpdRgn, EAX
@@invalidateRgn:
MOVSX EDX, [EBX].TControl.fEraseUpdRgn
PUSH EDX
PUSH [EBX].TControl.fCollectUpdRgn
PUSH [EBX].TControl.fHandle
CALL InvalidateRgn
@@asg_fPaintDC:
MOV ECX, [ESI].TMsg.wParam
INC ECX
LOOP @@storePaintDC
ADD ESP, -szPaintStruct
PUSH ESP
PUSH [EBX].TControl.fHandle
CALL BeginPaint
XCHG ECX, EAX
@@storePaintDC:
MOV [EBX].TControl.fPaintDC, ECX
XCHG EAX, ECX
MOV ECX, [EBX].TControl.fCollectUpdRgn
JECXZ @@doOnPaint
PUSH ECX
PUSH EAX
CALL SelectClipRgn
@@doOnPaint:
MOV ECX, [EBX].TControl.fPaintDC
MOV EDX, EBX
MOV EAX, [EBX].TControl.fOnPaint.TMethod.Data
CALL dword ptr [EBX].TControl.fOnPaint.TMethod.Code
MOV ECX, [EBX].TControl.fCanvas
JECXZ @@e_paint
XCHG EAX, ECX
XOR EDX, EDX
CALL TCanvas.SetHandle
@@e_paint:
MOV ECX, [ESI].TMsg.wParam
INC ECX
LOOP @@zero_fPaintDC
PUSH ESP
PUSH [EBX].TControl.fHandle
CALL EndPaint
ADD ESP, szPaintStruct
@@zero_fPaintDC:
XOR ECX, ECX
MOV [EBX].TControl.fPaintDC, ECX
POP EAX
MOV [EAX], ECX
XCHG ECX, [EBX].TControl.fUpdRgn
JECXZ @@exit_True
PUSH ECX
CALL DeleteObject
@@exit_True:
POP ESI
POP EBX
MOV AL, 1
RET
@@ret_false:
XOR EAX, EAX
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var PaintStruct: TPaintStruct;
Cplxity: Integer;
OldPaintDC: HDC;
begin
with Self_{-}^{+} do
case Msg.message of
//WM_PRINT,
WM_PAINT: if assigned( fOnPaint ) {or Assigned( fPaintProc )} then
begin
fUpdRgn := CreateRectRgn( 0, 0, 0, 0 );
Cplxity := Integer( GetUpdateRgn( fHandle, fUpdRgn, fEraseUpdRgn ) );
if (Cplxity = NULLREGION) or (Cplxity = ERROR) then
begin
DeleteObject( fUpdRgn );
fUpdRgn := 0;
end;
OldPaintDC := fPaintDC;
fPaintDC := Msg.wParam;
if fPaintDC = 0 then
fPaintDC := BeginPaint( fHandle, PaintStruct );
//if fUpdRgn <> 0 then added in v2.16
// SelectClipRgn( fPaintDC, fUpdRgn ); removed in v2.26
fOnPaint( Self_, fPaintDC );
if assigned( Self_.fCanvas ) then
Self_.fCanvas.SetHandle( 0 );
if Msg.wParam = 0 then
EndPaint( fHandle, PaintStruct );
fPaintDC := OldPaintDC;
Rslt := 0;
Result := True;
if fUpdRgn <> 0 then
DeleteObject( fUpdRgn );
fUpdRgn := 0;
Exit;
end;
end;
Result := FALSE;
end;
{$ENDIF ASM_VERSION}
//[END WndProcPaint]
{$ENDIF WIN_GDI}
//[procedure TControl.SetOnPaint]
{$IFDEF GDI}
procedure TControl.SetOnPaint( const Value: TOnPaint );
begin
fOnPaint := Value;
AttachProc( WndProcPaint );
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function expose_widget( Widget: PGtkWidget; Event: PGdkEventExpose;
Sender: PControl ): Boolean; cdecl;
begin
if not Assigned( Sender.fOnPaint ) then Result := FALSE
else
begin
Sender.Canvas.SaveState;
Sender.fOnPaint( Sender, Sender.Canvas.Handle );
Sender.Canvas.RestoreState;
Result := TRUE;
end;
end;
procedure TControl.SetOnPaint( const Value: TOnPaint );
begin
fOnPaint := Value;
{$IFNDEF SMALLER_CODE} // it is actually not necessary to disconnect, event
// still will be fired but fOnPaint is not assigned
// so FALSE will be returned to GTK.
if not Assigned( Value ) then
gtk_signal_disconnect( fHandle, fExposeEvent )
else
{$ENDIF}
fExposeEvent := gtk_signal_connect( GTK_OBJECT( fHandle ), 'expose_event',
@ expose_widget, @ Self );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//*
//[function WndProcEraseBkgnd]
function WndProcEraseBkgnd( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var PaintStruct: TPaintStruct;
OldPaintDC: HDC;
begin
Result := FALSE;
if Msg.message = WM_ERASEBKGND then
begin
if Assigned( Sender.OnEraseBkgnd ) then
begin
OldPaintDC := Sender.fPaintDC;
Sender.fPaintDC := Msg.wParam;
if Sender.fPaintDC = 0 then
Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct );
Sender.OnEraseBkgnd( Sender, Msg.wParam );
if Msg.wParam = 0 then
EndPaint( Sender.fHandle, PaintStruct );
if Assigned( Sender.fCanvas ) then
Sender.fCanvas.SetHandle( 0 );
Sender.fPaintDC := OldPaintDC;
Rslt := 0;
Result := TRUE;
end
else
Rslt := 0;
end;
end;
//[procedure TControl.SetOnEraseBkgnd]
procedure TControl.SetOnEraseBkgnd(const Value: TOnPaint);
begin
fOnEraseBkgnd := Value;
AttachProc( WndProcEraseBkgnd );
end;
procedure DummyPaintClear( Self_: PControl; Sender: PControl; DC: HDC );
begin
Sender.Canvas.FillRect( Sender.ClientRect );
end;
{$IFDEF NEW_GRADIENT}
function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var PaintStruct: TPaintStruct;
Bmp: PBitmap;
CR: TRect;
I: Integer;
R, G, B: Integer;
R1, G1, B1: Integer;
C: TColor;
W, H, WH: Integer;
OldPaintDC: HDC;
Pattern: PBitmap;
pdc: HDC;
pw: integer;
begin
case Msg.message of
WM_PAINT, WM_PRINTCLIENT:
begin
result := false;
CR := Self_.ClientRect;
case Self_.fGradientStyle of
gsHorizontal: begin
W := CR.Right;
H := 1;
WH := W;
pw := 32;
end;
gsVertical: begin
W := 1;
H := CR.Bottom;
WH := H;
pw := 32
end;
gsTopToBottom,
gsBottomToTop: begin
W := CR.Bottom + CR.Right;
H := 1;
WH := W;
pw := 1 + (CR.Bottom div 16);
if pw > 6 then
pw := 6;
end;
else exit;
// <-- impartant if user change GradientStyle to not supported by this object
end;
OldPaintDC := Self_.fPaintDC;
Self_.fPaintDC := Msg.wParam;
if Self_.fPaintDC = 0 then
Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );
Bmp := NewDIBBitmap( W, H, pf24bit );
C := Color2RGB( Self_.fColor1 );
R := C shr 16;
G := (C shr 8) and $FF;
B := C and $FF;
C := Color2RGB( Self_.fColor2 );
R1 := C shr 16;
G1 := (C shr 8) and $FF;
B1 := C and $FF;
for I := 0 to WH-1 do begin
C := (( R + (R1 - R) * I div WH ) shl 16) or
(( G + (G1 - G) * I div WH ) shl 8) or
( B + (B1 - B) * I div WH );
if Self_.fGradientStyle = gsVertical then
Bmp.DIBPixels[ 0, I ] := C
else
Bmp.DIBPixels[ I, 0 ] := C;
end;
if Self_.fGradientStyle = gsVertical then
Pattern := NewBitMap(pw, H)
else
Pattern := NewBitMap(W, pw);
pdc := Pattern.Canvas.Handle;
SetStretchBltMode( pdc, HALFTONE);
SetBrushOrgEx( pdc, 0, 0, nil );
StretchBlt( pdc, 0, 0, Pattern.Width, Pattern.Height, Bmp.Canvas.Handle,
0, 0, W, H, SRCCOPY );
case Self_.fGradientStyle of
gsHorizontal: for i := 0 to (CR.Bottom div pw) do
Pattern.Draw(Self_.fPaintDC, 0, i*pw);
gsVertical: for i := 0 to (CR.Right div pw) do
Pattern.Draw(Self_.fPaintDC, i*pw, 0);
gsTopToBottom: for i := 0 to ((CR.Bottom + pw -1) div pw)-1 do
Pattern.Draw(Self_.fPaintDC, -i*pw, i*pw);
gsBottomToTop: for i := 0 to ((CR.Bottom + pw -1) div pw)-1 do
Pattern.Draw(Self_.fPaintDC, -CR.Bottom + i*pw, i*pw);
end;
Bmp.Free;
Pattern.Free;
if TMethod( Self_.fOnPaint2 ).Code = @ DummyPaintClear then
Self_.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintProc ) );
if Assigned( Self_.fOnPaint ) then
Self_.fOnPaint( Self_, Self_.fPaintDC );
if Msg.wParam = 0 then
EndPaint( Self_.fHandle, PaintStruct );
Self_.fPaintDC := OldPaintDC;
Rslt := 0;
Result := True;
Exit;
end;
end;
Result := False;
end;
{$ELSE OLD_GRADIENT}
function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var PaintStruct: TPaintStruct;
CR: TRect;
I, R, G, B, R1, G1, B1, W, H, WH: Integer;
C: TColor;
{$ifdef win32}
W9x: Boolean;
Bmp: PBitmap;
{$endif win32}
Br: HBrush;
OldPaintDC: HDC;
begin
case Msg.message of
WM_PAINT, WM_PRINTCLIENT:
begin
OldPaintDC := Self_.fPaintDC;
Self_.fPaintDC := Msg.wParam;
if Self_.fPaintDC = 0 then
Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );
CR := Self_.ClientRect;
{$ifdef win32}
W9x := WinVer < wvNT;
Bmp := nil;
{$endif win32}
W := 1;
H := CR.Bottom;
WH := H;
if Self_.fGradientStyle = gsHorizontal then
begin
W := CR.Right;
H := 1;
WH := W;
end;
{$ifdef win32}
if not W9x then
Bmp := NewDIBBitmap( W, H, pf32bit );
{$endif win32}
C := Color2RGB( Self_.fColor1 );
R := C shr 16;
G := (C shr 8) and $FF;
B := C and $FF;
C := Color2RGB( Self_.fColor2 );
R1 := C shr 16;
G1 := (C shr 8) and $FF;
B1 := C and $FF;
for I := 0 to WH-1 do
begin
C := ((( R + (R1 - R) * I div WH ) and $FF) shl 16) or
((( G + (G1 - G) * I div WH ) and $FF) shl 8) or
( B + (B1 - B) * I div WH ) and $FF;
{$ifdef win32}
if W9x then
{$endif win32}
begin
if Self_.fGradientStyle <> gsHorizontal then
CR.Bottom := CR.Top + 1
else
CR.Right := CR.Left + 1;
Br := CreateSolidBrush( C );
Windows.FillRect( Self_.fPaintDC, CR, Br );
DeleteObject( Br );
if Self_.fGradientStyle <> gsHorizontal then
Inc( CR.Top )
else
Inc( CR.Left );
end
{$ifdef win32}
else
begin
if Self_.fGradientStyle <> gsHorizontal then
Bmp.DIBPixels[ 0, I ] := C
else
Bmp.DIBPixels[ I, 0 ] := C;
end;
{$endif win32}
end;
{$ifdef win32}
if not W9x then
begin
SetStretchBltMode( Self_.fPaintDC, HALFTONE );
SetBrushOrgEx( Self_.fPaintDC, 0, 0, nil );
StretchBlt( Self_.fPaintDC, 0, 0, CR.Right, CR.Bottom, Bmp.Canvas.Handle,
0, 0, W, H, SRCCOPY );
Bmp.Free;
end;
{$endif win32}
if TMethod( Self_.fOnPaint2 ).Code = @ DummyPaintClear then
Self_.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintProc ) );
if Assigned( Self_.fOnPaint ) then
Self_.fOnPaint( Self_, Self_.fPaintDC );
if Msg.wParam = 0 then
EndPaint( Self_.fHandle, PaintStruct );
Self_.fPaintDC := OldPaintDC;
Rslt := 0;
Result := True;
Exit;
end;
end;
Result := False;
end;
{$ENDIF OLD_GRADIENT}
//[END WndProcGradient]
//[function WndProcGradientEx]
function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
function Ceil( X: Double ): Integer;
begin
Result := Round( X ) {+ 1};
//if X > 0 then dec( Result ) else inc( Result );
end;
const
SQRT2 = 1.4142135623730950488016887242097;
var
RC, R0: TRect;
C, C2: TColor;
R1, G1, B1: Integer;
R2, G2, B2: Integer;
DX1, DX2, DY1, DY2, DR, DG, DB, K: Double;
PaintStruct: TPaintStruct;
I: Integer;
Br: HBrush;
Rgn: HRgn;
{$ifdef win32}
Poly: array[ 0..3 ] of TPoint;
{$endif win32}
OldPaintDC: HDC;
fX1, fX2, fY1, fY2: Double;
procedure OffsetF( DX, DY: Double );
begin
fX1 := fX1 + DX;
fX2 := fX2 + DX;
fY1 := fY1 + DY;
fY2 := fY2 + DY;
end;
begin
Result := FALSE;
if (Msg.message <> WM_PAINT) and (Msg.message <> WM_PRINTCLIENT) then Exit;
if Self_.fGradientStyle in [ gsHorizontal, gsVertical ] then
begin
Result := WndProcGradient( Self_, Msg, Rslt );
Exit;
end;
C := Color2RGB( Self_.fColor2 );
R2 := C and $FF;
G2 := (C shr 8) and $FF;
B2 := (C shr 16) and $FF;
C := Color2RGB( Self_.fColor1 );
R1 := C and $FF;
G1 := (C shr 8) and $FF;
B1 := (C shr 16) and $FF;
DR := (R2 - R1) / 256;
DG := (G2 - G1) / 256;
DB := (B2 - B1) / 256;
OldPaintDC := Self_.fPaintDC;
Self_.fPaintDC := Msg.wParam;
if Self_.fPaintDC = 0 then
Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );
RC := Self_.ClientRect;
fX1 := 0;
fY1 := 0;
case Self_.fGradientStyle of
gsRombic:
begin
fX2 := RC.Right / 128;
fY2 := RC.Bottom / 128;
end;
gsElliptic:
begin
fX2 := RC.Right / 256 * SQRT2;
fY2 := RC.Bottom / 256 * SQRT2;
end;
else
begin
fX2 := RC.Right / 256;
fY2 := RC.Bottom / 256;
end;
end;
case Self_.fGradientStyle of
gsRectangle, gsRombic, gsElliptic:
begin
case Self_.FGradientLayout of
glCenter, glTop, glBottom:
OffsetF( (RC.Right - fX2) / 2, 0 );
glTopRight, glBottomRight, glRight:
OffsetF( RC.Right - fX2 / 2, 0 );
glTopLeft, glBottomLeft, glLeft:
OffsetF( -fX2 / 2, 0 );
end;
case Self_.FGradientLayout of
glCenter, glLeft, glRight:
OffsetF( 0, (RC.Bottom - fY2) / 2 );
glBottom, glBottomLeft, glBottomRight:
OffsetF( 0, RC.Bottom - fY2 / 2 );
glTop, glTopLeft, glTopRight:
OffsetF( 0, -fY2 / 2 )
end;
end;
end;
DX1 := -fX1 / 255; //(-RF.Left) / 255;
DY1 := -fY1 / 255; // (-RF.Top) / 255;
DX2 := (RC.Right - fX2) / 255; //(RC.Right - RF.Right) / 255;
DY2 := (RC.Bottom - fY2) / 255;
case Self_.fGradientStyle of
gsRombic, gsElliptic:
begin
if DX2 < -DX1 then DX2 := -DX1;
if DY2 < -DY1 then DY2 := -DY1;
K := 2;
if Self_.fGradientStyle = gsElliptic then K := SQRT2;
DX2 := DX2 * K;
DY2 := DY2 * K;
DX1 := -DX2;
DY1 := -DY2;
end;
end;
C2 := C;
for I := 0 to 255 do
begin
if (I < 255) then
begin
C2 := TColor( (( Ceil( B1 + DB * (I+1) ) and $FF) shl 16) or
(( Ceil( G1 + DG * (I+1) ) and $FF) shl 8) or
Ceil( R1 + DR * (I+1) ) and $FF );
if (Self_.fGradientStyle in [gsRombic,gsElliptic,gsRectangle]) and
(C2 = C) then continue;
end;
Br := CreateSolidBrush( C );
R0 := MakeRect( Ceil( fX1 + DX1 * I ),
Ceil( fY1 + DY1 * I ),
Ceil( fX2 + DX2 * I ) + 1,
Ceil( fY2 + DY2 * I ) + 1 );
Rgn := 0;
{$ifdef wince}
Rgn := CreateRectRgnIndirect( R0 );
{$else}
case Self_.fGradientStyle of
gsRectangle:
Rgn := CreateRectRgnIndirect( R0 );
gsRombic:
begin
Poly[ 0 ].x := R0.Left;
Poly[ 0 ].y := R0.Top + (R0.Bottom - R0.Top) div 2;
Poly[ 1 ].x := R0.Left + (R0.Right - R0.Left) div 2;
Poly[ 1 ].y := R0.Top;
Poly[ 2 ].x := R0.Right;
Poly[ 2 ].y := Poly[ 0 ].y;
Poly[ 3 ].x := Poly[ 1 ].x;
Poly[ 3 ].y := R0.Bottom;
Rgn := CreatePolygonRgn( Poly[ 0 ].x, 4, ALTERNATE );
end;
gsElliptic:
Rgn := CreateEllipticRgnIndirect( R0 );
end;
{$endif wince}
if Rgn <> 0 then
begin
if Rgn <> NULLREGION then
begin
Windows.FillRgn( Self_.fPaintDC, Rgn, Br );
{$ifdef win32}
ExtSelectClipRgn( Self_.fPaintDC, Rgn, RGN_DIFF );
{$endif win32}
end;
DeleteObject( Rgn );
end;
DeleteObject( Br );
C := C2;
end;
if TMethod( Self_.fOnPaint2 ).Code = @ DummyPaintClear then
Self_.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintProc ) );
if Assigned( Self_.fOnPaint ) then
Self_.fOnPaint( Self_, Self_.fPaintDC );
if Self_.fPaintDC <> HDC( Msg.wParam ) then
EndPaint( Self_.fHandle, PaintStruct );
Self_.fPaintDC := OldPaintDC;
Rslt := 0;
Result := True;
end;
//*
//[function WndProcLabelEffect]
function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var
Sz: TSize;
P0: TPoint;
CR: TRect;
B : Boolean;
CShadow: TColor;
Target: PCanvas;
Txt: KOLString;
//LCaption: PKOLChar;
OldPaintDC: HDC;
procedure doTextOut( shfx, shfy: Integer; col: TColor );
begin
SetTextColor( Target.fHandle, col );
Windows.
{$IFDEF UNICODE_CTRLS}
ExtTextOutW
{$ELSE}
ExtTextOut
{$ENDIF}
( Target.fHandle, P0.x + shfx, P0.y + shfy,
ETO_CLIPPED, @CR,
PKOLChar(Txt), Length(Txt), nil );
//GDIFlush; // for test only
end;
var I, J, Istp : Integer;
PS: TPaintStruct;
//DoEndPaint: Boolean;
begin
Result := False;
case Msg.message of
WM_SETTEXT:
begin
Self_.fCaption := PKOLChar( Msg.lParam );
Result := True;
Rslt := 1;
Exit;
end;
WM_PRINTCLIENT, WM_PAINT:
begin
OldPaintDC := Self_.fPaintDC;
Self_.fPaintDC := Msg.wParam;
if Self_.fPaintDC = 0 then
Self_.fPaintDC := BeginPaint( Self_.fHandle, PS );
begin
Target := Self_.Canvas;
Txt := Self_.fCaption;
Target.TextArea( Txt, Sz, P0 );
if Self_.fShadowDeep <> 0 then
begin
for B := False to Self_.fCtl3D do
begin
Inc( Sz.cx, Abs( Self_.fShadowDeep ) );
Inc( Sz.cy, Abs( Self_.fShadowDeep ) );
end;
end;
CR := Self_.ClientRect;
case Self_.fTextAlign of
taCenter: P0.x := P0.x + (CR.Right - Sz.cx) div 2;
taRight: P0.x := P0.x + (CR.Right - Sz.cx);
end;
case Self_.fVerticalAlign of
vaCenter: P0.y := P0.y + (CR.Bottom - Sz.cy) div 2;
vaBottom: P0.y := P0.y + (CR.Bottom - Sz.cy);
end;
if Self_.fShadowDeep <> 0 then
begin
if Self_.fColor2 = clNone then
CShadow := ColorsMix(Color2RGB(Self_.fTextColor),Color2RGB(Self_.fColor2))
else
CShadow := Color2RGB( Self_.fColor2 );
if not Self_.fTransparent then
Target.FillRect( CR ); // GDIFlush; for test only
//Target.DeselectHandles;
Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
SetBkMode( Target.fHandle, Windows.TRANSPARENT );
if Self_.fCtl3D then
begin
I := - Self_.fShadowDeep;
Istp := 1;
if Self_.ShadowDeep > 0 then Istp := -1;
repeat
J := - Self_.fShadowDeep;
repeat
if not ( (I=0) and (J=0) ) then
begin
if (I * Istp < 0) and (J * Istp < 0) then
begin
doTextOut( I, J, CShadow );
end;
end;
J := J - Istp;
until J = Self_.fShadowDeep - IStp;
I := I - Istp;
until I = Self_.fShadowDeep - IStp;
end
else
doTextout( Self_.fShadowDeep, Self_.fShadowdeep, CShadow );
doTextout( 0, 0, Color2RGB(Self_.fTextColor) );
end
else
begin
Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
SetBkMode( Target.fHandle, Windows.TRANSPARENT );
doTextout( 0, 0, Color2RGB(Self_.fTextColor) );
end;
end;
if assigned( Self_.fCanvas ) then
Self_.fCanvas.SetHandle( 0 );
if MSg.wParam = 0 then
EndPaint( Self_.fHandle, PS );
Self_.fPaintDC := OldPaintDC;
Rslt := 0;
Result := True;
Exit;
end;
end;
end;
//[procedure TControl.DoClick]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.DoClick;
begin
fControlClick( @Self );
if Assigned( fOnClick ) then
fOnClick( @Self );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[function TControl.ParentForm]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.ParentForm: PControl;
begin
Result := @Self;
if Result.fIsControl then
repeat
Result := Result.fParent;
until (Result = nil) or not Result.fIsControl;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[procedure TControl.SetProgressColor]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetProgressColor(const Value: TColor);
begin
{$ifdef win32}
if Perform( PBM_SETBARCOLOR, 0, Color2RGB(Value) ) <> 0 then
fTextColor := Value;
{$endif win32}
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetShadowDeep]
procedure TControl.SetShadowDeep(const Value: Integer);
begin
fShadowDeep := Value;
Invalidate;
end;
{$ENDIF WIN_GDI}
//[function TControl.GetFont]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetFont: PGraphicTool;
begin
if FFont = nil then
begin
FFont := NewFont;
{$IFDEF USE_AUTOFREE4CONTROLS}
Add2AutoFree( FFont );
{$ENDIF}
FFont.fData.Color := fTextColor;
FFont.OnChange := FontChanged;
end;
Result := FFont;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[function TControl.GetBrush]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetBrush: PGraphicTool;
begin
if FBrush = nil then
begin
FBrush := NewBrush;
FBrush.fData.Color := fColor;
FBrush.OnChange := BrushChanged;
{$IFDEF USE_AUTOFREE4CONTROLS}
Add2AutoFree( FBrush );
{$ENDIF}
end;
Result := FBrush;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[procedure TControl.FontChanged]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.FontChanged(Sender: PGraphicTool);
begin
fTextColor := Sender.fData.Color;
ApplyFont2Wnd;
Invalidate;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[procedure TControl.BrushChanged]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.BrushChanged(Sender: PGraphicTool);
begin
fColor := Sender.fData.Color;
if fTmpBrush <> 0 then
begin
DeleteObject( fTmpBrush );
fTmpBrush := 0;
end;
if fPaintDC = 0 then
// only if not in painting already :
Invalidate;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
//[procedure DoApplyFont2Wnd]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure DoApplyFont2Wnd( _Self: PControl );
begin
if _Self.fFont <> nil then
begin
if _Self.fHandle <> 0 then
begin
_Self.fTextColor := _Self.fFont.fData.Color;
_Self.Perform( WM_SETFONT, _Self.FFont.Handle, 1 );
end;
if (_Self.fCanvas <> nil) and (_Self.fCanvas.fFont <> nil) then
_Self.fCanvas.fFont.Assign(_Self.fFont);
if Assigned( _Self.fAutoSize ) then
_Self.fAutoSize( _Self );
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure DoApplyFont2Wnd( _Self: PControl );
var oldfontdesc: PPangoFontDescription;
rcstyle: PGtkRcStyle;
gcolor: TGdkColor;
i: Integer;
begin
if Assigned( _Self.fFont ) then
begin
gcolor := Color2GdkColor( _Self.fFont.Color );
rcstyle := gtk_widget_get_modifier_style( _Self.fHandle );
oldfontdesc := rcstyle.font_desc;
rcstyle.font_desc :=
pango_font_description_copy( _Self.fFont.GetPangoFontDesc );
gtk_widget_modify_style( _Self.fHandle, rcstyle );
if oldfontdesc <> nil then
pango_font_description_free( oldfontdesc );
for i := 0 to 4 do
gtk_widget_modify_fg( _Self.fCaptionHandle, {GTK_STATE_NORMAL} i, @ gcolor );
end;
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TControl.ApplyFont2Wnd]
procedure TControl.ApplyFont2Wnd;
begin
if Assigned( ApplyFont2Wnd_Proc ) then
ApplyFont2Wnd_Proc( @ Self );
end;
{$IFDEF WIN_GDI}
//[function TControl.ResizeParent]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.ResizeParent: PControl;
begin
ResizeParentBottom;
ResizeParentRight;
// Once again, to fix Windows (or my???) bug with
// incorrect calculating of GetClientRect after
// SetWindowLong( GWL_[EX}STYLE,... )
Result := ResizeParentBottom;
end;
{$ENDIF ASM_VERSION}
//[function TControl.ResizeParentBottom]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.ResizeParentBottom: PControl;
var NewCH: Integer;
begin
Result := @Self;
if fParent <> nil then
begin
NewCH := BoundsRect.Bottom + fParent.fMargin;
if (fParent.fChangedPosSz and $20) <> 0 then
if NewCH <> fParent.ClientHeight then Exit;
fParent.ClientHeight := NewCH;
fParent.fChangedPosSz := fParent.fChangedPosSz or $20;
end;
end;
{$ENDIF ASM_VERSION}
//[function TControl.ResizeParentRight]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.ResizeParentRight: PControl;
var NewCW: Integer;
begin
Result := @Self;
if fParent <> nil then
begin
NewCW := fBoundsRect.Right + fParent.fMargin;
if (fParent.fChangedPosSz and $10) <> 0 then
if NewCW < fParent.ClientWidth then Exit;
fParent.ClientWidth := NewCW;
fParent.fChangedPosSz := fParent.fChangedPosSz or $10;
end;
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetClientHeight]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetClientHeight: Integer;
begin
with ClientRect do
Result := Bottom - Top;
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetClientWidth]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetClientWidth: Integer;
begin
with ClientRect do
Result := Right - Left;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetClientHeight]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetClientHeight(const Value: Integer);
var Delta: Integer;
begin
Delta := ClientHeight;
Delta := Height - Delta;
Height := Value + Delta;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetClientWidth]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetClientWidth(const Value: Integer);
var Delta: Integer;
begin
Delta := ClientWidth;
Delta := Width - Delta;
Width := Value + Delta;
end;
{$ENDIF ASM_VERSION}
//[function TControl.CenterOnParent]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.CenterOnParent: PControl;
var PCR: TRect;
begin
Result := @Self;
if (fParent = nil) or not fIsControl then
PCR := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) )
else
PCR := fParent.ClientRect;
GetWindowHandle;
Left := (PCR.Right - PCR.Left - Width) div 2;
Top := (PCR.Bottom - PCR.Top - Height) div 2;
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetHasBorder]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetHasBorder: Boolean;
begin
UpdateWndStyles;
Result := LongBool( fStyle and (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME))
or LongBool( fExStyle and WS_EX_CLIENTEDGE );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_noVERSION} // YS
//[procedure TControl.SetHasBorder]
procedure TControl.SetHasBorder(const Value: Boolean);
const style_mask = WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION
or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU;
exstyle_mask = not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME
or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE);
asm
PUSH EAX
PUSH EDX
CALL GetHasBorder
POP ECX
CMP AL, CL
POP EAX
JZ @@exit
MOV EDX, [EAX].fStyle
DEC CL
MOVZX ECX, [EAX].fIsControl
JNZ @@1
OR EDX, WS_THICKFRAME
INC ECX
LOOP @@set_style
OR EDX, style_mask
JMP @@set_style
@@1: AND EDX, not style_mask
INC ECX
LOOP @@2
OR EDX, WS_POPUP
@@2: PUSH EDX
MOV EDX, [EAX].fExStyle
AND EDX, exstyle_mask
PUSH EAX
CALL SetExStyle
POP EAX
POP EDX
@@set_style:
TEST [EAX].fTabStop, 1
JZ @@no_tabstop
OR DX, WS_TABSTOP
JMP @@set_style_1
@@no_tabstop:
AND DX, not WS_TABSTOP
@@set_style_1:
CALL SetStyle
@@exit:
end;
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetHasBorder(const Value: Boolean);
var NewStyle: DWORD;
begin
if Value = GetHasBorder then Exit;
if Value then
begin
if not fIsControl then
Style := fStyle or WS_BORDER or WS_CAPTION or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU
{$ifdef win32}or WS_THICKFRAME or WS_DLGFRAME{$endif}
else
{$ifdef win32}
if fCtl3D then
ExStyle := fExStyle or WS_EX_CLIENTEDGE
else
{$endif win32}
Style := fStyle or WS_BORDER;
end
else
begin
NewStyle := fStyle and not (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION
or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU);
{$ifdef win32}
if not fIsControl then NewStyle := NewStyle or WS_POPUP;
{$endif win32}
Style := NewStyle;
{$ifdef win32}
ExStyle := fExStyle and not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME
or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE);
{$endif win32}
end;
//+MTsv DN
if fIsControl then
if fTabStop then Style := fStyle or WS_TABSTOP
else Style := fStyle {xor} and not WS_TABSTOP;
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetHasCaption]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetHasCaption: Boolean;
begin
UpdateWndStyles;
Result := LongBool( fStyle and (WS_CAPTION xor WS_BORDER));
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetHasCaption]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetHasCaption(const Value: Boolean);
begin
if Value = GetHasCaption then Exit;
if Value then
begin
Style := fStyle {$ifdef win32}and not (WS_POPUP or WS_DLGFRAME){$endif} or WS_CAPTION;
end
else
begin
if fIsControl then
Style := fStyle and not WS_CAPTION or WS_DLGFRAME
else
Style := fStyle and not (WS_CAPTION or WS_SYSMENU xor WS_BORDER){$ifdef win32} or WS_POPUP{$endif};
{$ifdef win32}
ExStyle := fExStyle or WS_EX_DLGMODALFRAME;
{$endif win32}
end;
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetCanResize]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetCanResize: Boolean;
begin
//UpdateWndStyles;
//Result := LongBool( fStyle and WS_THICKFRAME);
Result := not fPreventResize;
end;
{$ENDIF ASM_VERSION}
//[function WndProcCanResize]
function WndProcCanResize( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;
var W, H: Integer;
P: PMinMaxInfo;
begin
if not Sender.CanResize then
if M.message = WM_GETMINMAXINFO then
begin
Rslt := Sender.CallDefWndProc( M );
W := Sender.FFixWidth;
H := Sender.FFixHeight;
P := Pointer( M.lParam );
P.ptMinTrackSize.x := W;
P.ptMinTrackSize.y := H;
P.ptMaxTrackSize := P.ptMinTrackSize;
Result := True; // stop further processing (prevent resizing)
Exit;
end
else
{$ifdef win32}
if M.message = WM_NCHITTEST then
begin
Rslt := Sender.CallDefWndProc( M );
if (Rslt >= 10) and (Rslt <= 17) then
begin
{$IFDEF CANRESIZE_THICKFRAME}
Rslt := {-}HTBORDER{+}{++}(*18{HTBORDER}*){--};
{$ELSE}
Rslt := HTNOWHERE;
{$ENDIF}
Result := True;
exit;
end;
end
{$endif win32};
Result := False; // continue message processing
end;
//[procedure TControl.SetCanResize]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetCanResize( const Value: Boolean );
begin
if Value = CanResize then Exit;
fPreventResize := not Value;
{$IFDEF CANRESIZE_THICKFRAME}
if Value then
Style := Style or WS_THICKFRAME
else
Style := Style and not WS_THICKFRAME;
{$ENDIF}
GetWindowHandle;
FFixWidth := Width;
FFixHeight := Height;
AttachProc( WndProcCanResize );
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetStayOnTop]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetStayOnTop: Boolean;
begin
UpdateWndStyles;
Result := LongBool( fExStyle and WS_EX_TOPMOST);
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetStayOnTop]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetStayOnTop(const Value: Boolean);
begin
if Value = GetStayOnTop then Exit;
if fHandle <> 0 then
if Value then
SetWindowPos( fHandle, HWND_TOPMOST, 0,0,0,0,
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )
else
SetWindowPos( fHandle, HWND_NOTOPMOST, 0,0,0,0,
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )
else
if Value then fExStyle := fExStyle or WS_EX_TOPMOST
else fExStyle := fExStyle and not WS_EX_TOPMOST;
end;
{$ENDIF ASM_VERSION}
//[function TControl.UpdateWndStyles]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.UpdateWndStyles: PControl;
begin
Result := @Self;
if fHandle = 0 then Exit;
fStyle := GetWindowLong( fHandle, GWL_STYLE );
fExStyle := GetWindowLong( fHandle, GWL_EXSTYLE );
fClsStyle := GetClassLong( fHandle, GCL_STYLE );
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetChecked]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetChecked: Boolean;
begin
if bboFixed in fBitBtnOptions then
Result := fChecked
else
Result := LongBool( Perform( BM_GETCHECK, 0, 0 ) ) ; //= BST_CHECKED;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.Set_Checked]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.Set_Checked(const Value: Boolean);
begin
if bboFixed in fBitBtnOptions then
begin
fChecked := Value;
Invalidate;
end
else
Perform( BM_SETCHECK, Integer( Value ), 0 );
end;
{$ENDIF ASM_VERSION}
//[function TControl.SetChecked]
function TControl.SetChecked(const Value: Boolean): PControl;
begin
Perform( BM_SETCHECK, Integer( Value ), 0 );
Result := @Self;
end;
//[function TControl.SetRadioCheckedOld]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.SetRadioCheckedOld: PControl;
begin
Result := @Self;
if fParent = nil then Exit;
CheckRadioButton( fParent.GetWindowHandle,
fParent.fRadio1st,
fParent.fRadioLast,
fMenu );
end;
{$ENDIF ASM_VERSION}
//*
//[function TControl.SetRadioChecked]
{$IFDEF ASM_VERSION}
{$ELSE PAS_VERSION}
function TControl.SetRadioChecked: PControl;
var WasTabStop: Boolean;
begin
WasTabStop := fTabStop;
fTabStop := FALSE;
DoClick;
fTabStop := WasTabStop;
Result := @Self;
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetCheck3]
function TControl.GetCheck3: TTriStateCheck;
begin
Result := TTriStateCheck(Perform(BM_GETCHECK, 0, 0) and 3);
end;
//[procedure TControl.SetCheck3]
procedure TControl.SetCheck3(value: TTriStateCheck);
var
wp: WPARAM;
begin
wp := Perform(BM_GETCHECK, 0, 0) and not 3;
wp := wp or WPARAM(ord(value));
Perform(BM_SETCHECK, wp, 0);
end;
//*
//[procedure TControl.Click]
procedure TControl.Click;
begin
if (fCommandActions.aClick <> 0) or
(fCommandActions.aEnter = BN_SETFOCUS) then
Perform( WM_COMMAND, (fCommandActions.aClick shl 16) or fMenu,
GetWindowHandle )
else
begin
Perform( WM_LBUTTONDOWN, MK_LBUTTON, 0 );
Perform( WM_LBUTTONUP, MK_LBUTTON, 0 );
end;
end;
type
TCharRange = record
cpMin: Longint;
cpMax: LongInt;
end;
//[function TControl.GetSelStart]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetSelStart: Integer;
//var SR: TCharRange;
begin
Result := 0;
if fCommandActions.aGetSelRange <> 0 then
//Result := LoWord( Perform( fCommandActions.aGetSelRange, 0, 0 ) )
Perform( fCommandActions.aGetSelRange, Integer( @ Result ), 0 )
{else
if fCommandActions.aExGetSelRange <> 0 then
begin
Perform( fCommandActions.aExGetSelRange, 0, Integer( @SR ) );
Result := SR.cpMin;
end};
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetSelStart]
procedure TControl.SetSelStart(const Value: Integer);
begin
ItemSelected[ Value ] := True;
end;
//[function TControl.GetSelLength]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetSelLength: Integer;
var Start, Finish: Integer;
begin
Result := 0;
if fCommandActions.aGetSelCount <> 0 then
begin
if fCommandActions.aGetSelCount = EM_GETSEL then
begin
Perform( fCommandActions.aGetSelCount, Integer( @ Start ), Integer( @ Finish ) );
Result := Finish - Start;
end
else
begin
Result := Perform( fCommandActions.aGetSelCount {and $7FFF}, 0, 0 );
end;
end
{else
if fCommandActions.aExGetSelRange <> 0 then
begin
Perform( fCommandActions.aExGetSelRange, 0, Integer( @SR ) );
Result := SR.cpMax - SR.cpMin;
end};
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetSelLength]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetSelLength(const Value: Integer);
var SR: TCharRange;
begin
SR.cpMin := GetSelStart;
SR.cpMax := SR.cpMin + Value;
if Value < 0 then
SR.cpMax := -1;
if fCommandActions.aSetSelRange <> 0 then
Perform( fCommandActions.aSetSelRange, SR.cpMin, SR.cpMax )
else
if fCommandActions.aExSetSelRange <> 0 then
Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );
// Preform( EM_SCROLLCARET, 0, 0 );
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetItems]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetItems(Idx: Integer): KOLString;
var L, Pos: Integer;
Buf: PKOLChar;
begin
Result := '';
Pos := Item2Pos( Idx );
Idx := Pos2Item( Pos );
if fCommandActions.aGetItemLength <> 0 then
L := Perform( fCommandActions.aGetItemLength, Pos, 0 )
else
Exit;
if L = 0 then Exit;
GetMem( Buf, (L + 4) * SizeOf( KOLChar ) );
PDWORD( Buf )^ := L + 1;
if fCommandActions.aGetItemText <> 0 then
Perform( fCommandActions.aGetItemText, Idx, Integer( Buf ) );
Buf[ L ] := #0;
Result := Buf;
FreeMem( Buf );
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetItems]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetItems(Idx: Integer; const Value: KOLString);
var Strt, L : DWORD;
{$IFNDEF NOT_FIX_CURINDEX}
TmpCurIdx: Integer; // AK - Andrzey Kubasek
TmpData: DWORD;
{$ENDIF NOT_FIX_CURINDEX}
begin
if fCommandActions.aSetItemText <> 0 then
begin
Strt := Item2Pos( Idx );
L := Item2Pos( Idx + 1 ) - Strt;
SelStart := Strt;
SelLength := L;
Perform( fCommandActions.aSetItemText, 0, Integer( PKOLChar( Value ) ) );
end
else
if fCommandActions.aDeleteItem <> 0 then
begin
{$IFNDEF NOT_FIX_CURINDEX}
TmpCurIdx := CurIndex; // +AK
TmpData := ItemData[ Idx ];
{$ENDIF}
Delete( Idx );
Insert( Idx, Value );
{$IFNDEF NOT_FIX_CURINDEX}
CurIndex := TmpCurIdx; //+AK
ItemData[ Idx ] := TmpData;
{$ENDIF}
end;
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetItemsCount]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetItemsCount: Integer;
begin
Result := 0;
{$IFDEF DEBUG}
try
{$ENDIF}
if fCommandActions.aGetCount = 0 then Exit;
Result := Perform( fCommandActions.aGetCount, 0, 0 );
{$IFDEF DEBUG}
except
asm
int 3
end;
end;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//*
//[procedure TControl.SetItemsCount]
procedure TControl.SetItemsCount(const Value: Integer);
begin
if fCommandActions.aSetCount = 0 then Exit;
Perform( fCommandActions.aSetCount, Value, 0 );
end;
//[function TControl.Item2Pos]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.Item2Pos(ItemIdx: Integer): DWORD;
begin
Result := ItemIdx;
if fCommandActions.aItem2Pos <> 0 then
begin
Result := Perform( fCommandActions.aItem2Pos, ItemIdx, 0 );
//if Result < 0 then Result := 0;
end;
end;
{$ENDIF ASM_VERSION}
//[function TControl.Pos2Item]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.Pos2Item(Pos: Integer): DWORD;
begin
Result := Pos;
if fCommandActions.aPos2Item <> 0 then
Result := Perform( fCommandActions.aPos2Item, Pos, 0 );
end;
{$ENDIF ASM_VERSION}
function TControl.SavePosition: TEditPositions;
var {$IFNDEF NOT_USE_RICHEDIT}
p: TPoint;
{$ENDIF USE_RICHEDIT}
i: Integer;
begin
Result.SelStart := SelStart;
Result.SelLength := SelLength;
{$IFNDEF NOT_USE_RICHEDIT}
if fCannotDoubleBuf { TRUE for rich edit, FALSE for edit } then
begin
P.X := 0;
P.Y := 0;
i := Perform( EM_CHARFROMPOS, 0, Integer( @ P ) );
Result.TopLine := Pos2Item( i );
Result.TopColumn := i - Integer( Item2Pos( Result.TopLine ) );
{$ifdef win32}
Perform( EM_GETSCROLLPOS, 0, Integer( @ Result.ScrollPos ) );
{$else}
Result.ScrollPos.x:=0;
Result.ScrollPos.y:=0;
{$endif win32}
end
else
{$ENDIF USE_RICHEDIT}
begin
i := 0;
i := Perform( EM_CHARFROMPOS, 0, i );
Result.TopLine := HiWord( i );
Result.TopColumn := LoWord( i ) - Item2Pos( Result.TopLine );
Result.ScrollPos.Y := GetScrollPos( Handle, SB_VERT );
Result.ScrollPos.X := GetScrollPos( Handle, SB_HORZ );
end;
Result.RestoreScroll := TRUE;
end;
procedure TControl.RestorePosition( const P: TEditPositions );
var Cur: TEditPositions;
begin
SelStart := P.SelStart;
SelLength := P.SelLength;
if P.RestoreScroll then
begin
Perform( EM_SCROLLCARET, 0, 0 );
Cur := SavePosition;
{$IFNDEF NOT_USE_RICHEDIT}
if fCannotDoubleBuf then
begin // RichEdit
if P.TopLine <> Cur.TopLine then
Perform( EM_LINESCROLL, 0, P.TopLine - Cur.TopLine );
{$ifdef win32}
Perform( EM_SETSCROLLPOS, 0, Integer( @ P.ScrollPos ) );
{$endif win32}
end
else // Edit
{$ENDIF USE_RICHEDIT}
begin
if (P.TopLine <> Cur.TopLine) or
(P.TopColumn <> Cur.TopColumn) then
Perform( EM_LINESCROLL, P.TopColumn - Cur.TopColumn,
P.TopLine - Cur.TopLine );
SetScrollPos( Handle, SB_VERT, P.ScrollPos.Y, TRUE );
SetScrollPos( Handle, SB_HORZ, P.ScrollPos.X, TRUE );
end;
end;
end;
procedure TControl.UpdatePosition( var p: TEditPositions; FromPos,
CountInsertDelChars, CountInsertDelLines: Integer );
var d: Integer;
begin
if (FromPos <= p.SelStart) and (CountInsertDelChars >= 0) or
(CountInsertDelChars < 0) and
((FromPos + Abs( CountInsertDelChars ) <= p.SelStart)
) then
begin
p.SelStart := p.SelStart + CountInsertDelChars;
end
else
if FromPos >= p.SelStart + p.SelLength then
begin
// nothing to do
end
else
if CountInsertDelChars < 0 then // deleting
begin
if FromPos - CountInsertDelChars > p.SelStart + p.SelLength then
CountInsertDelChars := -( p.SelStart + p.SelLength - FromPos );
if FromPos - CountInsertDelChars >= p.SelStart then
begin
d := FromPos - CountInsertDelChars - p.SelStart;
p.SelLength := p.SelLength - d;
//inc( CountInsertDelChars, d );
end;
inc( p.SelStart, CountInsertDelChars );
end
else // inserting
begin
if (FromPos > p.SelStart) and (FromPos < p.SelStart + p.SelLength) then
inc( p.SelLength, CountInsertDelChars )
else
if FromPos <= p.SelStart then
inc( p.SelStart, CountInsertDelChars );
end;
p.TopLine := p.TopLine + CountInsertDelLines;
end;
//[function WndProcTabChar]
function WndProcTabChar( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;
begin
if M.message = WM_CHAR then
begin
if M.wParam = 9 then
Sender.ReplaceSelection( #9, TRUE );
end;
Result := FALSE;
end;
//[function TControl.EditTabChar]
function TControl.EditTabChar: PControl;
begin
AttachProc( WndProcTabChar );
Result := @Self;
end;
//[function TControl.Add]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TControl.Add(const S: KOLString): Integer;
begin
if fCommandActions.aAddItem <> 0 then
begin
Result := Perform( fCommandActions.aAddItem, 0, Integer( PKOLChar( S ) ) );
if Count = 1 then
ItemSelected[ 0 ] := True;
end
else
begin
if assigned( fCommandActions.aAddText ) then
fCommandActions.aAddText( @Self, S )
else
Text := Text + S;
Result := 0;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.Delete]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.Delete(Idx: Integer);
begin
if fCommandActions.aDeleteItem <> 0 then
Perform( fCommandActions.aDeleteItem, Idx, 0 );
end;
{$ENDIF ASM_VERSION}
//[function TControl.Insert]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TControl.Insert(Idx: Integer; const S: KOLString): Integer;
begin
if fCommandActions.aInsertItem <> 0 then
Result := Perform( fCommandActions.aInsertItem, Idx, Integer( PKOLChar( S ) ) )
else
Result := -1;
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetItemSelected]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetItemSelected(ItemIdx: Integer): Boolean;
var SS: Integer;
begin
if fCommandActions.aGetSelected <> 0 then
begin
SS := Perform( fCommandActions.aGetSelected, ItemIdx, LVIS_SELECTED );
{ Though it is written in docs that for combobox lParam for CB_GETCURSEL
is not used and _must_ be 0, therefore this code is working for
combobox too. }
if fCommandActions.aGetSelected <> CB_GETCURSEL then
ItemIdx := 1;
Result := SS = ItemIdx;
end
else
begin
SS := SelStart;
Result := (ItemIdx >= SS) and (ItemIdx < SS + SelLength);
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetItemSelected]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetItemSelected(ItemIdx: Integer; const Value: Boolean);
var SR: TCharRange;
begin
if fCommandActions.aSetSelected <> 0 then
Perform( fCommandActions.aSetSelected, Integer( Value ), ItemIdx )
else
if fCommandActions.aSetCurrent <> 0 then
Perform( fCommandActions.aSetCurrent, ItemIdx, 0 )
else
if fCommandActions.aSetSelRange <> 0 then
Perform( fCommandActions.aSetSelRange, ItemIdx, ItemIdx )
else
if fCommandActions.aExSetSelRange <> 0 then
begin
SR.cpMin := ItemIdx;
SR.cpMax := ItemIdx;
Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );
end
else
begin // for ImageShow: set the index and invalidate the control
FCurIndex := ItemIdx;
Invalidate;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetCtl3D]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetCtl3D(const Value: Boolean);
begin
fCtl3Dchild := Value;
//if fCtl3D = Value then Exit;
fCtl3D := Value;
{$ifdef win32}
UpdateWndStyles;
if Value then
begin
Style := fStyle and not WS_BORDER;
ExStyle := fExStyle or WS_EX_CLIENTEDGE;
end
else
begin
Style := fStyle or WS_BORDER;
ExStyle := fExStyle and not WS_EX_CLIENTEDGE;
end;
{$endif win32}
end;
{$ENDIF ASM_VERSION}
//[function TControl.Shift]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.Shift(dX, dY: Integer): PControl;
begin
Left := fBoundsRect.Left + dX;
Top := fBoundsRect.Top + dY;
Result := @Self;
end;
{$ENDIF ASM_VERSION}
//[procedure SetKeyEvent]
procedure SetKeyEvent( Self_: PControl );
begin
Self_.fWndProcKeybd := WndProcKeybd;
end;
//[procedure TControl.SetOnChar]
procedure TControl.SetOnChar(const Value: TOnChar);
begin
fOnChar := Value;
SetKeyEvent( @Self );
end;
{$IFDEF SUPPORT_ONDEADCHAR}
//[procedure TControl.SetOnChar]
procedure TControl.SetOnDeadChar(const Value: TOnChar);
begin
fOnDeadChar := Value;
SetKeyEvent( @Self );
end;
{$ENDIF SUPPORT_ONDEADCHAR}
//[procedure TControl.SetOnKeyDown]
procedure TControl.SetOnKeyDown(const Value: TOnKey);
begin
fOnKeyDown := Value;
SetKeyEvent( @Self );
end;
//[procedure TControl.SetOnKeyUp]
procedure TControl.SetOnKeyUp(const Value: TOnKey);
begin
fOnKeyUp := Value;
SetKeyEvent( @Self );
end;
//[FUNCTION CollectTabControls]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function CollectTabControls( Form: PControl ): PList;
var R: PList;
function CollectTab( P: PControl ): Boolean;
var I, J: Integer;
C, D: PControl;
begin
Result := FALSE;
for I := 0 to P.fChildren.fCount - 1 do
begin
C := P.fChildren.fItems[ I ];
if C.fTabstop and C.fEnabled and C.ToBeVisible and
(C.fStyle and WS_TABSTOP <> 0) then
begin
D := nil;
for J := 0 to R.fCount - 1 do
begin
D := R.fItems[ J ];
if D.fTabOrder > C.fTabOrder then
begin
Result := TRUE;
R.Insert( J, C );
break;
end
else
D := nil;
end;
if D = nil then
begin
R.Add( C );
Result := TRUE;
end;
end;
if C.fEnabled then
begin
if CollectTab( C ) then
R.Remove( C );
end;
end;
end;
{$IFDEF DEBUG_COLLECTTABCONTROLS}
var SL: PStrList;
i: Integer;
C: PControl;
{$ENDIF}
begin
R := NewList;
CollectTab( Form );
{$IFDEF DEBUG_COLLECTTABCONTROLS}
SL := NewStrList;
for i := 0 to R.Count-1 do
begin
C := R.Items[ i ];
SL.Add( Int2Str( C.fTabOrder ) + ' ' + Int2Str( C.fTag ) + ' ' + C.fCaption );
end;
SL.SaveToFile( GetStartDir + 'debug_collecttabcontrols.txt' );
SL.Free;
{$ENDIF}
Result := R;
end;
{$ENDIF ASM_VERSION}
//[END CollectTabControls]
//[PROCEDURE Tabulate2Next]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure Tabulate2Next( Form: PControl; Dir: Integer );
var CL : PList;
I, J : Integer;
Ctrl1, Ctrl2, C : PControl;
begin
CL := CollectTabControls( Form );
I := 0;
C := Form.fCurrentControl;
if C <> nil then
I := C.fTabOrder;
Ctrl2 := nil;
Ctrl1 := nil;
for J := 0 to CL.fCount - 1 do
begin
C := CL.fItems[ J ];
if C.fTabOrder = I then continue;
if (Ctrl1 = nil)
and ( (Dir >= 0) and (C.fTabOrder > I)
or (Dir < 0) and (C.fTabOrder < I) )
or (Dir >= 0)
and (C.fTabOrder > I) and (C.fTabOrder < Ctrl1.fTabOrder)
or (Dir < 0)
and (C.fTabOrder < I) and (C.fTabOrder > Ctrl1.fTabOrder)
then Ctrl1 := C;
if (Ctrl2 = nil)
or (Dir >= 0) and (C.fTabOrder < Ctrl2.fTabOrder)
or (Dir < 0) and (C.fTabOrder > Ctrl2.fTabOrder)
then Ctrl2 := C;
end;
if Ctrl1 = nil then
Ctrl1 := Ctrl2;
if Ctrl1 <> nil then
begin
if (Ctrl1.fHandle <> 0) {$IFDEF USE_GRAPHCTLS} or not Ctrl1.fWindowed {$ENDIF} then
begin
Inc( Ctrl1.fClickDisabled );
Ctrl1.Focused := TRUE;
Dec( Ctrl1.fClickDisabled );
end;
Form.fCurrentControl := Ctrl1;
end;
CL.Free;
end;
{$ENDIF ASM_VERSION}
//[END Tabulate2Next]
//[FUNCTION Tabulate2Control]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
var Form: PControl;
begin
Result := False;
case Key of
VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit;
VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit;
VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit;
VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then exit;
else Exit;
end;
Result := True;
if checkOnly then Exit;
Form := Self_.ParentForm;
case Key of
VK_TAB:
if GetKeyState( VK_SHIFT ) < 0 then
Tabulate2Next( Form, -1 )
else
Tabulate2Next( Form, 1 );
VK_RIGHT, VK_DOWN, VK_NEXT: Tabulate2Next( Form, 1 );
VK_LEFT, VK_UP, VK_PRIOR: Tabulate2Next( Form, -1 );
end;
end;
{$ENDIF ASM_VERSION}
//[END Tabulate2Control]
//[FUNCTION Tabulate2ControlEx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
label search_tabcontrol;
var Form: PControl;
CL : PList;
I : Integer;
CurCtrl, Ctrl, Found : PControl;
MinDist, Dist: Integer;
R, R1 : TRect;
begin
Result := False;
case Key of
VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit;
VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit;
VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit;
VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then exit;
else exit;
end;
Result := True;
if checkOnly then Exit;
Form := Self_.ParentForm;
if Key = VK_TAB then
if GetKeyState( VK_SHIFT ) < 0 then
Tabulate2Next( Form, -1 )
else
Tabulate2Next( Form, 1 )
else
begin
CL := CollectTabControls( Form );
I := CL.IndexOf( Form.fCurrentControl );
Found := nil;
if I >= 0 then
begin
CurCtrl := CL.fItems[ I ];
GetWindowRect( CurCtrl.Handle, R );
search_tabcontrol:
MinDist := MaxInt;
for I := CL.fCount - 1 downto 0 do
begin
Ctrl := CL.fItems[ I ];
if Ctrl = CurCtrl then continue;
if not (Ctrl.fEnabled and Ctrl.fTabstop) then continue;
GetWindowRect( Ctrl.Handle, R1 );
Dist := MaxInt;
case Key of
VK_LEFT:
begin
if (R1.Bottom < R.Top)
or (R1.Top >= R.Bottom)
or (R1.Left > R.Left) then continue;
Dist := R.Left - R1.Left;
end;
VK_RIGHT:
begin
if (R1.Bottom < R.Top)
or (R1.Top >= R.Bottom)
or (R1.Left < R.Left) then continue;
Dist := R1.Left - R.Left;
end;
VK_UP, VK_PRIOR:
begin
if (R1.Right < R.Left)
or (R1.Left >= R.Right)
or (R1.Top > R.Top) then continue;
Dist := R.Top - R1.Top;
end;
VK_DOWN, VK_NEXT:
begin
if (R1.Right < R.Left)
or (R1.Left >= R.Right)
or (R1.Top < R.Bottom) then continue;
Dist := R1.Top - R.Top;
end;
end;
if Dist < MinDist then
begin
Found := Ctrl;
MinDist := Dist;
end;
end;
if Found = nil then
begin
case Key of
VK_LEFT:
begin
Key := VK_UP; goto search_tabcontrol;
end;
VK_RIGHT:
begin
Key := VK_DOWN; goto search_tabcontrol;
end;
VK_UP, VK_PRIOR:
Tabulate2Next( Form, -1 );
VK_DOWN, VK_NEXT:
Tabulate2Next( Form, 1 );
end;
end
else
begin
if Found.fHandle <> 0 then
begin
Inc( Found.fClickDisabled );
SetFocus( Found.fHandle );
Dec( Found.fClickDisabled );
end;
Form.fCurrentControl := Found;
end;
end;
CL.Free;
end;
end;
{$ENDIF ASM_VERSION}
//[END Tabulate2ControlEx]
//[function TControl.Tabulate]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.Tabulate: PControl;
var F : PControl;
begin
Result := @Self;
F := ParentForm;
if F = nil then Exit;
F.fGotoControl := Tabulate2Control;
end;
{$ENDIF ASM_VERSION}
//[function TControl.TabulateEx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.TabulateEx: PControl;
var F : PControl;
begin
Result := @Self;
F := ParentForm;
if F = nil then Exit;
F.fGotoControl := Tabulate2ControlEx;
end;
{$ENDIF ASM_VERSION}
function WndProcMouseTransparent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
if Msg.message = WM_NCHITTEST then
begin
Rslt := HTTRANSPARENT;
Result := TRUE;
end;
end;
function TControl.MouseTransparent: PControl;
begin
AttachProc( WndProcMouseTransparent );
Result := @ Self;
end;
//*
//[procedure TControl.GotoControl]
procedure TControl.GotoControl(Key: DWORD);
var Form: PControl;
begin
Form := ParentForm;
if Form <> nil then
if assigned( Form.fGotoControl ) then
Form.fGotoControl( Form.fCurrentControl, Key, false );
end;
//[function TControl.GetCurIndex]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetCurIndex: Integer;
var I, J: Integer;
begin
Result := fCurIndex;
if fCommandActions.aGetCurrent = 0 then
Exit;
I := 0;
if fCommandActions.aGetCurrent = EM_LINEINDEX then
Dec( I );
J := 0;
if fCommandActions.aGetCurrent = LVM_GETNEXTITEM then
begin
J := 2 {LVNI_SELECTED};
Dec( I );
end;
Result := Perform( fCommandActions.aGetCurrent, I, J );
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetCurIndex]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetCurIndex(const Value: Integer);
var NMHdr: TNMHdr;
begin
if fCommandActions.aSetCurrent <> 0 then
begin
Perform( fCommandActions.aSetCurrent, Value, 0 );
if fCommandActions.aSetCurrent = TCM_SETCURSEL then
begin
LongInt(NMHdr.code) := TCN_SELCHANGE;
NMHdr.hwndFrom := fHandle;
Perform( WM_NOTIFY, 0, Integer( @NMHdr ) );
end;
end
else
ItemSelected[ Value ] := True;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
//[function TControl.GetTextAlign]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetTextAlign: TTextAlign;
begin
UpdateWndStyles;
if (fStyle and fCommandActions.aTextAlignRight) = fCommandActions.aTextAlignRight then
Result := taRight
else
if (fStyle and fCommandActions.aTextAlignCenter) = fCommandActions.aTextAlignCenter then
Result := taCenter
else
Result := fTextAlign;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TControl.GetTextAlign: TTextAlign;
begin
Result := fTextAlign;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
//[procedure TControl.SetTextAlign]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetTextAlign(const Value: TTextAlign);
var NewStyle: DWORD;
begin
fTextAlign := Value;
NewStyle := 0;
with fCommandActions do
case Value of
taLeft: NewStyle := fStyle and not DWORD(aTextAlignCenter or aTextAlignRight)
or aTextAlignLeft;
taRight: NewStyle := fStyle and not DWORD(aTextAlignLeft or aTextAlignCenter)
or aTextAlignRight;
taCenter: NewStyle := fStyle and not DWORD(aTextAlignLeft or aTextAlignRight)
or aTextAlignCenter;
end;
NewStyle := NewStyle and not DWORD(fCommandActions.aTextAlignMask);
Style := NewStyle;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetTextAlign(const Value: TTextAlign);
begin
if fTextAlign = Value then Exit;
fTextAlign := Value;
if Assigned( fSetTextAlign ) then
fSetTextAlign( @ Self );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
//[function TControl.GetVerticalAlign]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetVerticalAlign: TVerticalAlign;
begin
UpdateWndStyles;
if (fStyle and (fCommandActions.aVertAlignCenter shl 8)) = (DWORD(fCommandActions.aVertAlignCenter) shl 8) then
Result := vaCenter
else
if (fStyle and (fCommandActions.aVertAlignBottom shl 8)) = (DWORD(fCommandActions.aVertAlignBottom) shl 8) then
Result := vaBottom
else
Result := fVerticalAlign;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TControl.GetVerticalAlign: TVerticalAlign;
begin
Result := fVerticalAlign;
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[procedure TControl.SetVerticalAlign]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetVerticalAlign(const Value: TVerticalAlign);
var NewStyle: DWORD;
begin
fVerticalAlign := Value;
with fCommandActions do
begin
NewStyle := fStyle and not DWORD((aVertAlignTop or aVertAlignCenter or aVertAlignBottom) shl 8);
case Value of
vaCenter: NewStyle := NewStyle or (aVertAlignCenter shl 8);
vaTop: NewStyle := NewStyle or (aVertAlignTop shl 8);
vaBottom: NewStyle := NewStyle or (aVertAlignBottom shl 8);
end;
end;
Style := NewStyle;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure TControl.SetVerticalAlign(const Value: TVerticalAlign);
begin
if fVerticalAlign = Value then Exit;
fVerticalAlign := Value;
if Assigned( fSetTextAlign ) then
fSetTextAlign( @ Self );
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[function TControl.Dc2Canvas]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.Dc2Canvas( Sender: PCanvas ): HDC;
begin
if fPaintDC <> 0 then
begin
Result := fPaintDC;
Sender.SetHandle( Result );
Sender.fIsPaintDC := True;
end
else
begin
if Sender.fHandle <> 0 then
Result := Sender.fHandle
else
Result := GetDC( GetWindowHandle );
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[function TControl.GetCanvas]
{$IFDEF GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetCanvas: PCanvas;
begin
if not assigned( fCanvas ) then
begin
fCanvas := NewCanvas( 0 );
fCanvas.OnGetHandle := Dc2Canvas;
fCanvas.fOwnerControl := @Self;
if assigned( fFont ) then
fCanvas.fFont := fCanvas.fFont.Assign( fFont );
if assigned( fBrush ) then
fCanvas.fBrush := fCanvas.fBrush.Assign( fBrush );
end;
Result := fCanvas;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TControl.ProvideCanvasHandle( Sender: PCanvas ): HDC;
type PPGdkGC = ^PGdkGC;
var Array_gc: PPGdkGC;
begin
if fInBkPaint then Array_gc := @ fEventboxHandle.style.bg_gc[ 0 ]
else
//if fInPaint then
Array_gc := @ fEventboxHandle.style.fg_gc[ 0 ];
{CASE fEventboxHandle.state OF
GTK_STATE_NORMAL : Result := Array_gc[ 0 ];
GTK_STATE_ACTIVE : Result := Array_gc[ 1 ];
GTK_STATE_PRELIGHT : Result := Array_gc[ 2 ];
GTK_STATE_SELECTED : Result := Array_gc[ 3 ];
GTK_STATE_INSENSITIVE: Result := Array_gc[ 4 ];
else Result := Array_gc[ 0 ];
END;}
CASE fEventboxHandle.state OF
GTK_STATE_NORMAL,
GTK_STATE_ACTIVE,
GTK_STATE_PRELIGHT,
GTK_STATE_SELECTED,
GTK_STATE_INSENSITIVE: Result := PPGdkGC( Integer( Array_gc ) + fEventboxHandle.state * sizeof( Pointer ) )^;
else Result := Array_gc^;
END;
end;
function TControl.GetCanvas: PCanvas;
begin
if not assigned( fCanvas ) then
begin
fCanvas := NewCanvas( nil {fHandle.style.fg_gc[0]} );
fCanvas.OnGetHandle := ProvideCanvasHandle;
fCanvas.fOwnerControl := @Self;
fCanvas.fDrawable := Pointer( fEventboxHandle.window );
{if assigned( fFont ) then
fCanvas.fFont := fCanvas.fFont.Assign( fFont );}
{if assigned( fBrush ) then
fCanvas.fBrush := fCanvas.fBrush.Assign( fBrush );}
end;
//fCanvas.fHandle := fEventboxHandle.style.fg_gc[ 0 ]; // todo: setup desired context
fCanvas.GetHandle; // получим здесь тот контекст, который соответствует
// текущему состоянию контрола (если это контрол) и текущей
// стадии рисования
Result := fCanvas;
end;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
//[function TControl.DblBufTopParent]
function TControl.DblBufTopParent: PControl;
var Ctl: PControl;
begin
Result := nil;
Ctl := @ Self;
while Ctl <> nil do
begin
if (Ctl.fDoubleBuffered) or (Ctl.fTransparent) then
Result := Ctl;
Ctl := Ctl.fParent;
end;
end;
//[procedure TControl.SetDoubleBuffered]
procedure TControl.SetDoubleBuffered(const Value: Boolean);
begin
{$ifdef win32}
if CannotDoubleBuf then Exit;
fDoubleBuffered := Value;
AttachProc(WndProcTransparent);
{$IFNDEF SMALLEST_CODE}
Global_AttachProcExtension := @TransparentAttachProcExtension;
{$ENDIF}
{$endif win32}
end;
//[procedure TControl.SetTransparent]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetTransparent(const Value: Boolean);
begin
{$ifdef win32}
fTransparent := Value;
if fParent = nil then Exit;
{$IFDEF GRAPHCTL_XPSTYLES}
if not AppTheming then
fClassicTransparent := Value;
{$ENDIF}
if Value then begin
AttachProc(WndProcTransparent);
fParent.DoubleBuffered := TRUE;
end;
{$endif win32}
end;
{$ENDIF ASM_VERSION}
//[function TControl.SetBorder]
function TControl.SetBorder( Value: Integer ): PControl;
begin
fMargin := Value;
Result := @ Self;
end;
{ TTrayIcon }
var FTrayItems: PList;
//[FUNCTION WndProcTray]
{$IFDEF ASM_noVERSION}
function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
asm
PUSH ECX
MOV ECX, [EDX].TMsg.message
CMP CX, CM_TRAYICON
JNE @@1
MOV ECX, [EDX].TMsg.lParam
MOV EDX, [EDX].TMsg.wParam
MOV EAX, [EDX].TTrayIcon.fOnMouse.TMethod.Data
CMP word ptr [EDX].TTrayIcon.fOnMouse.TMethod.Code+2, 0
JE @@no_on
CALL [EDX].TTrayIcon.fOnMouse.TMethod.Code
@@no_on:
POP ECX
XOR EAX, EAX
MOV [ECX], EAX
INC EAX
RET
@@1:
SUB ECX, WM_CLOSE
JNE @@exit_0
@@2:
POP ECX
PUSH EBX
XCHG EBX, EAX
MOV EAX, [EBX].TControl.fHandle
CMP EAX, [EDX].TMsg.hwnd
JNE @@otherwin
MOV EDX, [FTrayItems]
MOV ECX, [EDX].TList.fCount
MOV EDX, [EDX].TList.fItems
@@loop:
MOV EAX, [EDX + ECX*4 - 4]
CMP [EAX].TTray.FNoAutoDeactivate, 0
JNZ @@3
CMP [EAX].TTrayIcon.fControl, EBX
JNE @@3
PUSHAD
XOR EDX, EDX
CALL TTrayIcon.SetActive
POPAD
@@3: LOOP @@loop
@@otherwin:
POP EBX
PUSH ECX
@@exit_0:
XOR EAX, EAX
POP ECX
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
var Self_: PTrayIcon;
I : Integer;
begin
Result := False;
case Msg.message of
CM_TRAYICON:
begin
Self_ := Pointer( Msg.wParam );
if Assigned( Self_.FOnMouse ) then
Self_.FOnMouse( @Self_, Msg.lParam );
Rslt := 0;
Result := True;
end;
WM_CLOSE:
if Msg.hwnd = Control.fHandle then
begin
if FTrayItems <> nil then // ?????????????????
for I := FTrayItems.Count - 1 downto 0 do
begin
Self_ := FTrayItems.Items[ I ];
if not Self_.FNoAutoDeactivate then
if Self_.FControl = Control then
Self_.Active := False;
end;
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcTray]
function WndProcTrayIconWnd( Wnd: HWnd; Msg: DWORD; wParam, lParam: Integer ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif};
var PrevProc: function ( Wnd: HWnd; Msg: DWORD;
wParam, lParam: Integer ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
var Tr: PTrayIcon;
begin
PrevProc := Pointer( GetProp( Wnd, 'TRAYSAVEPROC' ) );
if Msg = CM_TRAYICON then
begin
Tr := Pointer( wParam );
if Assigned( Tr.FOnMouse ) then
Tr.FOnMouse( Tr, lParam );
Result := 0;
Exit;
end
else
if Msg = WM_CLOSE then
begin
if Assigned( PrevProc ) then
begin
SetWindowLong( Wnd, GWL_WNDPROC, Integer( @ PrevProc ) );
RemoveProp( Wnd, 'TRAYSAVEPROC' );
PostMessage( Wnd, WM_CLOSE, wParam, lParam );
Result := 0;
Exit;
end;
end;
if (Wnd <> 0) and IsWindow( Wnd ) and Assigned( PrevProc ) then
Result := PrevProc( Wnd, Msg, wParam, lParam )
else
Result := DefWindowProc( Wnd, Msg, wParam, lParam );
end;
//[PROCEDURE TTrayIcon.AttachProc2Wnd]
procedure TTrayIcon.AttachProc2Wnd;
begin
if FWnd = 0 then Exit;
if GetProp( FWnd, 'TRAYSAVEPROC' ) <> 0 then Exit; // already attached
SetProp( FWnd, 'TRAYSAVEPROC', GetWindowLong( FWnd, GWL_WNDPROC ) );
SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ WndProcTrayIconWnd ) );
end;
// [END TTrayIcon.AttachProc2Wnd]
// [PROCEDURE TTrayIcon.DetachProc2Wnd]
procedure TTrayIcon.DetachProc2Wnd;
var OldProc: function ( Wnd: HWnd; Msg: DWORD;
wParam, lParam: Integer ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
if FWnd = 0 then Exit;
OldProc := Pointer( GetProp( FWnd, 'TRAYSAVEPROC' ) );
if not Assigned( OldProc ) then Exit; // not attached
SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ OldProc ) );
RemoveProp( FWnd, 'TRAYSAVEPROC' );
end;
// [END TTrayIcon.DetachProc2Wnd]
//[FUNCTION NewTrayIcon]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon;
begin
if FTrayItems = nil then
FTrayItems := NewList;
{-}
New( Result, Create );
{+}{++}(*Result := PTrayIcon.Create;*){--}
FTrayItems.Add( Result );
if Wnd <> nil then
Wnd.AttachProc( WndProcTray );
Result.FControl := Wnd;
Result.FIcon := Icon;
Result.Active := True;
end;
{$ENDIF ASM_VERSION}
//[END NewTrayIcon]
var fRecreateMsg: DWORD;
//[FUNCTION WndProcRecreateTrayIcons]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcRecreateTrayIcons( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
TI: PTrayIcon;
begin
if Msg.message = fRecreateMsg then
begin
for I := 0 to FTrayItems.fCount - 1 do
begin
TI := FTrayItems.Items[ I ];
if TI.fAutoRecreate then
if TI.fActive then
begin
TI.fActive := False;
TI.Active := True;
end;
end;
end;
Result := False;
end;
{$ENDIF ASM_VERSION}
//[END WndProcRecreateTrayIcons]
const
TaskbarCreatedMsg: array[ 0..14 ] of KOLChar = ('T','a','s','k','b','a','r',
'C','r','e','a','t','e','d',#0);
//[procedure TTrayIcon.SetAutoRecreate]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TTrayIcon.SetAutoRecreate(const Value: Boolean);
begin
fAutoRecreate := Value;
FControl.ParentForm.AttachProc( WndProcRecreateTrayIcons );
fRecreateMsg := RegisterWindowMessage( TaskbarCreatedMsg );
end;
{$ENDIF ASM_VERSION}
//[destructor TTrayIcon.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TTrayIcon.Destroy;
begin
Active := False;
if fIcon <> 0 then
DestroyIcon( fIcon );
FTrayItems.Remove( @ Self );
if FTrayItems.Count = 0 then
Free_And_Nil( FTrayItems );
FTooltip := '';
inherited;
end;
{$ENDIF ASM_VERSION}
//[procedure TTrayIcon.SetActive]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
{$ifdef wince}
const
NIM_ADD = $00000000;
NIM_MODIFY = $00000001;
NIM_DELETE = $00000002;
NIF_MESSAGE = $00000001;
NIF_ICON = $00000002;
NIF_TIP = $00000004;
{$endif wince}
procedure TTrayIcon.SetActive(const Value: Boolean);
begin
if FActive = Value then Exit;
if FIcon = 0 then Exit;
if (Wnd = 0) and ((FControl = nil) or (FControl.GetWindowHandle = 0)) then Exit;
FActive := Value;
if Value then
SetTrayIcon( NIM_ADD )
else
SetTrayIcon( NIM_DELETE );
end;
{$ENDIF ASM_VERSION}
//[procedure TTrayIcon.SetIcon]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TTrayIcon.SetIcon(const Value: HIcon);
var Cmd : DWORD;
begin
if FIcon = Value then Exit;
// Previous icon is not destroying. This is normal for
// icons, loaded from resources using LoadIcon. For icons,
// created using CreateIconIndirect, You have to call
// DestroyIcon manually.
Cmd := NIM_MODIFY;
if FIcon = 0 then
Cmd := NIM_ADD;
FIcon := Value;
if FActive then
SetTrayIcon( Cmd );
end;
{$ENDIF ASM_VERSION}
//[procedure TTrayIcon.SetTooltip]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
procedure TTrayIcon.SetTooltip(const Value: KOLString);
begin
if FTooltip = Value then Exit;
FTooltip := Value;
if Active then
SetTrayIcon( NIM_MODIFY );
end;
{$ENDIF ASM_VERSION}
//[procedure TTrayIcon.SetTrayIcon]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
procedure TTrayIcon.SetTrayIcon(const Value: DWORD);
var NID : {$IFDEF UNICODE_CTRLS} TNotifyIconDataW {$ELSE} TNotifyIconData {$ENDIF};
L : Integer;
V : DWORD;
begin
V := Value;
if AppletTerminated then
V := NIM_DELETE;
if Wnd <> 0 then
NID.Wnd := Wnd
else
NID.Wnd := FControl.fHandle;
NID.cbSize := Sizeof( NID );
NID.uID := DWORD( @Self );
NID.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
if V = NIM_DELETE then
NID.uFlags := 0;
NID.uCallbackMessage := CM_TRAYICON;
NID.hIcon := FIcon;
L := Length( FToolTip );
if L > 63 then L := 63;
Move( FTooltip[1], NID.szTip[0], Min( 63, L ) );
{$ifdef wince}
NID.szTip[ L ] := 0;
{$else wince}
NID.szTip[ L ] := #0;
{$endif wince}
Shell_NotifyIcon( V, @NID );
end;
{$ENDIF ASM_VERSION}
{ -- JustOne -- }
var JustOneMutex: THandle;
//[FUNCTION WndProcJustOne]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
begin
Result := False;
case Msg.message of
WM_CLOSE{$ifndef wince}, WM_NCDESTROY{$endif}:
if LongBool( JustOneMutex ) and (Control.Handle = Msg.hwnd) then
begin
CloseHandle( JustOneMutex );
JustOneMutex := 0;
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcJustOne]
//[FUNCTION JustOne]
{$IFDEF ASM_noVERSION}
function JustOne( Wnd: PControl; const Identifier : String ) : Boolean;
asm
PUSH EBX
PUSH ESI
XOR ESI, ESI
PUSH EDI
XCHG EBX, EAX
CALL EDX2PChar
PUSH EDX
PUSH 0
PUSH 1
PUSH ESI
MOV EDI, offset[CreateMutex]
CALL EDI
POP EDX
TEST EAX, EAX
JZ @@exit //
PUSH EAX
PUSH EAX
PUSH EDX
PUSH ESI
PUSH ESI
CALL EDI
MOV [JustOneMutex], EAX
TEST EAX, EAX
JE @@1 //
PUSH ESI
PUSH EAX
CALL WaitForSingleObject
SUB EAX, WAIT_TIMEOUT
JE @@1
INC ESI
@@1:
XCHG EAX, EBX
MOV EDX, offset[WndProcJustOne]
CALL TControl.AttachProc
CALL ReleaseMutex
CALL CloseHandle
@@exit:
XCHG EAX, ESI
POP EDI
POP ESI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean;
var CritSecMutex : THandle;
DW : Longint;
begin
Result := False;
CritSecMutex := CreateMutex( nil, True, nil );
if CritSecMutex = 0 then Exit;
{$ifdef UNICODE_CTRLS}
JustOneMutex := CreateMutexW( nil, False, PKOLChar( Identifier ) );
{$else}
JustOneMutex := CreateMutex( nil, False, PChar( Identifier ) );
{$endif UNICODE_CTRLS}
if JustOneMutex <> 0 then
begin
DW := WaitForSingleObject( JustOneMutex, 0 );
Result := (DW <> WAIT_TIMEOUT);
end;
Wnd.AttachProc( WndProcJustOne );
CloseHandle( CritSecMutex );
end;
{$ENDIF ASM_VERSION}
//[END JustOne]
var
JustOneIdentifier: KOLString;
FoundOtherWnd: HWND;
function JustOneEnumWindowsProc( Wnd : HWnd; Identifier: PKOLChar ) : Boolean; {$ifdef wince}cdecl{$else}{$ifdef wince}cdecl{$else}stdcall{$endif}{$endif};
begin
Result:=GetProp(Wnd, Identifier) <> 1;
if not Result then begin
SetForegroundWindow(Wnd {$ifdef wince} or 1 {$endif});
JustOneIdentifier:='';
FoundOtherWnd:=Wnd;
end;
end;
function WndProcJustOneActivate( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
begin
Result := False;
if (Msg.message = WM_DESTROY) and (Control.fHandle = Msg.hwnd) then
RemoveProp(Msg.hwnd, PKOLChar(JustOneIdentifier));
end;
function JustOneActivate( Wnd: PControl; const Identifier : KOLString ) : HWND;
begin
JustOneIdentifier:=Identifier;
FoundOtherWnd:=0;
EnumWindows(@JustOneEnumWindowsProc, DWORD(PKOLChar(Identifier)));
Result:=FoundOtherWnd;
if FoundOtherWnd = 0 then begin
SetProp(Wnd.GetWindowHandle, PKOLChar(Identifier), 1);
Wnd.AttachProc(WndProcJustOneActivate);
end;
end;
{$ifndef wince}
{ JustOneNotify }
var
OnAnotherInstance: TOnAnotherInstance;
JustOneMsg: DWORD;
//[FUNCTION WndProcJustOneNotify]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
var Buf : array[0..MAX_PATH] of KOLChar;
begin
WndProcJustOne( Control, Msg, Rslt );
Result := False;
if Msg.message = JustOneMsg then
begin
Result := True;
if assigned( OnAnotherInstance ) then
begin
GetWindowText( Msg.lParam, Buf, MAX_PATH );
OnAnotherInstance( Buf );
end;
Rslt := 0;
end;
end;
{$ENDIF ASM_VERSION}
//[END WndProcJustOneNotify]
// Redefine here incorrectly declared BroadcastSystemMessage API function.
// It should not refer to BroadcastSystemMessageA, which is not present in
// earlier versions of Windows95, but to BroadcastSystemMessage, which is
// present in all Windows95/98/Me and NT/2K/XP.
//[API BroadcastSystemMessage]
function BroadcastSystemMessage(Flags: DWORD; Recipients: PDWORD;
uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; {$ifdef wince}cdecl{$else}stdcall{$endif};
external user32 name 'BroadcastSystemMessage';
//[FUNCTION JustOneNotify]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function JustOneNotify( Wnd: PControl; const Identifier : KOLString;
const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;
var Recipients : DWord;
OldCap: String;
begin
Result := False;
JustOneMsg := RegisterWindowMessage( PKOLChar( 'Message.' + Identifier ) );
if JustOneMsg = 0 then Exit;
Result := JustOne( Wnd, Identifier );
if not Result then
begin
// Send a message to the first instance of applet
OldCap := Wnd.Caption;
Wnd.Caption := GetCommandLine;
if Wnd.GetWindowHandle <> 0 then
begin
Recipients := BSM_APPLICATIONS;
BroadcastSystemMessage( BSF_QUERY or BSF_IGNORECURRENTTASK, @Recipients,
JustOneMsg, 0, Wnd.fHandle );
end;
Wnd.Caption := OldCap;
end
else
begin
// Store event handler to notify this instance about another
// instance staring:
OnAnotherInstance := aOnAnotherInstance;
Wnd.AttachProc( WndProcJustOneNotify );
end;
end;
{$ENDIF ASM_VERSION}
//[END JustOneNotify]
{$endif wince}
///////////////////////////////////////// STRING LIST OBJECT /////////////////
{$ENDIF WIN}
{ TStrList }
//[function NewStrList]
function NewStrList: PStrList;
begin
{-}
New( Result, Create );
{+}
{++}(*
Result := PStrList.Create;
*){--}
end;
//[END NewStrList]
//[destructor TStrList.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TStrList.Destroy;
begin
Clear;
inherited;
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.Init]
procedure TStrList.Init;
begin
{$IFDEF _D2orD3}
inherited;
{$ENDIF}
fNameDelim := DefaultNameDelimiter;
end;
//[function TStrList.Add]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TStrList.Add(const S: string): integer;
begin
Result := fCount;
Insert( Result, S );
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.AddStrings]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.AddStrings(Strings: PStrList);
begin
SetText( Strings.Text, True );
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.Assign]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.Assign(Strings: PStrList);
begin
Clear;
AddStrings( Strings );
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.Clear]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.Clear;
var I: Integer;
begin
if fCount > 0 then
for I := fList.Count - 1 downto 0 do
Delete( I );
fList.Free;
fList := nil;
fCount := 0;
if fTextBuf <> nil then
begin
FreeMem( fTextBuf );
fTextBuf := nil;
fTextSiz := 0;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.Delete]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.Delete(Idx: integer);
var P: DWORD;
El:Pointer;
begin
P := DWORD( fList.fItems[ Idx ] );
if (fTextBuf <> nil) and ( P >= DWORD( fTextBuf )) and
( P < DWORD( fTextBuf ) + fTextSiz ) then
else
begin
El := FList.Items[ Idx ];
FreeMem( El );
end;
fList.Delete( Idx );
Dec( fCount );
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.DeleteLast]
procedure TStrList.DeleteLast;
begin
Delete( Count-1 );
end;
//[function TStrList.Get]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TStrList.Get(Idx: integer): string;
begin
if fList <> nil then
Result := PChar( fList.Items[ Idx ] )
else Result := '';
end;
{$ENDIF ASM_VERSION}
//[function TStrList.GetPChars]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TStrList.GetPChars(Idx: Integer): PChar;
begin
Result := PChar( fList.fItems[ Idx ] );
end;
{$ENDIF ASM_VERSION}
//[function TStrList.GetTextStr]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TStrList.GetTextStr: string;
var
I, Len, Size: integer;
P: PChar;
begin
Size := 0;
for I := 0 to fCount - 1 do
Inc(Size, StrLen( PChar(fList.fItems[I]) ) +
{$IFDEF LIN} 1 {$ELSE} 2 {$ENDIF});
SetString(Result, nil, Size);
P := Pointer(Result);
for I := 0 to Count - 1 do
begin
Len := StrLen(PChar(fList.fItems[I]));
if (Len > 0) then
begin
System.Move(PChar(fList.fItems[I])^, P^, Len);
Inc(P, Len);
end;
P^ := #13;
Inc(P);
{$IFDEF WIN}
P^ := #10;
Inc(P);
{$ENDIF WIN}
end;
end;
{$ENDIF ASM_VERSION}
//[function TStrList.IndexOf]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TStrList.IndexOf(const S: string): integer;
begin
for Result := 0 to fCount - 1 do
if (S = PChar( fList.Items[Result] )) then Exit;
Result := -1;
end;
{$ENDIF ASM_VERSION}
//[function TStrList.IndexOf]
function TStrList.IndexOf_NoCase(const S: string): integer;
begin
for Result := 0 to fCount - 1 do
if AnsiCompareStrNoCase( S, Items[Result] ) = 0 then Exit;
Result := -1;
end;
function TStrList.IndexOfStrL_NoCase( Str: PChar; L: Integer ): integer;
begin
for Result := 0 to fCount - 1 do
if (StrLen( PChar( fList.fItems[ Result ] ) ) = DWORD( L )) and
(StrLComp_NoCase( Str, PChar( fList.fItems[ Result ] ), L ) = 0) then Exit;
Result := -1;
end;
//[function TStrList.Find]
function TStrList.Find(const S: String; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
begin
Result := FALSE;
L := 0;
H := FCount - 1;
while L <= H do
begin
I := (L + H) shr 1;
C := AnsiCompareStr( PChar( fList.Items[ I ] ), S );
if C < 0 then L := I + 1 else
begin
H := I - 1;
if C = 0 then
begin
Result := TRUE;
L := I;
end;
end;
end;
Index := L;
end;
//[procedure TStrList.Insert]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.Insert(Idx: integer; const S: string);
var Mem: PChar;
L: Integer;
begin
if fList = nil then
fList := NewList;
L := Length( S ) + 1;
GetMem( Mem, L );
Mem[0] := #0;
if L > 1 then
System.Move( S[1], Mem[0], L );
fList.Insert( Idx, Mem );
Inc( fCount );
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.Move]
procedure TStrList.Move(CurIndex, NewIndex: integer);
begin
fList.MoveItem( CurIndex, NewIndex );
end;
//[procedure TStrList.Put]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.Put(Idx: integer; const Value: string);
begin
Delete( Idx );
Insert( Idx, Value );
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.SetText]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
//[procedure TStrList.SetText]
procedure TStrList.SetText(const S: string; Append2List: boolean);
var
P, TheLast : PChar;
L, I : Integer;
procedure AddTextBuf(Src: PChar; Len: DWORD);
var OldTextBuf, P: PChar;
I : Integer;
begin
if Src <> nil then
begin
OldTextBuf := fTextBuf;
GetMem( fTextBuf, fTextSiz + Len );
if fTextSiz <> 0 then
begin
System.Move( OldTextBuf^, fTextBuf^, fTextSiz );
for I := 0 to fCount - 1 do
begin
P := fList.fItems[ I ];
if (DWORD( P ) >= DWORD( OldTextBuf )) and
(DWORD( P ) < DWORD( OldTextBuf ) + fTextSiz) then
fList.fItems[ I ] := Pointer( DWORD( P ) - DWORD( OldTextBuf ) + DWORD( fTextBuf ) );
end;
FreeMem( OldTextBuf );
end;
System.Move( Src^, fTextBuf[ fTextSiz ], Len );
Inc( fTextSiz, Len );
end;
end;
begin
if not Append2List then Clear;
if S = '' then Exit;
L := fTextSiz;
AddTextBuf( PChar( S ), Length( S ) + 1 );
P := PChar( DWORD( fTextBuf ) + DWORD( L ) );
if fList = nil then
fList := NewList;
I := 0;
TheLast := P + Length( S );
while P^ <> #0 do
begin
Inc( I );
{$IFDEF WIN}
P := StrScanLen( P, #13, TheLast - P );
if P^ = #10 then
Inc( P );
{$ELSE LIN}
P := StrScanLen( P, #10, TheLast - P );
{$ENDIF}
end;
Inc( fCount, I );
if fList.fCapacity < fCount then
fList.Capacity := fCount;
P := PChar( DWORD( fTextBuf ) + DWORD( L ) );
while P^ <> #0 do
begin
fList.Add( P );
{$IFDEF WIN}
P := StrScanLen( P, #13, TheLast - P );
if PChar( P - 1 )^ = #13 then
PChar( P - 1 )^ := #0;
if P^ = #10 then Inc(P);
{$ELSE LIN}
P := StrScanLen( P, #10, TheLast - P );
{$ENDIF}
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.SetUnixText]
procedure TStrList.SetUnixText(const S: String; Append2List: Boolean);
var S1: String;
begin
S1 := S;
NormalizeUnixText( S1 );
SetText( S1, Append2List );
end;
//[procedure TStrList.SetTextStr]
procedure TStrList.SetTextStr(const Value: string);
begin
SetText( Value, False );
end;
//[FUNCTION CompareStrListItems]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function CompareStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
var S1, S2 : PChar;
begin
S1 := PStrList( Sender ).fList.Items[ e1 ];
S2 := PStrList( Sender ).fList.Items[ e2 ];
if PStrList( Sender ).fCaseSensitiveSort then
Result := StrComp( S1, S2 )
else
Result := StrComp( PChar( LowerCase( S1 ) ), PChar( LowerCase( S2 ) ) );
end;
{$ENDIF ASM_VERSION}
//[END CompareStrListItems]
//[FUNCTION CompareAnsiStrListItems]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
var S1, S2 : PKOLChar;
begin
S1 := PStrList( Sender ).fList.Items[ e1 ];
S2 := PStrList( Sender ).fList.Items[ e2 ];
if PStrList( Sender ).fCaseSensitiveSort then
Result := _AnsiCompareStr( S1, S2 )
else
Result := _AnsiCompareStrNoCase( S1, S2 );
end;
{$ENDIF ASM_VERSION}
//[END CompareAnsiStrListItems]
{$IFNDEF ASM_VERSION}
//[procedure SwapStrListItems]
procedure SwapStrListItems( const Sender: Pointer; const e1, e2: DWORD );
begin
PStrList( Sender ).Swap( e1, e2 );
end;
{$ENDIF}
//[procedure TStrList.Sort]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.Sort(CaseSensitive: Boolean);
begin
fCaseSensitiveSort := CaseSensitive;
SortData( @Self, fCount, @CompareStrListItems, @SwapStrListItems );
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.AnsiSort]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.AnsiSort(CaseSensitive: Boolean);
begin
fCaseSensitiveSort := CaseSensitive;
SortData( @Self, fCount, @CompareAnsiStrListItems, @SwapStrListItems );
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.Swap]
procedure TStrList.Swap(Idx1, Idx2: Integer);
begin
fList.Swap( Idx1, Idx2 );
end;
//[function TStrList.Last]
function TStrList.Last: String;
begin
if Count = 0 then
Result := ''
else
Result := Items[ Count - 1 ];
end;
//-- code by Dod:
//[function TStrList.IndexOfName]
function TStrList.IndexOfName(AName: string): Integer;
var
i: Integer;
L: Integer;
begin
Result:=-1;
// Do not start search if empty string
L := Length( AName );
if L > 0 then
begin
AName := LowerCase( AName ) + fNameDelim;
Inc( L );
for i := 0 to fCount - 1 do
begin
// For optimization, check only list entry that begin with same letter as searched name
if StrLComp( PChar( LowerCase( ItemPtrs[ i ] ) ), PChar( AName ), L ) = 0 then
begin
Result:=i;
exit;
end;
end;
end;
end;
//-- code by Dod:
//[function TStrList.GetValue]
function TStrList.GetValue(const AName: string): string;
var
i: Integer;
begin
I := IndexOfName(AName);
if I >= 0
then Result := Copy(Items[i], Length(AName) + 2, Length(Items[i])-Length(AName)-1)
else Result := '';
end;
//-- code by Dod:
//[procedure TStrList.SetValue]
procedure TStrList.SetValue(const AName, Value: string);
var
I: Integer;
begin
I := IndexOfName(AName);
if i=-1
then Add( AName + fNameDelim + Value )
else Items[i] := AName + fNameDelim + Value;
end;
//[function TStrList.GetLineName]
function TStrList.GetLineName(Idx: Integer): String;
var s: KOLString;
begin
s := Items[ Idx ];
Result := Parse( s, fNameDelim );
end;
//[procedure TStrList.SetLineName]
procedure TStrList.SetLineName(Idx: Integer; const NV: String);
begin
Items[ Idx ] := NV + fNameDelim + LineValue[ Idx ];
end;
//[function TStrList.GetLineValue]
function TStrList.GetLineValue(Idx: Integer): string;
var s: KOLString;
begin
s := Items[ Idx ];
Parse( s, fNameDelim );
Result := s;
end;
//[procedure TStrList.SetLineValue]
procedure TStrList.SetLineValue(Idx: Integer; const Value: string);
begin
Items[ Idx ] := LineName[ Idx ] + fNameDelim + Value;
end;
function TStrList.Join( const sep: String ): String;
var
I, Len, Size: integer;
P: PChar;
begin
Size := 0;
for I := 0 to Count - 1 do
Inc(Size, Integer( StrLen( ItemPtrs[I] ) ) + Length(Sep));
SetString(Result, nil, Size);
P := @ Result[ 1 ];
for I := 0 to Count - 1 do
begin
Len := StrLen( ItemPtrs[I] );
if (Len > 0) then
begin
System.Move( ItemPtrs[I]^, P^, Len);
Inc(P, Len);
end;
P := StrPCopy(P, Sep);
inc( P, Length( Sep ) ); // + by Korneev Ivan
end;
end;
{$IFDEF WIN_GDI}
//[function TStrList.AppendToFile]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TStrList.AppendToFile(const FileName: KOLstring): Boolean;
var F: HFile;
Buf: String;
L: Integer;
begin
F := FileCreate( FileName, ofOpenWrite or ofOpenAlways );
Result := F <> INVALID_HANDLE_VALUE;
if Result then
begin
FileSeek( F, 0, spEnd );
Buf := Text;
L := Length( Buf );
FileWrite( F, Buf[ 1 ], L );
FileClose( F );
end;
end;
{$ENDIF ASM_VERSION}
//[function TStrList.LoadFromFile]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TStrList.LoadFromFile(const FileName: KOLstring): Boolean;
var Buf: String;
F: HFile;
Sz: Integer;
begin
F := FileCreate( FileName, ofOpenRead or ofShareDenyWrite or ofOpenExisting );
Result := F <> INVALID_HANDLE_VALUE;
if Result then
begin
Sz := GetFileSize( F, nil );
SetString( Buf, nil, Sz );
FileRead( F, Buf[1], Sz );
FileClose( F );
SetText( Buf, False );
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.LoadFromStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.LoadFromStream(Stream: PStream; Append2List: boolean);
var Buf: String;
Sz: Integer;
begin
Sz := Stream.Size - Stream.Position;
SetString( Buf, nil, Sz );
Stream.Read( Buf[1], Sz );
SetText( Buf, Append2List );
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.MergeFromFile]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.MergeFromFile(const FileName: KOLstring);
var TmpStream: PStream;
begin
TmpStream := NewReadFileStream( FileName );
LoadFromStream( TmpStream, True );
TmpStream.Free;
end;
{$ENDIF ASM_VERSION}
//[function TStrList.SaveToFile]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TStrList.SaveToFile(const FileName: KOLstring): Boolean;
var F: HFile;
Buf: String;
begin
F := FileCreate( FileName, ofOpenWrite or ofCreateAlways );
Result := F <> INVALID_HANDLE_VALUE;
if Result then
begin
Buf := Text;
FileWrite( F, Buf[ 1 ], Length( Buf ) );
SetEndOfFile( F ); // necessary! - V.K.
FileClose( F );
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TStrList.SaveToStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TStrList.SaveToStream(Stream: PStream);
var S: string;
L: Integer;
begin
S := GetTextStr;
L := Length( S );
if L <> 0 then
Stream.Write( S[1], L );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
////////////////////////////////// EXTENDED STRING LIST OBJECT ////////////////
{-}
//[procedure WStrCopy]
{$IFDEF ASM_VERSION}
procedure WStrCopy( Dest, Src: PWideChar );
asm
PUSH EDI
PUSH ESI
MOV ESI,EAX
MOV EDI,EDX
OR ECX, -1
XOR EAX, EAX
REPNE SCASW
NOT ECX
MOV EDI,ESI
MOV ESI,EDX
REP MOVSW
POP ESI
POP EDI
end;
{$ELSE ASM_VERSION} //Pascal
procedure WStrCopy( Dest, Src: PWideChar );
var
counter : longint;
Begin
counter := 0;
while Src[counter] <> #0 do
begin
Dest[counter] := Src[counter];
Inc(counter);
end;
Dest[counter] := #0;
end;
{$ENDIF ASM_VERSION}
procedure WStrLCopy( Dest, Src: PWideChar; MaxLen: Integer );
begin
while MaxLen > 0 do
begin
Dest^ := Src^;
if Src^ = #0 then break;
inc( Dest );
inc( Src );
dec( MaxLen );
if MaxLen = 0 then
Dest^ := Src^;
end;
end;
//[function WStrCmp]
{$IFDEF ASM_VERSION}
function WStrCmp( W1, W2: PWideChar ): Integer;
asm
PUSH ESI
PUSH EDI
XCHG ESI, EAX
MOV EDI, EDX
XOR EAX, EAX
@@loop: LODSW
MOVZX EDX, word ptr [EDI]
INC EDI
INC EDI
CMP EAX, EDX
JNE @@exit
TEST EAX, EAX
JNZ @@loop
@@exit: SUB EAX, EDX
POP EDI
POP ESI
end;
{$ELSE ASM_VERSION} //Pascal
function WStrCmp( W1, W2: PWideChar ): Integer;
var
counter: Integer;
Begin
counter := 0;
While W1[counter] = W2[counter] do
Begin
if (W2[counter] = #0) or (W1[counter] = #0) then
break;
Inc(counter);
end;
Result := ord(W1[counter]) - ord(W2[counter]);
end;
{$ENDIF ASM_VERSION}
{ TStrListEx }
//[function NewStrListEx]
function NewStrListEx: PStrListEx;
begin
{-}
new( Result, Create );
{+}
{++}(*
Result := PStrListEx.Create;
*){--}
end;
//[END NewStrListEx]
//[destructor TStrListEx.Destroy]
destructor TStrListEx.Destroy;
var Obj: PList;
begin
Obj := FObjects;
inherited;
Obj.Free;
end;
//[function TStrListEx.GetObjects]
function TStrListEx.GetObjects(Idx: Integer): DWORD;
begin
Result := 0;
if FObjects.fCount > Idx then
Result := DWORD( FObjects.Items[ Idx ] );
end;
//[function TStrListEx.GetObjectCount]
function TStrListEx.GetObjectCount: Integer;
begin
Result := FObjects.Count;
end;
//[procedure TStrListEx.SetObjects]
procedure TStrListEx.SetObjects(Idx: Integer; const Value: DWORD);
begin
ProvideObjCapacity( Idx + 1 );
FObjects.Items[ Idx ] := Pointer( Value );
end;
//[procedure TStrListEx.Init]
procedure TStrListEx.Init;
begin
inherited;
FObjects := NewList;
end;
//[procedure SwapStrListExItems]
procedure SwapStrListExItems( const Sender: Pointer; const e1, e2: DWORD );
begin
PStrListEx( Sender ).Swap( e1, e2 );
end;
//[procedure TStrListEx.AnsiSort]
procedure TStrListEx.AnsiSort(CaseSensitive: Boolean);
begin
fCaseSensitiveSort := CaseSensitive;
SortData( @Self, fCount, @CompareAnsiStrListItems, @SwapStrListExItems );
end;
//[procedure TStrListEx.Sort]
procedure TStrListEx.Sort(CaseSensitive: Boolean);
begin
fCaseSensitiveSort := CaseSensitive;
SortData( @Self, fCount, @CompareStrListItems, @SwapStrListExItems );
end;
//[procedure TStrListEx.Move]
procedure TStrListEx.Move(CurIndex, NewIndex: integer);
begin
// move string
fList.MoveItem( CurIndex, NewIndex );
// move object
if FObjects.fCount >= Min( CurIndex, NewIndex ) then
begin
ProvideObjCapacity( max( CurIndex, NewIndex ) + 1 );
FObjects.MoveItem( CurIndex, NewIndex );
end;
end;
//[procedure TStrListEx.Swap]
procedure TStrListEx.Swap(Idx1, Idx2: Integer);
begin
// swap strings
fList.Swap( Idx1, Idx2 );
// swap objects
if FObjects.fCount >= Min( Idx1, Idx2 ) then
begin
ProvideObjCapacity( max( Idx1, Idx2 ) + 1 );
FObjects.Swap( Idx1, Idx2 );
end;
end;
//[procedure TStrListEx.ProvideObjCapacity]
procedure TStrListEx.ProvideObjCapacity(NewCap: Integer);
begin
if FObjects.FCount < NewCap then
begin
FObjects.Capacity := NewCap;
FillChar( FObjects.FItems[ FObjects.FCount ],
(FObjects.Capacity - FObjects.Count) * sizeof( Pointer ), #0 );
FObjects.FCount := NewCap;
end;
end;
//[procedure TStrListEx.AddStrings]
procedure TStrListEx.AddStrings(Strings: PStrListEx);
var I: Integer;
begin
I := Count;
if Strings.FObjects.fCount > 0 then
ProvideObjCapacity( Count );
inherited AddStrings( Strings );
if Strings.FObjects.fCount > 0 then
begin
ProvideObjCapacity( I + Strings.FObjects.fCount );
System.Move( Strings.FObjects.FItems[ 0 ],
FObjects.FItems[ I ],
Sizeof( Pointer ) * Strings.FObjects.fCount );
end;
end;
//[procedure TStrListEx.Assign]
procedure TStrListEx.Assign(Strings: PStrListEx);
begin
inherited Assign( Strings );
FObjects.Assign( Strings.FObjects );
end;
//[procedure TStrListEx.Clear]
procedure TStrListEx.Clear;
begin
inherited;
FObjects.Clear;
end;
//[procedure TStrListEx.Delete]
procedure TStrListEx.Delete(Idx: integer);
begin
inherited;
if FObjects.fCount > Idx then // mdw: '>=' -> '>'
FObjects.Delete( Idx );
end;
//[function TStrListEx.LastObj]
function TStrListEx.LastObj: DWORD;
begin
if Count = 0 then
Result := 0
else
Result := Objects[ Count - 1 ];
end;
//[function TStrListEx.AddObject]
function TStrListEx.AddObject(const S: String; Obj: DWORD): Integer;
begin
Result := Count;
InsertObject( Count, S, Obj );
end;
//[procedure TStrListEx.InsertObject]
procedure TStrListEx.InsertObject(Before: Integer; const S: String; Obj: DWORD);
begin
Insert( Before, S );
ProvideObjCapacity( Before );
FObjects.Insert( Before, Pointer( Obj ) );
end;
//[function TStrListEx.IndexOfObj]
function TStrListEx.IndexOfObj( Obj: Pointer ): Integer;
begin
Result := FObjects.IndexOf( Obj );
end;
//[function WStrLen]
{$IFDEF ASM_VERSION}
function WStrLen( W: PWideChar ): Integer;
asm
XCHG EDI, EAX
XCHG EDX, EAX
OR ECX, -1
XOR EAX, EAX
CMP EAX, EDI
JE @@exit0
REPNE SCASW
DEC EAX
DEC EAX
SUB EAX, ECX
@@exit0:
MOV EDI, EDX
end;
{$ELSE ASM_VERSION} //Pascal
function WStrLen( W: PWideChar ): Integer;
var i : Integer;
begin
i:=0;
while W[i]<>#0 do inc(i);
Result:=i;
end;
{$ENDIF ASM_VERSION}
{$IFDEF _D3orHigher} {$ifdef win32}
function UTF8_2WideString( const s: AnsiString ): WideString;
var Buffer: PWideChar;
L: Integer;
begin
L := Length( s ) + 1;
GetMem( Buffer, L * 2 );
MultiByteToWideChar( CP_UTF8, 0, PChar( s ), L-1,
Buffer, L );
Result := Buffer;
FreeMem( Buffer );
end;
{$endif win32} {$ENDIF _D3orHigher}
{------------------------------------------------------------------------------)
| |
| T W S t r L i s t |
| |
(------------------------------------------------------------------------------}
{$IFDEF WIN_GDI}
{$IFNDEF _D2}
//[function NewWStrList]
function NewWStrList: PWStrList;
begin
new( Result, Create );
end;
{ TWStrList }
//[function TWStrList.Add]
function TWStrList.Add(const W: WideString): Integer;
begin
Result := Count;
Insert( Result, W );
end;
//[procedure TWStrList.AddWStrings]
procedure TWStrList.AddWStrings(WL: PWStrList);
begin
Text := Text + WL.Text;
end;
//[function TWStrList.AppendToFile]
function TWStrList.AppendToFile(const Filename: KOLString): Boolean;
var Strm: PStream;
begin
Strm := NewReadWriteFileStream( Filename );
Result := Strm.Handle <> INVALID_HANDLE_VALUE;
if Result then
begin
Strm.Position := Strm.Size;
SaveToStream( Strm );
end;
Strm.Free;
end;
//[procedure TWStrList.Assign]
procedure TWStrList.Assign(WL: PWStrList);
begin
Text := WL.Text;
end;
//[procedure TWStrList.Clear]
procedure TWStrList.Clear;
var I: Integer;
P: Pointer;
begin
for I := 0 to Count-1 do
begin
P := fList.Items[ I ];
if P <> nil then
if not( (P >= fText) and (P <= fText + fTextBufSz) ) then
FreeMem( P );
end;
if fText <> nil then
FreeMem( fText );
fText := nil;
fTextBufSz := 0;
fList.Clear;
end;
//[procedure TWStrList.Delete]
procedure TWStrList.Delete(Idx: Integer);
var P: Pointer;
begin
P := fList.Items[ Idx ];
if P <> nil then
if not( (P >= fText) and (P <= fText + fTextBufSz) ) then
FreeMem( P );
fList.Delete( Idx );
end;
//[destructor TWStrList.Destroy]
destructor TWStrList.Destroy;
begin
Clear;
fList.Free;
inherited;
end;
//[function TWStrList.GetCount]
function TWStrList.GetCount: Integer;
begin
Result := fList.Count;
end;
//[function TWStrList.GetItems]
function TWStrList.GetItems(Idx: Integer): WideString;
begin
Result := PWideChar( fList.Items[ Idx ] );
end;
//[function TWStrList.GetPtrs]
function TWStrList.GetPtrs(Idx: Integer): PWideChar;
begin
Result := fList.Items[ Idx ];
end;
//[function TWStrList.GetText]
function TWStrList.GetText: WideString;
const
EoL: array[ 0..5 ] of Char = ( #13, #0, #10, #0, #0, #0 );
var L, I: Integer;
P, Dest: Pointer;
begin
L := 0;
for I := 0 to Count-1 do
begin
P := fList.Items[ I ];
if P <> nil then
L := L + WStrLen( P ) + 2
else
L := L + 2;
end;
SetLength( Result, L );
Dest := PWideChar( Result );
for I := 0 to Count-1 do
begin
P := fList.Items[ I ];
if P <> nil then
begin
WStrCopy( Dest, P );
Dest := Pointer( cardinal( Dest ) + cardinal(WStrLen( P )) * 2 );
end;
WStrCopy( Dest, Pointer( @ EoL[ 0 ] ) );
Dest := Pointer( cardinal( Dest ) + 4 );
end;
end;
//[procedure TWStrList.Init]
procedure TWStrList.Init;
begin
fList := NewList;
end;
//[procedure TWStrList.Insert]
procedure TWStrList.Insert(Idx: Integer; const W: WideString);
var P: Pointer;
begin
while Idx > Count do // by Misha Shar. a.k.a. kreit
fList.Add( nil );
GetMem( P, (Length( W ) + 1) * Sizeof(WideChar) );
fList.Insert( Idx, P );
WStrCopy( P, PWideChar( W ) );
end;
//[function TWStrList.LoadFromFile]
function TWStrList.LoadFromFile(const Filename: KOLString): Boolean;
begin
Clear;
Result := MergeFromFile( Filename );
end;
//[procedure TWStrList.LoadFromStream]
procedure TWStrList.LoadFromStream(Strm: PStream);
begin
Clear;
MergeFromStream( Strm );
end;
//[function TWStrList.MergeFromFile]
function TWStrList.MergeFromFile(const Filename: KOLString): Boolean;
var Strm: PStream;
begin
Strm := NewReadFileStream( Filename );
Result := Strm.Handle <> INVALID_HANDLE_VALUE;
if Result then
MergeFromStream( Strm );
Strm.Free;
end;
//[procedure TWStrList.MergeFromStream]
procedure TWStrList.MergeFromStream(Strm: PStream);
var Buf: WideString;
L: Integer;
begin
L := Strm.Size - Strm.Position;
Assert( L mod 1 = 0, 'Wide strings streams must be of even length in bytes.' );
if L = 0 then Exit;
SetLength( Buf, L div 2 );
Strm.Read( Buf[ 1 ], L );
Text := Text + Buf;
end;
//[procedure TWStrList.Move]
procedure TWStrList.Move(IdxOld, IdxNew: Integer);
begin
fList.MoveItem( IdxOld, IdxNew );
end;
//[function TWStrList.SaveToFile]
function TWStrList.SaveToFile(const Filename: KOLString): Boolean;
var Strm: PStream;
begin
Strm := NewWriteFileStream( Filename );
Result := Strm.Handle <> INVALID_HANDLE_VALUE;
if Result then
SaveToStream( Strm );
Strm.Free;
end;
//[procedure TWStrList.SaveToStream]
procedure TWStrList.SaveToStream(Strm: PStream);
var Buf, Dest: PWideChar;
I, L, Sz: Integer;
P: Pointer;
begin
Sz := 0;
for I := 0 to Count-1 do
begin
P := fList.Items[ I ];
if P <> nil then
Sz := Sz + WStrLen( P ) * 2 + 4
else
Sz := Sz + 4;
end;
GetMem( Buf, Sz );
Dest := Buf;
for I := 0 to Count-1 do
begin
P := fList.Items[ I ];
if P <> nil then
begin
L := WStrLen( P );
System.Move( P^, Dest^, L * 2 );
Inc( Dest, L );
end;
Dest^ := #13;
Inc( Dest );
Dest^ := #10;
Inc( Dest );
end;
Strm.Write( Buf^, Sz );
FreeMem( Buf );
end;
//[procedure TWStrList.SetItems]
procedure TWStrList.SetItems(Idx: Integer; const Value: WideString);
var P: Pointer;
begin
while Idx > Count-1 do
fList.Add( nil );
if WStrLen( ItemPtrs[ Idx ] ) > Length( Value ) then // fixed by kreit
WStrCopy( ItemPtrs[ Idx ], PWideChar( Value ) )
else
begin
P := fList.Items[ Idx ];
if P <> nil then
if not ((P >= fText) and (P <= fText + fTextBufSz)) then
FreeMem( P );
GetMem( P, (Length( Value ) + 1) * Sizeof(WideChar) );
fList.Items[ Idx ] := P;
WStrCopy( P, PWideChar( Value ) );
end;
end;
//[procedure TWStrList.SetText]
procedure TWStrList.SetText(const Value: WideString);
var L, N: Integer;
P: PWideChar;
begin
Clear;
if Value = '' then Exit;
L := (Length( Value ) + 1) * Sizeof( WideChar );
GetMem( fText, L );
System.Move( Value[ 1 ], fText^, L );
fTextBufSz := Length( Value );
N := 0;
P := fText;
while Word( P^ ) <> 0 do
begin
if (Word( P^ ) = 13) then
begin
Inc( N );
PWord( P )^ := 0;
if Word( P[ 1 ] ) = 10 then
Inc( P );
end
else
if (Word( P^ ) = 10) and ((P = fText) or (Word( (P-1)^ ) <> 0)) then
begin
Inc( N );
PWord( P )^ := 0;
end;
Inc( P );
end;
fList.Capacity := N;
P := fText;
while P < fText + fTextBufSz do
begin
fList.Add( P );
while Word( P^ ) <> 0 do Inc( P );
Inc( P );
if Word( P^ ) = 10 then Inc( P );
end;
end;
//[function CompareWStrListItems]
function CompareWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;
var WL: PWStrList;
begin
WL := Sender;
Result := WStrCmp( WL.fList.Items[ Idx1 ], WL.fList.Items[ Idx2 ] );
end;
//[function CompareWStrListItems_UpperCase]
function CompareWStrListItems_UpperCase( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;
var WL: PWStrList;
L1, L2: Integer;
begin
WL := Sender;
L1 := WStrLen( WL.fList.Items[ Idx1 ] );
L2 := WStrLen( WL.fList.Items[ Idx2 ] );
if Length( WL.fTmp1 ) < L1 then
SetLength( WL.fTmp1, L1 + 1 );
if Length( WL.fTmp2 ) < L2 then
SetLength( WL.fTmp2, L2 + 1 );
if L1 > 0 then
Move( WL.fList.Items[ Idx1 ]^, WL.fTmp1[ 1 ], (L1 + 1) * 2 )
else
WL.fTmp1[ 1 ] := #0;
if L2 > 0 then
Move( WL.fList.Items[ Idx2 ]^, WL.fTmp2[ 1 ], (L2 + 1) * 2 )
else
WL.fTmp2[ 1 ] := #0;
CharUpperBuffW( PWideChar( WL.fTmp1 ), L1 );
CharUpperBuffW( PWideChar( WL.fTmp2 ), L2 );
Result := WStrCmp( PWideChar( WL.fTmp1 ), PWideChar( WL.fTmp2 ) );
end;
//[procedure SwapWStrListItems]
procedure SwapWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD );
var WL: PWStrList;
begin
WL := Sender;
WL.Swap( Idx1, Idx2 );
end;
//[procedure TWStrList.Sort]
procedure TWStrList.Sort( CaseSensitive: Boolean );
begin
if CaseSensitive then
SortData( @ Self, Count, @CompareWStrListItems, @SwapWStrListItems )
else
begin
SortData( @ Self, Count, @CompareWStrListItems_UpperCase, @SwapWStrListItems );
fTmp1 := '';
fTmp2 := '';
end;
end;
//[procedure TWStrList.Swap]
procedure TWStrList.Swap(Idx1, Idx2: Integer);
begin
fList.Swap( Idx1, Idx2 );
end;
function TWStrList.IndexOf( const s: WideString ): Integer;
var i: Integer;
p: PWideChar;
begin
for i := 0 to Count-1 do
begin
p := ItemPtrs[ i ];
if (p <> nil) and
(WStrCmp( PWideChar( s ), p ) = 0) then
begin
Result := i;
Exit;
end;
end;
Result := -1;
end;
//[function NewWStrListEx]
function NewWStrListEx: PWStrListEx;
begin
new( Result, Create );
end;
{ TWStrListEx }
//[function TWStrListEx.AddObject]
function TWStrListEx.AddObject(const S: WideString; Obj: DWORD): Integer;
begin
Result := Count;
InsertObject( Count, S, Obj );
end;
//[procedure TWStrListEx.AddWStrings]
procedure TWStrListEx.AddWStrings(WL: PWStrListEx);
var I: Integer;
begin
I := Count;
if WL.FObjects.Count > 0 then
ProvideObjectsCapacity( Count );
inherited AddWStrings( WL );
if WL.FObjects.Count > 0 then
begin
ProvideObjectsCapacity( I + WL.FObjects.Count );
System.Move( WL.FObjects.FItems[ 0 ],
FObjects.FItems[ I ],
Sizeof( Pointer ) * WL.FObjects.Count );
end;
end;
//[procedure TWStrListEx.Assign]
procedure TWStrListEx.Assign(WL: PWStrListEx);
begin
inherited Assign( WL );
FObjects.Assign( WL.FObjects );
end;
//[procedure TWStrListEx.Clear]
procedure TWStrListEx.Clear;
begin
inherited Clear;
FObjects.Clear;
end;
//[procedure TWStrListEx.Delete]
procedure TWStrListEx.Delete(Idx: Integer);
begin
inherited Delete( Idx );
if FObjects.FCount >= Idx then
FObjects.Delete( Idx );
end;
//[destructor TWStrListEx.Destroy]
destructor TWStrListEx.Destroy;
begin
fObjects.Free;
inherited;
end;
//[function TWStrListEx.GetObjects]
function TWStrListEx.GetObjects(Idx: Integer): DWORD;
begin
Result := DWORD( fObjects.Items[ Idx ] );
end;
//[function TWStrListEx.IndexOfObj]
function TWStrListEx.IndexOfObj(Obj: Pointer): Integer;
begin
Result := FObjects.IndexOf( Obj );
end;
//[procedure TWStrListEx.Init]
procedure TWStrListEx.Init;
begin
inherited;
fObjects := NewList;
end;
//[procedure TWStrListEx.InsertObject]
procedure TWStrListEx.InsertObject(Before: Integer; const S: WideString;
Obj: DWORD);
begin
Insert( Before, S );
FObjects.Insert( Before, Pointer( Obj ) );
end;
//[procedure TWStrListEx.Move]
procedure TWStrListEx.Move(IdxOld, IdxNew: Integer);
begin
fList.MoveItem( IdxOld, IdxNew );
if FObjects.FCount >= Min( IdxOld, IdxNew ) then
begin
ProvideObjectsCapacity( Max( IdxOld, IdxNew ) + 1 );
FObjects.MoveItem( IdxOld, IdxNew );
end;
end;
//[procedure TWStrListEx.ProvideObjectsCapacity]
procedure TWStrListEx.ProvideObjectsCapacity(NewCap: Integer);
begin
if fObjects.Capacity >= NewCap then Exit;
fObjects.Capacity := NewCap;
FillChar( FObjects.FItems[ FObjects.Count ],
(FObjects.Capacity - FObjects.Count) * Sizeof( Pointer ), #0 );
FObjects.FCount := NewCap;
end;
//[procedure TWStrListEx.SetObjects]
procedure TWStrListEx.SetObjects(Idx: Integer; const Value: DWORD);
begin
ProvideObjectsCapacity( Idx + 1 );
fObjects.Items[ Idx ] := Pointer( Value );
end;
{$ENDIF}
{$ENDIF WIN_GDI}
{+}
//////////////////////////////////////////////////////////////////////////
// S O R T I N G
//////////////////////////////////////////////////////////////////////////
{ -- qsort -- }
//[PROCEDURE SortData]
{$IFDEF ASM_VERSION} // translated to BASM by Kladov Vladimir
procedure SortData( const Data: Pointer; const uNElem: Dword;
const CompareFun: TCompareEvent;
const SwapProc: TSwapEvent );
asm
CMP EDX, 2
JL @@exit
PUSH EAX // [EBP-4] = Data
PUSH ECX // [EBP-8] = CompareFun
PUSH EBX // EBX = pivotP
XOR EBX, EBX
INC EBX // EBX = 1 to pass to qSortHelp as PivotP
MOV EAX, EDX // EAX = nElem
CALL @@qSortHelp
POP EBX
POP ECX
POP ECX
@@exit:
POP EBP
RET 4
@@qSortHelp:
PUSH EBX // EBX (in) = PivotP
PUSH ESI // ESI = leftP
PUSH EDI // EDI = rightP
@@TailRecursion:
CMP EAX, 2
JG @@2
JNE @@exit_qSortHelp
LEA ECX, [EBX+1]
MOV EDX, EBX
CALL @@Compare
JLE @@exit_qSortHelp
@@swp_exit:
CALL @@Swap
@@exit_qSortHelp:
POP EDI
POP ESI
POP EBX
RET
// ESI = leftP
// EDI = rightP
@@2: LEA EDI, [EAX+EBX-1]
MOV ESI, EAX
SHR ESI, 1
ADD ESI, EBX
MOV ECX, ESI
MOV EDX, EDI
CALL @@CompareLeSwap
MOV EDX, EBX
CALL @@Compare
JG @@4
CALL @@Swap
JMP @@5
@@4: MOV ECX, EBX
MOV EDX, EDI
CALL @@CompareLeSwap
@@5:
CMP EAX, 3
JNE @@6
MOV EDX, EBX
MOV ECX, ESI
JMP @@swp_exit
@@6: // classic Horae algorithm
PUSH EAX // EAX = pivotEnd
LEA EAX, [EBX+1]
MOV ESI, EAX
@@repeat:
MOV EDX, ESI
MOV ECX, EBX
CALL @@Compare
JG @@while2
@@while1:
JNE @@7
MOV EDX, ESI
MOV ECX, EAX
CALL @@Swap
INC EAX
@@7:
CMP ESI, EDI
JGE @@qBreak
INC ESI
JMP @@repeat
@@while2:
CMP ESI, EDI
JGE @@until
MOV EDX, EBX
MOV ECX, EDI
CALL @@Compare
JGE @@8
DEC EDI
JMP @@while2
@@8:
MOV EDX, ESI
MOV ECX, EDI
PUSHFD
CALL @@Swap
POPFD
JE @@until
INC ESI
DEC EDI
@@until:
CMP ESI, EDI
JL @@repeat
@@qBreak:
MOV EDX, ESI
MOV ECX, EBX
CALL @@Compare
JG @@9
INC ESI
@@9:
PUSH EBX // EBX = PivotTemp
PUSH ESI // ESI = leftTemp
DEC ESI
@@while3:
CMP EBX, EAX
JGE @@while3_break
CMP ESI, EAX
JL @@while3_break
MOV EDX, EBX
MOV ECX, ESI
CALL @@Swap
INC EBX
DEC ESI
JMP @@while3
@@while3_break:
POP ESI
POP EBX
MOV EDX, EAX
POP EAX // EAX = nElem
PUSH EDI // EDI = lNum
MOV EDI, ESI
SUB EDI, EDX
ADD EAX, EBX
SUB EAX, ESI
PUSH EBX
PUSH EAX
CMP EAX, EDI
JGE @@10
MOV EBX, ESI
CALL @@qSortHelp
POP EAX
MOV EAX, EDI
POP EBX
JMP @@11
@@10: MOV EAX, EDI
CALL @@qSortHelp
POP EAX
POP EBX
MOV EBX, ESI
@@11:
POP EDI
JMP @@TailRecursion
@@Compare:
PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [EBP-4]
DEC EDX
DEC ECX
CALL dword ptr [EBP-8]
POP ECX
POP EDX
TEST EAX, EAX
POP EAX
RET
@@CompareLeSwap:
CALL @@Compare
JG @@ret
@@Swap: PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [EBP-4]
DEC EDX
DEC ECX
CALL dword ptr [SwapProc]
POP ECX
POP EDX
TEST EAX, EAX
POP EAX
@@ret:
RET
end;
{$ELSE ASM_VERSION} //Pascal
procedure SortData( const Data: Pointer; const uNElem: Dword;
const CompareFun: TCompareEvent;
const SwapProc: TSwapEvent );
{ uNElem - number of elements to sort }
function Compare( const e1, e2 : DWord ) : Integer;
begin
Result := CompareFun( Data, e1 - 1, e2 - 1 );
end;
procedure Swap( const e1, e2 : DWord );
begin
SwapProc( Data, e1 - 1, e2 - 1 );
end;
procedure qSortHelp(pivotP: Dword; nElem: Dword);
label
TailRecursion,
qBreak;
var
leftP, rightP, pivotEnd, pivotTemp, leftTemp: Dword;
lNum: Dword;
retval: integer;
begin
TailRecursion:
if (nElem <= 2) then
begin
if (nElem = 2) then
begin
rightP := pivotP +1;
retval := Compare(pivotP,rightP);
if (retval > 0) then Swap(pivotP,rightP);
end;
exit;
end;
rightP := (nElem -1) + pivotP;
leftP := (nElem shr 1) + pivotP;
{ sort pivot, left, and right elements for "median of 3" }
retval := Compare(leftP,rightP);
if (retval > 0) then Swap(leftP, rightP);
retval := Compare(leftP,pivotP);
if (retval > 0) then
Swap(leftP, pivotP)
else
begin
retval := Compare(pivotP,rightP);
if retval > 0 then Swap(pivotP, rightP);
end;
if (nElem = 3) then
begin
Swap(pivotP, leftP);
exit;
end;
{ now for the classic Horae algorithm }
pivotEnd := pivotP + 1;
leftP := pivotEnd;
repeat
retval := Compare(leftP, pivotP);
while (retval <= 0) do
begin
if (retval = 0) then
begin
Swap(leftP, pivotEnd);
Inc(pivotEnd);
end;
if (leftP < rightP) then
Inc(leftP)
else
goto qBreak;
retval := Compare(leftP, pivotP);
end; {while}
while (leftP < rightP) do
begin
retval := Compare(pivotP, rightP);
if (retval < 0) then
Dec(rightP)
else
begin
Swap(leftP, rightP);
if (retval <> 0) then
begin
Inc(leftP);
Dec(rightP);
end;
break;
end;
end; {while}
until (leftP >= rightP);
qBreak:
retval := Compare(leftP,pivotP);
if (retval <= 0) then Inc(leftP);
leftTemp := leftP -1;
pivotTemp := pivotP;
while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do
begin
Swap(pivotTemp, leftTemp);
Inc(pivotTemp);
Dec(leftTemp);
end; {while}
lNum := (leftP - pivotEnd);
nElem := ((nElem + pivotP) -leftP);
if (nElem < lNum) then
begin
qSortHelp(leftP, nElem);
nElem := lNum;
end
else
begin
qSortHelp(pivotP, lNum);
pivotP := leftP;
end;
goto TailRecursion;
end; {qSortHelp }
begin
if (uNElem < 2) then exit; { nothing to sort }
qSortHelp(1, uNElem);
end;
{$ENDIF ASM_VERSION}
//[END SortData]
//[FUNCTION CompareIntegers]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
var I1, I2 : Integer;
begin
I1 := PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;
I2 := PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
Result := 0;
if I1 < I2 then Result := -1
else
if I1 > I2 then Result := 1;
end;
{$ENDIF ASM_VERSION}
//[END CompareIntegers]
//[FUNCTION CompareDwords]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
var I1, I2 : DWord;
begin
I1 := PDWORD( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;
I2 := PDWORD( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
Result := 0;
if I1 < I2 then Result := -1
else
if I1 > I2 then Result := 1;
end;
{$ENDIF ASM_VERSION}
//[END CompareDwords]
//[PROCEDURE SwapIntegers]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD );
var Tmp : Integer;
begin
Tmp := PInteger( DWORD( Sender ) + e1 * SizeOf( Integer ) )^;
PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^ :=
PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^ := Tmp;
end;
{$ENDIF ASM_VERSION}
//[END SwapIntegers]
//[procedure SortIntegerArray]
procedure SortIntegerArray( var A : array of Integer );
begin
SortData( @A[ 0 ], High( A ) - Low( A ) + 1, @CompareIntegers, @SwapIntegers );
end;
procedure SwapListItems( const L: Pointer; const e1, e2: DWORD );
begin
PList( L ).Swap( e1, e2 );
end;
//[procedure SortDwordArray]
procedure SortDwordArray( var A : array of DWORD );
begin
SortData( @A[ 0 ], High( A ) - Low( A ) + 1, @CompareDwords, @SwapIntegers );
end;
{$IFDEF WIN_GDI}
{ -- status bar implementation -- }
//[FUNCTION _NewStatusbar]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function _NewStatusbar( AParent: PControl ): PControl;
var Style: DWORD;
begin
Style := WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or 3 or WS_VISIBLE;
{if AParent.CanResize then
Style := Style or SBARS_SIZEGRIP;}
if AParent.fSizeGrip then
Style := (Style or SBARS_SIZEGRIP) and not 3;
Result := _NewCommonControl( AParent, STATUSCLASSNAME,
Style, FALSE, nil );
with Result.fBoundsRect do
begin
Left := 0;
Right := 0;
Top := 0;
Bottom := 0;
end;
Result.fAlign := caBottom;
Result.fNotUseAlign := True;
{$IFDEF TEST_VERSION}
Result.fTag := DWORD( PChar( 'Status bar' ) );
{$ENDIF}
InitCommonControlSizeNotify( Result );
{$ifdef wince}
Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
{$endif wince}
end;
{$ENDIF ASM_VERSION}
//[END _NewStatusbar]
//[procedure TControl.SetStatusText]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetStatusText(Index: Integer; Value: PKOLChar);
var ch: Integer;
R : TRect;
N, I, L, W : Integer;
WidthsBuf: array[ 0..254 ] of Integer;
begin
if fStatusCtl = nil then
begin
ch := GetClientHeight;
fStatusCtl := _NewStatusBar( @Self );
fStatusWnd := fStatusCtl.GetWindowHandle;
fStatusCtl.Perform( SB_SIMPLE, Integer( LongBool( Index = 255 ) ), 0 );
GetWindowRect( fStatusWnd, R );
fClientBottom := R.Bottom - R.Top;
SetClientHeight( ch );
SendMessage( fStatusWnd, WM_SIZE, 0, 0 );
end;
if Index < 255 then
begin
N := SendMessage( fStatusWnd, SB_GETPARTS, 0, 0 );
if N <= Index then
begin
W := Width;
L := W div (Index + 1);
W := L;
for I := 0 to Index - 1 do
begin
WidthsBuf[ I ] := W;
Inc( W, L );
end;
WidthsBuf[ Index ] := -1;
SendMessage( fStatusWnd, SB_SETPARTS, Index + 1, Integer( @WidthsBuf[ 0 ] ) );
end;
SendMessage( fStatusWnd, SB_SIMPLE, 0, 0 );
end;
SendMessage( fStatusWnd,
{$IFDEF UNICODE_CTRLS} SB_SETTEXTW {$ELSE} SB_SETTEXT {$ENDIF}, Index, Integer( Value ) );
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetStatusText]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetStatusText( Index: Integer ): PKOLChar;
var L, I: Integer;
Msg: DWORD;
begin
Result := nil;
if fStatusWnd = 0 then Exit;
if fStatusTxt <> nil then
FreeMem( fStatusTxt );
fStatusTxt := nil;
Msg := SB_GETTEXTLENGTH;
I := Index;
if Index = 255 then
begin
Msg := WM_GETTEXTLENGTH;
I := 0;
end;
L := SendMessage( fStatusWnd, Msg, I, 0 ) and $FFFF;
if L > 0 then
begin
GetMem( fStatusTxt, (L + 1)*Sizeof(KOLChar) );
fStatusTxt[ L ] := #0;
Msg := {$IFDEF UNICODE_CTRLS} SB_GETTEXTW {$ELSE} SB_GETTEXT {$ENDIF};
if Index = 255 then
Msg := WM_GETTEXT;
SendMessage( fStatusWnd, Msg, I, Integer( fStatusTxt ) );
end;
Result := fStatusTxt;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.RemoveStatus]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.RemoveStatus;
var ch: Integer;
begin
if fStatusCtl = nil then Exit;
ch := ClientHeight;
fStatusWnd := 0;
fStatusCtl.Free;
fStatusCtl := nil;
fClientBottom := 0;
ClientHeight := ch;
end;
{$ENDIF ASM_VERSION}
//[function TControl.StatusPanelCount]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.StatusPanelCount: Integer;
begin
Result := 0;
if fStatusWnd = 0 then Exit;
Result := SendMessage( fStatusWnd, SB_GETPARTS, 0, 0 );
end;
{$ENDIF ASM_VERSION}
//[function TControl.GetStatusPanelX]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetStatusPanelX(Idx: Integer): Integer;
var Buf: array[0..254] of Integer;
N : Integer;
begin
Result := 0;
if fStatusWnd = 0 then Exit;
N := SendMessage( fStatusWnd, SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
if N <= Idx then Exit;
Result := Buf[ Idx ];
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetStatusPanelX]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetStatusPanelX(Idx: Integer; const Value: Integer);
var Buf: array[0..254] of Integer;
N : Integer;
begin
if fStatusWnd = 0 then Exit;
N := SendMessage( fStatusWnd, SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
if N <= Idx then Exit;
Buf[ Idx ] := Value;
SendMessage( fStatusWnd, SB_SETPARTS, N, Integer( @Buf[ 0 ] ) );
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.SetColor1]
procedure TControl.SetColor1(const Value: TColor);
begin
fColor1 := Value;
Invalidate;
end;
//[procedure TControl.SetColor2]
procedure TControl.SetColor2(const Value: TColor);
begin
fColor2 := Value;
Invalidate;
end;
//[procedure TControl.SetGradientLayout]
procedure TControl.SetGradientLayout(const Value: TGradientLayout);
begin
FGradientLayout := Value;
Invalidate;
end;
//[procedure TControl.SetGradientStyle]
procedure TControl.SetGradientStyle(const Value: TGradientStyle);
begin
FGradientStyle := Value;
Invalidate;
end;
{ -- Image List -- }
//*
{$IFDEF USE_CONSTRUCTORS}
//[function NewImageList]
function NewImageList( AOwner: PControl ): PImageList;
begin
new( Result, CreateImageList( AOwner ) );
end;
//[END NewImageList]
{$ELSE not_USE_CONSTRUCTORS}
//[function NewImageList]
function NewImageList( AOwner: PControl ): PImageList;
begin
{*************} DoInitCommonControls( ICC_WIN95_CLASSES );
{-}
New( Result, Create );
{+}
{++}(*Result := TImageList.Create;*){--}
Result.FAllocBy := 1;
Result.FMasked := True;
Result.fBkColor := clNone;
//ImageList_SetBkColor( Result.FHandle, CLR_NONE );
Result.FImgWidth := 32;
Result.FImgHeight := 32;
Result.FColors := ilcDefault;
if AOwner = nil then exit;
Result.fNext := PImageList( AOwner.fImageList );
if AOwner.fImageList <> nil then
PImageList( AOwner.fImageList ).fPrev := Result;
Result.FControl := AOwner;
{$IFDEF USE_AUTOFREE4CONTROLS}
AOwner.Add2AutoFree( Result );
{$ENDIF}
AOwner.fImageList := Result;
end;
{$ENDIF}
{$ifdef win32}
//[API ImageList_XXX]
function ImageList_Create; {$ifdef wince}cdecl{$else}stdcall{$endif}; external cctrl name 'ImageList_Create';
function ImageList_Destroy; external cctrl name 'ImageList_Destroy';
function ImageList_GetImageCount; external cctrl name 'ImageList_GetImageCount';
function ImageList_SetImageCount; external cctrl name 'ImageList_SetImageCount';
function ImageList_Add; external cctrl name 'ImageList_Add';
function ImageList_ReplaceIcon; external cctrl name 'ImageList_ReplaceIcon';
function ImageList_SetBkColor; external cctrl name 'ImageList_SetBkColor';
function ImageList_GetBkColor; external cctrl name 'ImageList_GetBkColor';
function ImageList_SetOverlayImage; external cctrl name 'ImageList_SetOverlayImage';
function ImageList_Draw; external cctrl name 'ImageList_Draw';
function ImageList_Replace; external cctrl name 'ImageList_Replace';
function ImageList_AddMasked; external cctrl name 'ImageList_AddMasked';
function ImageList_DrawEx; external cctrl name 'ImageList_DrawEx';
function ImageList_Remove; external cctrl name 'ImageList_Remove';
function ImageList_GetIcon; external cctrl name 'ImageList_GetIcon';
{$IFDEF UNICODE_CTRLS}
function ImageList_LoadImage; external cctrl name 'ImageList_LoadImageW';
{$ELSE}
function ImageList_LoadImage; external cctrl name 'ImageList_LoadImageA';
{$ENDIF}
function ImageList_BeginDrag; external cctrl name 'ImageList_BeginDrag';
function ImageList_EndDrag; external cctrl name 'ImageList_EndDrag';
function ImageList_DragEnter; external cctrl name 'ImageList_DragEnter';
function ImageList_DragLeave; external cctrl name 'ImageList_DragLeave';
function ImageList_DragMove; external cctrl name 'ImageList_DragMove';
function ImageList_SetDragCursorImage; external cctrl name 'ImageList_SetDragCursorImage';
function ImageList_DragShowNolock; external cctrl name 'ImageList_DragShowNolock';
function ImageList_GetDragImage; external cctrl name 'ImageList_GetDragImage';
function ImageList_GetIconSize; external cctrl name 'ImageList_GetIconSize';
function ImageList_SetIconSize; external cctrl name 'ImageList_SetIconSize';
function ImageList_GetImageInfo; external cctrl name 'ImageList_GetImageInfo';
function ImageList_Merge; external cctrl name 'ImageList_Merge';
//[function ImageList_AddIcon]
function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer;
begin
Result := ImageList_ReplaceIcon(ImageList, -1, Icon);
end;
//[function Index2OverlayMask]
function Index2OverlayMask(Index: Integer): Integer;
begin
Result := Index shl 8;
end;
{ macros }
//[procedure ImageList_RemoveAll]
procedure ImageList_RemoveAll(ImageList: HImageList); {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
ImageList_Remove(ImageList, -1);
end;
//[function ImageList_ExtractIcon]
function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList;
Image: Integer): HIcon; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
Result := ImageList_GetIcon(ImageList, Image, 0);
end;
//[function ImageList_LoadBitmap]
function ImageList_LoadBitmap(Instance: THandle; Bmp: PKOLChar;
CX, Grow: Integer; Mask: TColorRef): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
Result := ImageList_LoadImage(Instance, Bmp, CX, Grow, Mask, IMAGE_BITMAP, 0);
end;
{$endif win32}
//[procedure FreeBmp]
procedure FreeBmp( Bmp: HBitmap );
begin
DeleteObject( Bmp );
end;
//[function LoadBmp]
function LoadBmp( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap;
begin
Result := LoadBitmap( Instance, Rsrc );
MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) );
end;
{ TImageList }
//*
//[function TImageList.Add]
function TImageList.Add(Bmp, Msk: HBitmap): Integer;
begin
Result := -1;
if not HandleNeeded then Exit;
Result := ImageList_Add( FHandle, Bmp, Msk );
end;
//*
//[function TImageList.AddIcon]
function TImageList.AddIcon(Ico: HIcon): Integer;
{var Bmp : HBitmap;
DC : HDC;}
begin
Result := -1;
if ImgWidth = 0 then
ImgWidth := 32;
if ImgHeight = 0 then
ImgHeight := 32;
if not HandleNeeded then Exit;
Result := ImageList_AddIcon( fHandle, Ico );
end;
//*
//[function TImageList.AddMasked]
function TImageList.AddMasked(Bmp: HBitmap; Color: TColor): Integer;
begin
Result := -1;
if not HandleNeeded then Exit;
Result := ImageList_AddMasked( FHandle, Bmp, Color2RGB( Color ) );
end;
//+
//[procedure TImageList.Clear]
procedure TImageList.Clear;
begin
Handle := 0;
end;
//*
//[procedure TImageList.Delete]
procedure TImageList.Delete(Idx: Integer);
begin
if FHandle = 0 then Exit;
ImageList_Remove( FHandle, Idx );
end;
//[destructor TImageList.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TImageList.Destroy;
begin
Clear;
if fNext <> nil then
fNext.fPrev := fPrev;
if fPrev <> nil then
fPrev.fNext := fNext;
if fControl <> nil then
begin
if PControl( fControl ).fImageList = @Self then
PControl( fControl ).fImageList := fNext;
{$IFDEF USE_AUTOFREE4CONTROLS}
PControl(fControl).RemoveFromAutoFree( @ Self );
{$ENDIF}
end;
inherited;
end;
{$ENDIF ASM_VERSION}
//*
//[procedure TImageList.Draw]
procedure TImageList.Draw(Idx: Integer; DC: HDC; X, Y: Integer);
begin
if FHandle = 0 then Exit;
ImageList_Draw( FHandle, Idx, DC, X, Y, GetDrawStyle );
end;
//[function TImageList.ExtractIcon]
function TImageList.ExtractIcon(Idx: Integer): HIcon;
begin
Result := ImageList_ExtractIcon( 0, FHandle, Idx );
end;
//[function TImageList.ExtractIconEx]
function TImageList.ExtractIconEx(Idx: Integer): HIcon;
begin
Result := ImageList_GetIcon( FHandle, Idx, GetDrawStyle );
end;
//*
//[function TImageList.GetBitmap]
function TImageList.GetBitmap: HBitmap;
var II : TImageInfo;
begin
Result := 0;
if FHandle = 0 then Exit;
if ImageList_GetImageInfo( FHandle, 0, II ) then
Result := II.hbmImage;
end;
//*
//[function TImageList.GetBkColor]
function TImageList.GetBkColor: TColor;
begin
Result := fBkColor;
if FHandle = 0 then Exit;
Result := ImageList_GetBkColor( FHandle );
end;
//*
//[function TImageList.GetCount]
function TImageList.GetCount: Integer;
begin
Result := 0;
if FHandle <> 0 then
Result := ImageList_GetImageCount( FHandle );
end;
//*
//[function TImageList.GetDrawStyle]
function TImageList.GetDrawStyle: DWord;
begin
Result := 0;
if dsBlend25 in DrawingStyle then
Result := Result or ILD_BLEND25;
if dsBlend50 in DrawingStyle then
Result := Result or ILD_BLEND50;
if dsTransparent in DrawingStyle then
Result := Result or ILD_TRANSPARENT
else
if dsMask in DrawingStyle then
Result := Result or ILD_MASK
{else
Result := Result or ILD_NORMAL}; // ILD_NORMAL = 0
end;
//[function TImageList.GetHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TImageList.GetHandle: THandle;
begin
HandleNeeded;
Result := FHandle;
end;
{$ENDIF ASM_VERSION}
//*
//[function TImageList.GetMask]
function TImageList.GetMask: HBitmap;
var II : TImageInfo;
begin
Result := 0;
if FHandle = 0 then Exit;
if ImageList_GetImageInfo( FHandle, 0, II ) then
Result := II.hbmMask;
end;
{$IFDEF ASM_noVERSION}
//[function TImageList.HandleNeeded]
function TImageList.HandleNeeded: Boolean;
const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR,
ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24,
ILC_COLOR32, ILC_COLORDDB );
asm
MOV ECX, [EAX].FHandle
JECXZ @@make_handle
MOV AL, 1
RET
@@make_handle:
MOV ECX, [EAX].fImgWidth
JECXZ @@ret_ECX
MOV EDX, ECX
MOV ECX, [EAX].fImgHeight
JECXZ @@ret_ECX
PUSH EBX
XCHG EBX, EAX
PUSH [EBX].FAllocBy
PUSH 0
MOVZX EAX, [EBX].FColors
MOVZX EAX, byte ptr [ColorFlags+EAX]
CMP [EBX].FMasked, 0
JZ @@flags_ready
{$IFDEF PARANOIA} DB $0C, $01 {$ELSE} OR AL, 1 {$ENDIF}
@@flags_ready:
PUSH EAX
PUSH ECX
PUSH EDX
CALL ImageList_Create
MOV [EBX].FHandle, EAX
XCHG ECX, EAX
POP EBX
@@ret_ECX:
TEST ECX, ECX
SETNZ AL
end;
{$ELSE ASM_VERSION} //Pascal
function TImageList.HandleNeeded: Boolean;
const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR,
{$ifndef wince}
ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24, ILC_COLOR32,
{$else}
ILC_COLOR, ILC_COLOR, ILC_COLOR, ILC_COLOR, ILC_COLOR,
{$endif wince}
ILC_COLORDDB, 0 );
var Flags : DWord;
begin
Result := True;
if FHandle <> 0 then Exit;
Result := False;
if ImgWidth = 0 then Exit;
if ImgHeight = 0 then Exit;
Flags := ColorFlags[ FColors ];
if Masked then
Flags := Flags or ILC_MASK;
FHandle := ImageList_Create( ImgWidth, ImgHeight, Flags, 0, FAllocBy );
if fBkColor <> clNone then
SetBkColor( fBkColor );
Result := FHandle <> 0;
end;
{$ENDIF ASM_VERSION}
//*
//[function TImageList.ImgRect]
function TImageList.ImgRect(Idx: Integer): TRect;
var II : TImageInfo;
begin
Result := MakeRect( 0, 0, 0, 0 );
if FHandle = 0 then Exit;
if ImageList_GetImageInfo( FHandle, Idx, II ) then
Result := II.rcImage;
end;
{$IFDEF ASM_noVERSION_UNICODE}
//[function TImageList.LoadBitmap]
function TImageList.LoadBitmap(ResourceName: PChar;
TranspColor: TColor): Boolean;
asm
PUSH EBX
XCHG EBX, EAX
XCHG EAX, ECX //TranspColor
PUSH EDX
CMP EAX, clNone
JNE @@2rgb
OR EAX, -1
JMP @@tranColorReady
@@2rgb:
CALL Color2RGB
@@tranColorReady:
POP EDX
PUSH EAX
PUSH [EBX].fAllocBy
PUSH [EBX].fImgWidth
PUSH EDX
PUSH [hInstance]
CALL ImageList_LoadBitmap
TEST EAX, EAX
JZ @@exit
XCHG EDX, EAX
XCHG EAX, EBX
CALL SetHandle
MOV AL, 1
@@exit: POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TImageList.LoadBitmap(ResourceName: PKOLChar;
TranspColor: TColor): Boolean;
var NewHandle : THandle;
TranColr: TColor;
begin
TranColr := TranspColor;
if TranColr = clNone then TranColr := TColor( CLR_NONE )
else TranColr := Color2RGB( TranColr );
NewHandle := ImageList_LoadBitmap( hInstance, pointer(ResourceName),
ImgWidth, AllocBy, TranColr );
//ImageList_GetIconSize( NewHandle, fImgWidth, fImgHeight );
Result := NewHandle <> 0;
if Result then
Handle := NewHandle;
ImageList_GetIconSize( fHandle, FImgWidth, FImgHeight );
end;
{$ENDIF ASM_VERSION}
//*
//[function TImageList.LoadFromFile]
function TImageList.LoadFromFile(FileName: PKOLChar; TranspColor: TColor;
ImgType: TImageType): Boolean;
const ImgTypes:array[ TImageType ] of DWord = ( IMAGE_BITMAP, IMAGE_ICON, IMAGE_CURSOR );
var NewHandle : THandle;
TranspFlag : DWord;
begin
TranspFlag := 0;
if TranspColor <> clNone then
TranspFlag := LR_LOADTRANSPARENT;
NewHandle := ImageList_LoadImage( hInstance, pointer(FileName), ImgWidth, AllocBy,
Color2RGB( TranspColor ), ImgTypes[ ImgType ],
LR_LOADFROMFILE or TranspFlag );
Result := NewHandle <> 0;
if Result then
Handle := NewHandle;
end;
//*
//[function TImageList.LoadSystemIcons]
function TImageList.LoadSystemIcons(SmallIcons: Boolean): Boolean;
var NewHandle : THandle;
FileInfo : TSHFileInfo;
Flags : DWord;
begin
{$ifdef win32}OleInit;{$endif}
Flags := SHGFI_SYSICONINDEX;
if SmallIcons then
Flags := Flags or SHGFI_SMALLICON;
NewHandle := {$IFDEF UNICODE_CTRLS} SHGetFileInfoW {$ELSE} SHGetFileInfoA {$ENDIF}
( '', 0, FileInfo, Sizeof( FileInfo ), Flags );
Result := NewHandle <> 0;
if Result then
begin
Handle := NewHandle;
FShareImages := True;
end;
end;
//*
//[function TImageList.Merge]
function TImageList.Merge(Idx: Integer; ImgList2: PImageList; Idx2, X,
Y: Integer): PImageList;
var L : THandle;
begin
Result := nil;
//if FHandle = 0 then Exit;
L := ImageList_Merge( FHandle, Idx, ImgList2.Handle, Idx2, X, Y );
if L <> 0 then
begin
Result := NewImageList( fControl );
Result.Handle := L;
end;
end;
//*
//[function TImageList.Replace]
function TImageList.Replace(Idx: Integer; Bmp, Msk: HBitmap): Boolean;
begin
Result := False;
if FHandle = 0 then Exit;
Result := ImageList_Replace( FHandle, Idx, Bmp, Msk );
end;
//*
//[function TImageList.ReplaceIcon]
function TImageList.ReplaceIcon(Idx: Integer; Ico: HIcon): Boolean;
begin
Result := False;
if FHandle = 0 then Exit;
Result := ImageList_ReplaceIcon( FHandle, Idx, Ico ) >= 0;
end;
//*
//[procedure TImageList.SetAllocBy]
procedure TImageList.SetAllocBy(const Value: Integer);
begin
if FHandle <> 0 then Exit;
// AllocBy can be changed only before adding images
// and creating image list handle
FAllocBy := Value;
end;
//*
//[procedure TImageList.SetBkColor]
procedure TImageList.SetBkColor(const Value: TColor);
begin
fBkColor := Value;
if fHandle <> 0 then
ImageList_SetBkColor( FHandle, Color2RGB( Value ) );
end;
//*
//[procedure TImageList.SetColors]
procedure TImageList.SetColors(const Value: TImageListColors);
begin
if FHandle <> 0 then Exit;
FColors := Value;
end;
//[procedure TImageList.SetHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TImageList.SetHandle(const Value: THandle);
begin
if FHandle = Value then Exit;
if (FHandle <> 0) and not FShareImages then
ImageList_Destroy( FHandle );
FHandle := Value;
if FHandle <> 0 then
ImageList_GetIconSize( FHandle, FImgWidth, FImgHeight )
else
begin
FImgWidth := 0;
FImgHeight := 0;
end;
//FBkColor := ImageList_GetBkColor( FHandle );
end;
{$ENDIF ASM_VERSION}
//[procedure TImageList.SetImgHeight]
procedure TImageList.SetImgHeight(const Value: Integer);
begin
if FHandle <> 0 then Exit;
FImgHeight := Value;
end;
//[procedure TImageList.SetImgWidth]
procedure TImageList.SetImgWidth(const Value: Integer);
begin
if FHandle <> 0 then Exit;
FImgWidth := Value;
end;
//[procedure TImageList.SetMasked]
procedure TImageList.SetMasked(const Value: Boolean);
begin
if FHandle <> 0 then Exit;
FMasked := Value;
end;
//*
//[function TImageList.GetOverlay]
function TImageList.GetOverlay(Idx: TImgLOVrlayIdx): Integer;
begin
Result := fOverlay[ Idx ];
end;
//[procedure TImageList.SetOverlay]
procedure TImageList.SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer);
begin
if ImageList_SetOverlayImage( fHandle, Value, Idx ) then
fOverlay[ Idx ] := Value;
end;
//[procedure TImageList.StretchDraw]
procedure TImageList.StretchDraw(Idx: Integer; DC: HDC; const Rect: TRect);
begin
if FHandle = 0 then Exit;
ImageList_DrawEx( FHandle, Idx, DC, Rect.Left, Rect.Top,
Rect.Right- Rect.Left, Rect.Bottom-Rect.Top,
BkColor, BlendColor, GetDrawStyle );
end;
//*
//[function GetImgListSize]
function GetImgListSize( Sender: PControl; Size: Integer ): PImageList;
begin
if Size > 16 then
Result := Sender.fCtlImageListNormal
else
Result := Sender.fCtlImageListSml;
if Result <> nil then
begin
if Result.fImgWidth = 0 then
Result.ImgWidth := Size;
if Result.fImgHeight = 0 then
Result.ImgHeight := Size;
//if (Result.FImgWidth <> Size) or (Result.FImgHeight <> Size) then
// Result := nil;
end;
if Result = nil then
begin
Result := Sender.fImageList;
while Result <> nil do
begin
if (Result.FImgWidth = Size) and (Result.FImgHeight = Size) then
break;
Result := Result.fNext;
end;
end;
end;
//*
//[function TControl.GetImgListIdx]
function TControl.GetImgListIdx(const Index: Integer): PImageList;
begin
if Index <> 0 then
Result := GetImgListSize( @Self, Index )
else
begin
Result := fCtlImgListState;
if Result = nil then
begin
Result := fImageList;
while Result <> nil do
begin
if (Result <> GetImgListIdx( 16 )) and (Result <> GetImgListIdx( 32 )) then
break;
Result := Result.fNext;
end;
end;
end;
end;
//*
//[procedure TControl.SetImgListIdx]
procedure TControl.SetImgListIdx(const Index: Integer;
const Value: PImageList);
begin
if Value <> nil then
begin
if Index <> 0 then
if (Value.ImgWidth = 0) or (Value.ImgHeight = 0) then
begin
Value.ImgWidth := Index;
Value.ImgHeight := Index;
end;
end;
case Index of
32: fCtlImageListNormal := Value;
16: fCtlImageListSml := Value;
else fCtlImgListState := Value;
end;
ApplyImageLists2Control( @Self );
end;
{ -- list view -- }
//[function WndProcEndLabelEdit]
function WndProcEndLabelEdit( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NMhdr: PNMHdr;
LVDisp: PLVDispInfo;
Flag: Boolean;
begin
Result := False;
if Msg.message = WM_NOTIFY then
begin
NMHdr := Pointer( Msg.lParam );
case LongInt(NMHdr.code) of
LVN_ENDLABELEDIT:
begin
LVDisp := Pointer( Msg.lParam );
Result := True;
if LVDisp.item.pszText = nil then Exit;
Rslt := 1;
if assigned( Self_.fOnEndEditLVItem ) then
begin
Flag := Self_.fOnEndEditLVItem( Self_, LVDisp.item.iItem,
LVDisp.item.iSubItem, LVDisp.item.pszText );
if Flag then Rslt := 1
else Rslt := 0;
end;
end;
end;
end;
end;
//[procedure TControl.SetOnEndEditLVItem]
procedure TControl.SetOnEndEditLVItem(const Value: TOnEditLVItem);
begin
fOnEndEditLVITem := Value;
AttachProc( WndProcEndLabelEdit );
end;
//*
//[procedure TControl.LVColAdd]
procedure TControl.LVColAdd(const aText: KOLString; aalign: TTextAlign;
aWidth: Integer);
begin
LVColInsert( fLVColCount, aText, aalign, aWidth );// 21.10.2001
end;
//****************** changed by Mike Gerasimov
//[procedure TControl.LVColInsert]
procedure TControl.LVColInsert(ColIdx: Integer; const aText: KOLString;
aAlign: TTextAlign; aWidth: Integer);
var LVColData: TLVColumn;
begin
LVColData.mask := LVCF_FMT or LVCF_TEXT;
if ImageListSmall <> nil then
LVColData.mask := LVColData.mask; // or LVCF_IMAGE ;
LVColData.iImage := -1;
LVColData.fmt := Ord( aAlign );
if aWidth < 0 then
begin
aWidth := -aWidth;
LVColData.fmt := LVColData.fmt or LVCFMT_BITMAP_ON_RIGHT;
end;
LVColData.cx := aWidth;
if aWidth > 0 then
LVColData.mask := LVColData.mask or LVCF_WIDTH;
LVColData.pszText := PKOL_Char( aText );
if Perform( LVM_INSERTCOLUMN, ColIdx, Integer( @LVColData ) ) >= 0 then
Inc( fLVColCount );
end;
//[function TControl.GetLVColText]
function TControl.GetLVColText(Idx: Integer): KOLString;
var Buf: array[ 0..4095 ] of KOLChar;
LC: TLVColumn;
begin
LC.mask := LVCF_TEXT;
LC.pszText := @ Buf[ 0 ];
LC.cchTextMax := 4096;
Buf[ 0 ] := #0;
Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
Result := Buf;
end;
//[procedure TControl.SetLVColText]
procedure TControl.SetLVColText(Idx: Integer; const Value: KOLString);
var LC: TLVColumn;
begin
FillChar( LC, Sizeof( LC ), #0 ); {Alexey (Lecha2002)}
LC.mask := LVCF_TEXT;
LC.pszText := '';
if Value <> '' then
LC.pszText := @ Value[ 1 ];
Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );
end;
//[function TControl.GetLVColalign]
function TControl.GetLVColalign(Idx: Integer): TTextAlign;
const Formats: array[ 0..2 ] of TTextAlign = ( taLeft, taRight, taCenter );
var LC: TLVColumn;
begin
FillChar( LC, Sizeof( LC ), #0 ); {Alexey (Lecha2002)}
LC.mask := LVCF_FMT;
Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
Result := Formats[ LC.fmt and LVCFMT_JUSTIFYMASK ];
end;
//[procedure TControl.SetLVColalign]
procedure TControl.SetLVColalign(Idx: Integer; const Value: TTextAlign);
const FormatFlags: array[ TTextAlign ] of BYTE = ( LVCFMT_LEFT, LVCFMT_RIGHT,
LVCFMT_CENTER );
var LC: TLVColumn;
begin
FillChar( LC, Sizeof( LC ), #0 ); {Alexey (Lecha2002)}
LC.mask := LVCF_FMT;
Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
LC.fmt := LC.fmt and not LVCFMT_JUSTIFYMASK or FormatFlags[ Value ];
Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );
end;
//[function TControl.GetLVColEx]
function TControl.GetLVColEx(Idx: Integer; const Index: Integer): Integer;
var LC: TLVColumn;
begin
FillChar( LC, Sizeof( LC ), #0 ); {Alexey (Lecha2002)}
LC.mask := LoWord( Index );
Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
Result := PDWORD( cardinal( @ LC ) + HiWord( Index ) )^;
end;
//********************** changed by Mike Gerasimov
//[procedure TControl.SetLVColEx]
procedure TControl.SetLVColEx(Idx: Integer; const Index: Integer;
const Value: Integer);
var LC: TLVColumn;
begin
FillChar(LC,SizeOf(LC),#0); // Added Line
LC.mask := LoWord( Index );
{$ifdef win32}
if HiWord( Index ) = 24 then // Added Line
begin // Added Line
LC.mask := LC.mask or LVCF_FMT; // Added Line
if Value <>-1 then // Added Line
LC.fmt := LC.fmt or LVCFMT_IMAGE or LVCFMT_COL_HAS_IMAGES // Added Line
else LC.mask := LC.mask and not LVCF_IMAGE; // + by non
end;
{$endif win32}
if (value<>-1)or(HiWord( Index )<>24) then // + by non
PDWORD( cardinal( @ LC ) + HiWord( Index ) )^ := Value;
Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );
end;
//*
//[function TControl.LVAdd]
function TControl.LVAdd(const aText: KOLString; ImgIdx: Integer;
State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer;
Data: DWORD): Integer;
begin
Result := LVInsert( MaxInt {Count}, aText, ImgIdx, State, StateImgIdx, OverlayImgIdx, Data );
end;
//*
//[function TControl.LVInsert]
function TControl.LVInsert(Idx: Integer; const aText: KOLString;
ImgIdx: Integer; State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer;
Data: DWORD): Integer;
const
LVM_REDRAWITEMS = LVM_FIRST + 21;
var LVI: TLVItem;
begin
LVI.mask := LVIF_TEXT or LVIF_IMAGE or LVIF_PARAM or LVIF_STATE;
LVI.iItem := Idx;
LVI.iSubItem := 0;
LVI.state := 0;
if lvisBlend in State then
LVI.state := LVIS_CUT;
if lvisHighlight in State then
LVI.state := LVI.state or LVIS_DROPHILITED;
if lvisFocus in State then
LVI.state := LVI.state or LVIS_FOCUSED;
if lvisSelect in State then
LVI.state := LVI.state or LVIS_SELECTED;
LVI.stateMask := $FFFF;
if StateImgIdx <> 0 then
LVI.state := LVI.state or ((cardinal(StateImgIdx) and $F) shl 12);
if OverlayImgIdx <> 0 then
LVI.state := LVI.state or ((cardinal(OverlayImgIdx) and $F) shl 8);
LVI.pszText := PKOL_Char( aText );
LVI.iImage := ImgIdx;
LVI.lParam := Data;
Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) );
//Perform( LVM_REDRAWITEMS, Idx, Idx );
end;
//*
//[procedure TControl.LVSetItem]
procedure TControl.LVSetItem(Idx, Col: Integer; const aText: KOLString;
ImgIdx: Integer; State: TListViewItemState; StateImgIdx,
OverlayImgIdx: Integer; Data: DWORD);
var LVI: TLVItem;
I: Integer;
begin
if Col = 0 then
LVI.mask := LVIF_TEXT or LVIF_STATE or LVIF_PARAM
else
LVI.mask := LVIF_TEXT;
if ImgIdx <> I_SKIP then
LVI.mask := LVI.mask or LVIF_IMAGE;
if ImgIdx < I_SKIP then
LVI.mask := LVIF_TEXT;
LVI.iItem := Idx;
LVI.iSubItem := Col;
LVI.state := 0;
if lvisBlend in State then
LVI.state := LVIS_CUT;
if lvisHighlight in State then
LVI.state := LVI.state or LVIS_DROPHILITED;
if lvisFocus in State then
LVI.state := LVI.state or LVIS_FOCUSED;
if lvisSelect in State then
LVI.state := LVI.state or LVIS_SELECTED;
LVI.stateMask := $FFFF;
if StateImgIdx <> 0 then
LVI.state := LVI.state or ((cardinal(StateImgIdx) and $F) shl 12);
if StateImgIdx < 0 {= I_SKIP} then
LVI.stateMask := $F0FF;
if OverlayImgIdx <> 0 then
LVI.state := LVI.state or ((cardinal(OverlayImgIdx) and $F) shl 8);
if OverlayImgIdx < 0 {=I_SKIP} then
LVI.stateMask := LVI.stateMask and $FFF;
LVI.pszText := PKOL_Char( aText );
LVI.iImage := ImgIdx;
LVI.lParam := Data;
I := Perform( LVM_SETITEM, 0, Integer( @LVI ) );
if (I = 0) and (Col = 0) then
Assert( False, 'Can not set item ' );
end;
//*
//[procedure LVGetItem]
procedure LVGetItem( Sender: PControl; Idx, Col: Integer; var LVI: TLVItem;
TextBuf: PKOL_Char; TextBufSize: Integer );
begin
LVI.mask := LVIF_STATE or LVIF_PARAM or LVIF_IMAGE;
if Col > 0 then
if not (lvoSubItemImages in Sender.fLVOptions) then
LVI.mask := LVIF_STATE or LVIF_PARAM;
LVI.iItem := Idx;
LVI.iSubItem := Col;
LVI.pszText := TextBuf;
LVI.cchTextMax := TextBufSize;
if TextBufSize <> 0 then
LVI.mask := LVI.mask or LVIF_TEXT;
Sender.Perform( LVM_GETITEM, 0, Integer( @LVI ) );
end;
//[function TControl.LVGetItemImgIdx]
function TControl.LVGetItemImgIdx(Idx: Integer): Integer;
var LVI: TLVItem;
begin
LVI.iImage := -1;//= Result if image is not assigned {Andrzej Kubaszek}
LVGetItem( @Self, Idx, 0, LVI, nil, 0 );
Result := LVI.iImage;
end;
//[procedure TControl.LVSetItemImgIdx]
procedure TControl.LVSetItemImgIdx(Idx: Integer; const Value: Integer);
var LVI: TLVItem;
begin
LVGetItem( @Self, Idx, 0, LVI, nil, 0 );
LVI.iImage := Value;
Perform( LVM_SETITEM, 0, Integer( @LVI ) );
end;
//[function TControl.LVGetItemText]
function TControl.LVGetItemText(Idx, Col: Integer): KOLString;
var LVI: TLVItem;
TextBuf: PKOL_Char;
BufSize: Integer;
begin
BufSize := 0;
TextBuf := nil;
repeat
if TextBuf <> nil then
FreeMem( TextBuf );
BufSize := BufSize * 2 + 100; // to vary in asm version
GetMem( TextBuf, BufSize * Sizeof( KOLChar ) );
TextBuf[ 0 ] := #0;
LVGetItem( @Self, Idx, Col, LVI, TextBuf, BufSize );
until Integer({$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}
( PKOLChar( TextBuf ) )) < BufSize - 1;
Result := TextBuf;
FreeMem( TextBuf );
end;
//*
//[procedure TControl.LVSetItemText]
procedure TControl.LVSetItemText(Idx, Col: Integer; const Value: KOLString);
var LVI: TLVItem;
begin
LVI.iSubItem := Col;
LVI.pszText := PKOL_Char( Value );
Perform( LVM_SETITEMTEXT, Idx, Integer( @LVI ) );
end;
//[procedure TControl.LVColDelete]
procedure TControl.LVColDelete(ColIdx: Integer);
begin
Perform( LVM_DELETECOLUMN, ColIdx, 0 );
if fLVColCount > 0 then
Dec( fLVColCount );
end;
//[procedure TControl.SetLVOptions]
procedure TControl.SetLVOptions(const Value: TListViewOptions);
begin
if fLVOptions = Value then Exit;
fLVOptions := Value;
ApplyImageLists2ListView( @Self );
PostMessage( fHandle, WM_SIZE, 0, 0 ); // to restore scrollers (otherwise its are lost)
end;
//[procedure TControl.SetLVStyle]
procedure TControl.SetLVStyle(const Value: TListViewStyle);
begin
if fLVStyle = Value then Exit;
fLVStyle := Value;
ApplyImageLists2ListView( @Self );
end;
//[function TControl.Perform]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.Perform(msgcode: DWORD; wParam, lParam: Integer): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
{$IFDEF INPACKAGE}
Log( '->TControl.Perform' );
TRY
{$ENDIF INPACKAGE}
Result := SendMessage( GetWindowHandle, msgcode, wParam, lParam );
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-TControl.Perform' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF ASM_VERSION}
//[function TControl.Postmsg]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.Postmsg(msgcode: DWORD; wParam, lParam: Integer): Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
Result := PostMessage( GetWindowHandle, msgcode, wParam, lParam );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
//[function TControl.GetChildCount]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetChildCount: Integer;
begin
Result := fChildren.fCount;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
//[procedure TControl.LVDelete]
procedure TControl.LVDelete(Idx: Integer);
begin
Perform( LVM_DELETEITEM, Idx, 0 );
end;
//[procedure TControl.LVEditItemLabel]
procedure TControl.LVEditItemLabel(Idx: Integer);
begin
Perform( LVM_EDITLABEL, Idx, 0 );
end;
//*
//[function TControl.LVItemRect]
function TControl.LVItemRect(Idx: Integer; Part: TGetLVItemPart): TRect;
const Parts: array[ TGetLVItemPart ] of Byte = (
LVIR_BOUNDS, LVIR_ICON, LVIR_LABEL, LVIR_SELECTBOUNDS );
begin
Result := MakeRect( Parts[ Part ], 0, 0, 0 );
if Perform( LVM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then
begin
//ShowMessage( SysErrorMessage( GetLastError ) );
Result := MakeRect( 0, 0, 0, 0 );
end;
end;
//[function TControl.LVSubItemRect]
function TControl.LVSubItemRect(Idx, ColIdx: Integer): TRect;
var Hdr: HWnd;
R, R1: TRect;
ClassNameBuf: array[ 0..31 ] of KOLChar;
HdItem: THDItem;
begin
Result.Top := ColIdx; // + 1; error in MSDN ?
Result.Left := LVIR_BOUNDS;
if Perform( LVM_GETSUBITEMRECT, Idx, Integer( @Result ) ) <> 0 then
Exit;
Result := MakeRect( 0, 0, 0, 0 );
if ColIdx > 0 then R := LVSubItemRect( Idx, ColIdx - 1 )
else R := LVItemRect( Idx, lvipBounds );
if (R.Left = 0) and (R.Right = 0) and
(R.Top = 0) and (R.Bottom = 0) then Exit;
Hdr := GetWindow( GetWindowHandle, GW_CHILD );
if Hdr <> 0 then
begin
if GetClassName( Hdr, ClassNameBuf, 32 ) > 0 then
if ClassNameBuf = 'SysHeader32' then
begin
if ColIdx > 0 then R.Left := R.Right
else R.Left := 0;
R1.Top := 0; R1.Left := 0;
Windows.ClientToScreen( Hdr,{$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} );
Windows.ScreenToClient( fHandle, {$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} );
R1 := R;
HdItem.Mask := HDI_WIDTH;
if SendMessage( Hdr, HDM_GETITEM, ColIdx, Integer( @HdItem ) ) = 0 then Exit;
R1.Right := R1.Left + HdItem.cxy;
Result := R1;
end;
end;
end;
//*
//[function TControl.LVGetItemPos]
function TControl.LVGetItemPos(Idx: Integer): TPoint;
begin
Perform( LVM_GETITEMPOSITION, Idx, Integer( @Result ) );
end;
//*
//[procedure TControl.LVSetItemPos]
procedure TControl.LVSetItemPos(Idx: Integer; const Value: TPoint);
begin
Perform( LVM_SETITEMPOSITION32, Idx, Integer( @Value ) );
end;
//*
//[function TControl.LVItemAtPos]
function TControl.LVItemAtPos(X, Y: Integer): Integer;
var Dummy: TWherePosLVItem;
begin
Result := LVItemAtPosEx( X, Y, Dummy );
end;
//*
//[function TControl.LVItemAtPosEx]
function TControl.LVItemAtPosEx(X, Y: Integer;
var Where: TWherePosLVItem): Integer;
var HTI: TLVHitTestInfo;
begin
HTI.pt.x := X;
HTI.pt.y := Y;
Perform( LVM_HITTEST, 0, Integer( @HTI ) );
Result := HTI.iItem;
Where := lvwpOnColumn;
if HTI.flags = LVHT_ONITEMICON then
Where := lvwpOnIcon
else
if HTI.flags = LVHT_ONITEMLABEL then
Where := lvwpOnLabel
else
if HTI.flags = LVHT_ONITEMSTATEICON then
Where := lvwpOnStateIcon
else
if HTI.flags = LVHT_ONITEM then
Where := lvwpOnItem;
end;
//[procedure TControl.LVMakeVisible]
procedure TControl.LVMakeVisible(Item: Integer; PartiallyOK: Boolean);
begin
if Item < 0 then Exit;
Perform( LVM_ENSUREVISIBLE, Item, Integer( PartiallyOK ) );
end;
//*
//[procedure TControl.LVSetColorByIdx]
procedure TControl.LVSetColorByIdx(const Index: Integer;
const Value: TColor);
var MsgCode: Integer;
ColorValue: TColor;
begin
MsgCode := Index + 1;
case MsgCode of
LVM_SETTEXTCOLOR: fTextColor := Value;
LVM_SETTEXTBKCOLOR: fLVTextBkColor := Value;
LVM_SETBKCOLOR: fColor := Value;
end;
ColorValue := Color2RGB( Value );
Perform( MsgCode, 0, ColorValue );
end;
{$IFDEF F_P}
//[function TControl.LVGetColorByIdx]
function TControl.LVGetColorByIdx(const Index: Integer): TColor;
begin
CASE Index OF
LVM_SETTEXTCOLOR: Result := fTextColor;
LVM_SETTEXTBKCOLOR: Result := fLVTextBkColor;
LVM_SETBKCOLOR: Result := fColor;
END;
end;
{$ENDIF F_P}
//*
//[function TControl.GetIntVal]
function TControl.GetIntVal(const Index: Integer): Integer;
begin
Result := GetItemVal( 0, Index );
end;
//*
//[procedure TControl.SetIntVal]
procedure TControl.SetIntVal(const Index, Value: Integer);
begin
SetItemVal( Value, Index, 0 );
end;
//*
//[function TControl.GetItemVal]
function TControl.GetItemVal(Item: Integer; const Index: Integer): Integer;
begin
Result := Perform( LoWord(Index), Item, 0 );
end;
//[procedure TControl.SetItemVal]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetItemVal(Item: Integer; const Index: Integer; const Value: Integer);
var MsgCode: Integer;
begin
MsgCode := HiWord( Index );
if MsgCode = 0 then
MsgCode := Index + 1;
Perform( MsgCode and $7FFF, Item, Value );
if (MsgCode and $8000) <> 0 then
Invalidate;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.GetSBMinMax]
function TControl.GetSBMinMax: TPoint;
{$IFDEF _D2}
var X, Y: Integer;
{$ENDIF}
begin
if (Handle <> 0) then begin
{$IFDEF _D2}
GetScrollRange(Handle, SB_CTL, X, Y);
Result.X := X;
Result.Y := Y;
{$ELSE}
GetScrollRange(Handle, SB_CTL, Result.X, Result.Y);
{$ENDIF}
Dec(Result.Y, SBPageSize - 1);
end
else
Result := fSBMinMax;
end;
//[procedure TControl.GetSBPageSize]
function TControl.GetSBPageSize: Integer;
var
SI: TScrollInfo;
begin
FillChar(SI, SizeOf(SI), #0);
SI.cbSize := SizeOf(SI);
SI.fMask := SIF_PAGE;
SBGetScrollInfo(SI);
Result := SI.nPage;
end;
//[procedure TControl.GetSBPosition]
function TControl.GetSBPosition: Integer;
begin
Result := GetScrollPos(Handle, SB_CTL);
end;
//[procedure TControl.SetSBMax]
procedure TControl.SetSBMax(Value: Longint);
var
P: TPoint;
begin
fSBMinMax.Y := Value;
if (Handle <> 0) then begin
P := SBMinMax;
P.Y := Value;
SBMinMax := P;
end;
end;
//[procedure TControl.SetSBMin]
procedure TControl.SetSBMin(Value: Longint);
var
P: TPoint;
begin
fSBMinMax.X := Value;
if (Handle <> 0) then begin
P := SBMinMax;
P.X := Value;
SBMinMax := P;
end;
end;
//[procedure TControl.SetSBPageSize]
procedure TControl.SetSBPageSize(Value: Integer);
var
SI: TScrollInfo;
begin
fSBPageSize := Value;
if (Handle <> 0) then begin
FillChar(SI, SizeOf(SI), #0);
SI.cbSize := SizeOf(SI);
SI.fMask := SIF_PAGE or SIF_RANGE;
SBGetScrollInfo(SI);
if (SI.nMax = 0) and (SI.nMin = 0) then
SI.nMax := 1;
SI.nMax := SI.nMax - Integer(SI.nPage) + Value;
SI.nPage := Value;
SBSetScrollInfo(SI);
end;
end;
//[procedure TControl.SetSBPosition]
procedure TControl.SetSBPosition(Value: Integer);
begin
fSBPosition := Value;
if (Handle <> 0) then
SetScrollPos(Handle, SB_CTL, Value, True);
end;
//[procedure TControl.SetSBMinMax]
procedure TControl.SetSBMinMax(const Value: TPoint);
begin
GetSBMinMax;
if (Handle <> 0) then
SetScrollRange(Handle, SB_CTL, Value.X, Value.Y + SBPageSize - 1, True)
else
fSBMinMax := Value;
end;
//[procedure TControl.SBSetScrollInfo]
function TControl.SBSetScrollInfo(const SI: TScrollInfo): Integer;
begin
Result := SetScrollInfo(Handle, SB_CTL, SI, True)
end;
//[procedure TControl.SBGetScrollInfo]
function TControl.SBGetScrollInfo(var SI: TScrollInfo): Boolean;
begin
Result := Cardinal(GetScrollInfo(Handle, SB_CTL, SI)) <> 0;
end;
{ -- OpenSaveDialog -- }
//*
//[function NewOpenSaveDialog]
function NewOpenSaveDialog( const Title, StrtDir: KOLString;
Options: TOpenSaveOptions ): POpenSaveDialog;
begin
{-}
New( Result, Create );
{+}{++}(*Result := POpenSaveDialog.Create;*){--}
Result.FOptions := Options;
if Options = [] then
Result.FOptions := DefOpenSaveDlgOptions;
Result.fOpenDialog := True;
Result.FTitle := Title;
Result.FInitialDir := StrtDir;
end;
//[END NewOpenSaveDialog]
{ TOpenSaveDialog }
//[destructor TOpenSaveDialog.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TOpenSaveDialog.Destroy;
begin
FFilter := '';
FInitialDir := '';
FDefExtension := '';
FFileName := '';
FTitle := '';
{$IFDEF OpenSaveDialog_Extended}
TemplateName := '';
{$ENDIF}
inherited;
end;
{$ENDIF ASM_VERSION}
//[function TOpenSaveDialog.Execute]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TOpenSaveDialog.Execute: Boolean;
const OpenSaveFlags: array[ TOpenSaveOption ] of Integer = (
OFN_CREATEPROMPT,
OFN_EXTENSIONDIFFERENT,
OFN_FILEMUSTEXIST,
OFN_HIDEREADONLY,
OFN_NOCHANGEDIR,
OFN_NODEREFERENCELINKS,
OFN_ALLOWMULTISELECT,
OFN_NONETWORKBUTTON,
OFN_NOREADONLYRETURN,
OFN_OVERWRITEPROMPT,
OFN_PATHMUSTEXIST,
OFN_READONLY,
OFN_NOVALIDATE
//{$IFDEF OpenSaveDialog_Extended}
,
OFN_ENABLETEMPLATE,
OFN_ENABLEHOOK
//{$ENDIF}
);
var
Ofn : TOpenFilename;
Fltr : KOLString;
TempFilename : KOLString;
Function MakeFilter(s : string) : String;
{
format of filter for API call is following:
'text files'#0'*.txt'#0
'bitmap files'#0'*.bmp'#0#0
}
var Str: PChar;
begin
Result := s;
if Result='' then
exit;
Result:=Result+#0; {Delphi string always end on #0 is this is #0#0}
Str := PChar( Result );
while Str^ <> #0 do
begin
if Str^ = '|' then
Str^ := #0;
Inc( Str );
end;
end;
var m: Integer;
begin
Fillchar( ofn, sizeof( ofn ), 0 );
{$ifdef wince}
ofn.lStructSize := Sizeof( ofn );
{$else}
{$IFDEF OpenSaveDialog_Extended}
if (WinVer <= wvNT) and (WinVer <> wvME) then
ofn.lStructSize := 76
else
begin
ofn.lStructSize := Sizeof( ofn );
ofn.FlagsEx := Integer( NoPlaceBar );
end;
{$ELSE}
ofn.lStructSize:= 76; //to provide correct work in Win9x
{$ENDIF}
{$endif wince}
if fWnd <> 0 then
ofn.hWndOwner := fWnd
else
if assigned(applet) then
ofn.hwndOwner:=applet.Handle;
ofn.hInstance:=HInstance;
Fltr:=MakeFilter(FFilter);
if Fltr <> '' then
ofn.lpstrFilter := PKOLchar(Fltr);
ofn.nFilterIndex := FFilterIndex;
if OSAllowMultiSelect in FOptions then
ofn.nMaxFile := High(word)-14 // by V.K. (exchanged condition)
else
ofn.nMaxFile := MAX_PATH+2;
SetLength( TempFileName, ofn.nMaxFile );
FillChar( TempFileName[ 1 ], ofn.nMaxFile * sizeof( KOLChar ), 0 );
m := Min( ofn.nMaxFile, Length(fFileName) );
{$IFDEF UNICODE_CTRLS}
ofn.lpstrFile := PKOLchar( TempFileName );
WStrLCopy(PWideChar(TempFileName), PWideChar(fFileName), m );
{$ELSE}
ofn.lpstrFile := StrLCopy(PKOLChar(TempFileName), PKOLchar(fFileName), m );
{$ENDIF}
ofn.lpstrInitialDir:=PKOLChar(FInitialDir);
ofn.lpstrTitle := PKOLChar(FTitle);
ofn.Flags := MakeFlags( @FOptions, OpenSaveFlags )
or OFN_EXPLORER or OFN_LONGNAMES{$ifdef win32} or OFN_ENABLESIZING{$endif};
ofn.lpstrDefExt := PKOLChar(FDefExtension);
ofn.lCustData := integer(@self);
{$ifdef win32}
{$IFDEF OpenSaveDialog_Extended}
ofn.lpTemplateName := PKOLChar( TemplateName );
ofn.lpfnHook := HookProc;
{$ELSE}
ofn.lpTemplateName := nil;
ofn.lpfnHook := nil;
{$ENDIF}
{$endif win32}
if fOpenDialog then
result := GetOpenFileName(POpenFileName( @ofn )^)
else
result := GetSaveFileName(POpenFileName( @ofn )^);
if result then begin
fFilterIndex := ofn.nFilterIndex; // by Vadim
fOpenReadOnly := OFN_READONLY and ofn.Flags <> 0; // by ECM (in my redaction)
if OSAllowMultiSelect in foptions then begin
FFileName := copy(TempFileName, 1, pos(#0#0, tempfilename)-1);
while pos(#0, ffilename) > 0 do begin
FFilename[pos(#0, ffilename)]:=#13;
end;
end else
FFileName := copy(tempFileName, 1, pos(#0, TempFilename)
-1 // by X.Y.B.
);
end else
FFilename:='';
end;
{$ENDIF ASM_VERSION}
{$ifdef wince}
{$define read_implementation}
{$I KOLCEOpenDir.inc}
{$undef read_implementation}
{$else}
{ -- OpenDirDialog -- }
//*
//[function NewOpenDirDialog]
function NewOpenDirDialog( const Title: KOLString; Options: TOpenDirOptions ):
POpenDirDialog;
begin
{-}
New( Result, Create );
{+}{++}(*Result := POpenDirDialog.Create;*){--}
Result.FOptions := [ odOnlySystemDirs ];
if Options <> [] then
Result.FOptions := Options;
Result.FTitle := Title;
end;
//[END NewOpenDirDialog]
{ TOpenDirDialog }
//[destructor TOpenDirDialog.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TOpenDirDialog.Destroy;
begin
FTitle := '';
FInitialPath := '';
FStatusText := '';
inherited;
end;
{$ENDIF ASM_VERSION}
{$ifdef win32}
type
PSHItemID = ^TSHItemID;
TSHItemID = {$ifndef wince}packed{$endif} record
cb: Word; { Size of the ID (including cb itself) }
abID: array[0..0] of Byte; { The item ID (variable length) }
end;
PItemIDList = ^TItemIDList;
TItemIDList = record
mkid: TSHItemID;
end;
PBrowseInfo = ^TBrowseInfo;
TBrowseInfoA = record
hwndOwner: HWND;
pidlRoot: PItemIDList;
pszDisplayName: PChar; { Return display name of item selected. }
lpszTitle: PChar; { text to go in the banner over the tree. }
ulFlags: UINT; { Flags that control the return stuff }
lpfn: Pointer; //TFNBFFCallBack;
lParam: LPARAM; { extra info that's passed back in callbacks }
iImage: Integer; { output var: where to return the Image index. }
end;
TBrowseInfoW = record
hwndOwner: HWND;
pidlRoot: PItemIDList;
pszDisplayName: PWideChar; { Return display name of item selected. }
lpszTitle: PWideChar; { text to go in the banner over the tree. }
ulFlags: UINT; { Flags that control the return stuff }
lpfn: Pointer; //TFNBFFCallBack;
lParam: LPARAM; { extra info that's passed back in callbacks }
iImage: Integer; { output var: where to return the Image index. }
end;
TBrowseInfo = {$IFDEF UNICODE_CTRLS} TBrowseInfoW {$ELSE} TBrowseInfoA {$ENDIF};
//[API SHXXXXXXXXXX]
function SHBrowseForFolderA(var lpbi: TBrowseInfoA): PItemIDList; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'SHBrowseForFolderA';
{$IFDEF UNICODE_CTRLS}
function SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'SHBrowseForFolderW';
{$ENDIF UNICODE_CTRLS}
function SHGetPathFromIDListA(pidl: PItemIDList; pszPath: PChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'SHGetPathFromIDListA';
{$IFDEF UNICODE_CTRLS}
function SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PKOLChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'shell32.dll' name 'SHGetPathFromIDListW';
{$ENDIF UNICODE_CTRLS}
procedure CoTaskMemFree(pv: Pointer); {$ifdef wince}cdecl{$else}stdcall{$endif}; external 'ole32.dll'
name 'CoTaskMemFree';
const
BIF_RETURNONLYFSDIRS = $0001; { For finding a folder to start document searching }
BIF_DONTGOBELOWDOMAIN = $0002; { For starting the Find Computer }
BIF_STATUSTEXT = $0004;
BIF_RETURNFSANCESTORS = $0008;
BIF_EDITBOX = $0010;
BIF_VALIDATE = $0020; { insist on valid result (or CANCEL) }
BIF_NEWDIALOGSTYLE = $0040; { Use the new dialog layout with the ability to resize }
{ Caller needs to call OleInitialize() before using this API (c) JVCL }
BIF_BROWSEFORCOMPUTER = $1000; { Browsing for Computers. }
BIF_BROWSEFORPRINTER = $2000; { Browsing for Printers }
BIF_BROWSEINCLUDEFILES = $4000; { Browsing for Everything }
BFFM_INITIALIZED = 1;
BFFM_SELCHANGED = 2;
BFFM_SETSTATUSTEXT = WM_USER + 100;
BFFM_ENABLEOK = WM_USER + 101;
BFFM_SETSELECTION = WM_USER + 102;
{$endif win32}
{$IFDEF ASM_UNICODE} // WndOwner
//[function TOpenDirDialog.Execute]
function TOpenDirDialog.Execute: Boolean;
asm
PUSH EBX
XCHG EBX, EAX
XOR ECX, ECX
PUSH ECX // prepare iImage = 0
PUSH EBX // prepare lParam = @Self
PUSH [EBX].FCallBack // prepare lpfn = FCallBack
LEA EAX, [EBX].FOptions
MOV EDX, Offset[@@FlagsArray]
MOV CL, 8
CALL MakeFlags
PUSH EAX // prepare ulFlags = Options
PUSH [EBX].FTitle // prepare lpszTitle
LEA EAX, [EBX].FBuf
PUSH EAX // prepare pszDisplayName
PUSH 0 // prepare pidlRoot
MOV ECX, [EBX].fWnd
INC ECX
LOOP @@1
MOV ECX, Applet
JECXZ @@1
MOV ECX, [ECX].TControl.fHandle
@@1: PUSH ECX // prepare hwndOwner
PUSH ESP
CALL SHBrowseForFolderA
ADD ESP, 32
TEST EAX, EAX
JZ @@exit
PUSH EAX
LEA EDX, [EBX].FBuf
PUSH EDX
PUSH EAX
CALL SHGetPathFromIDListA
CALL CoTaskMemFree
MOV AL, 1
JMP @@fin
@@FlagsArray:
DD BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN
DD BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT
DD BIF_BROWSEINCLUDEFILES, BIF_EDITBOX, BIF_NEWDIALOGSTYLE
@@exit: XOR EAX, EAX
@@fin:
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TOpenDirDialog.Execute: Boolean;
const FlagsArray: array[ TOpenDirOption ] of Integer =
( BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN,
BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT,
BIF_BROWSEINCLUDEFILES, BIF_EDITBOX, BIF_NEWDIALOGSTYLE );
var BI : TBrowseInfo;
Browse : PItemIdList;
begin
Result := False;
if WndOwner <> 0 then
BI.hwndOwner := WndOwner
else
if assigned( Applet ) then
BI.hwndOwner := Applet.Handle
else
BI.hwndOwner := 0;
BI.pidlRoot := nil;
BI.pszDisplayName := @FBuf[ 0 ];
BI.lpszTitle := PKOLChar( Title );
BI.ulFlags := MakeFlags( @FOptions, FlagsArray );
BI.lpfn := FCallBack;
BI.lParam := Integer( @Self );
Browse := {$IFDEF UNICODE_CTRLS} SHBrowseForFolderW {$ELSE} SHBrowseForFolderA {$ENDIF}
( BI );
if Browse <> nil then
begin
{$IFDEF UNICODE_CTRLS}SHGetPathFromIDListW{$ELSE} SHGetPathFromIDListA{$ENDIF}( Browse, @FBuf[ 0 ] );
CoTaskMemFree( Browse );
Result := True;
end;
end;
{$ENDIF ASM_VERSION}
//[function TOpenDirDialog.GetInitialPath]
function TOpenDirDialog.GetInitialPath: KOLString;
begin
Result := IncludeTrailingPathDelimiter( fInitialPath );
end;
//[function TOpenDirDialog.GetPath]
function TOpenDirDialog.GetPath: KOLString;
begin
Result := FBuf;
end;
//[FUNCTION OpenDirSelChangeCallBack]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ):
Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
var _Self_: POpenDirDialog;
EnableOK: Integer;
begin
_Self_ := Pointer( lpData );
if assigned( _Self_.FOnSelChanged ) then
begin
{$IFDEF UNICODE_CTRLS} SHGetPathFromIDListW {$ELSE} SHGetPathFromIDListA {$ENDIF}( PItemIDList( lParam ), @ _Self_.FBuf[ 0 ] );
EnableOK := 0;
_Self_.FOnSelChanged( _Self_, _Self_.FBuf, EnableOK,
KOL_String( KOLString( _Self_.FStatusText ) ) );
SendMessage( Wnd, BFFM_ENABLEOK, 0, EnableOK );
if _Self_.FStatusText <> '' then
SendMessage( Wnd, BFFM_SETSTATUSTEXT, 0, Integer( PKOLChar( _Self_.FStatusText ) ) );
end;
Result := 0;
end;
{$ENDIF ASM_VERSION}
//[END OpenDirSelChangeCallBack]
{$IFDEF ASM_LOCAL} {$UNDEF ASM_LOCAL} {$ENDIF}
{$IFNDEF NEW_OPEN_DIR_STYLE_EX}
{$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
{$ENDIF}
//[FUNCTION OpenDirCallBack]
{$IFDEF ASM_LOCAL}
{$ELSE ASM_VERSION} //Pascal
function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif};
{$IFDEF NEW_OPEN_DIR_STYLE_EX}
const
Shel: array[ 0..3 ] of Char = 'SHBr';
{$ENDIF}
var Self_ : POpenDirDialog;
{$IFDEF NEW_OPEN_DIR_STYLE_EX}
WList: HWnd;
ClassBuf: array[ 0..127 ] of KOLChar;
{$ENDIF}
begin
Self_ := Pointer( lpData );
Self_.FDialogWnd := Wnd;
if Msg = BFFM_INITIALIZED then
begin
if assigned( Self_.FCenterProc ) then
Self_.FCenterProc( Wnd );
if Self_.FInitialPath <> '' then
begin
{$IFDEF NEW_OPEN_DIR_STYLE_EX}
WList := GetWindow( Wnd, GW_CHILD );
while WList <> 0 do
begin
WList := GetWindow( WList, GW_HWNDNEXT );
GetClassName( WList, @ ClassBuf[ 0 ], Sizeof( ClassBuf ) );
if PDWord( @ ClassBuf[ 0 ] )^ = DWORD( Shel ) then
begin
PostMessage( Wnd, WM_NEXTDLGCTL, WList, 1 );
break;
end;
end;
PostMessage( Wnd, BFFM_SETSELECTION, 1, Integer( PChar(
ExtractFilePath( Self_.FInitialPath ) ) ) );
PostMessage( WND, WM_KEYDOWN, VK_ADD, 0 );
PostMessage( WND, WM_KEYUP, VK_ADD, 0 );
PostMessage( Wnd, BFFM_SETSELECTION, 1, Integer( PKOLChar( Self_.FInitialPath ) ) );
{$ELSE}
SendMessage( Wnd, BFFM_SETSELECTION, 1, Integer( PKOLChar( Self_.FInitialPath ) ) );
{$ENDIF}
SendMessage( Wnd, BFFM_ENABLEOK, 0, 1 );
end;
end
else
if Msg = BFFM_SELCHANGED then
begin
if assigned( Self_.FDoSelChanged ) then
Self_.FDoSelChanged( Wnd, Msg, lParam, lpData )
else
SendMessage( Wnd, BFFM_ENABLEOK, 0, 1 );
end;
Result := 0;
end;
{$ENDIF ASM_VERSION}
//[END OpenDirCallBack]
//[PROCEDURE OpenDirDlgCenter]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure OpenDirDlgCenter( Wnd: HWnd );
var R: TRect;
W, H: Integer;
begin
GetWindowRect( Wnd, R );
W := R.Right - R.Left;
H := R.Bottom - R.Top;
R.Left := (GetSystemMetrics( SM_CXSCREEN ) - W) div 2;
R.Top := (GetSystemMetrics( SM_CYSCREEN ) - H) div 2;
MoveWindow( Wnd, R.Left, R.Top, W, H, True );
end;
{$ENDIF ASM_VERSION}
//[END OpenDirDlgCenter]
//[procedure TOpenDirDialog.SetCenterOnScreen]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TOpenDirDialog.SetCenterOnScreen(const Value: Boolean);
var P: procedure( Wnd: HWnd );
begin
FCenterOnScreen := Value;
P := nil;
if Value then
P := @OpenDirDlgCenter;
FCenterProc := P;
end;
{$ENDIF ASM_VERSION}
//[procedure TOpenDirDialog.SetInitialPath]
procedure TOpenDirDialog.SetInitialPath(const Value: KOLString);
begin
FCallBack := @OpenDirCallBack;
FInitialPath := ExcludeTrailingPathDelimiter( Value );
if (FInitialPath <> '') and
(FInitialPath[ Length( FInitialPath ) ] = ':') then
FInitialPath := IncludeTrailingPathDelimiter( Value );
end;
//[procedure TOpenDirDialog.SetOnSelChanged]
procedure TOpenDirDialog.SetOnSelChanged(const Value: TOnODSelChange);
begin
FOnSelChanged := Value;
FCallBack := @OpenDirCallBack;
FDoSelChanged := @OpenDirSelChangeCallBack;
end;
{$endif wince}
type
PByteArray =^TByteArray;
TByteArray = array[Word]of Byte;
//[function CreateMappedBitmapEx]
function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PKOLChar; Flags:
Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap;
var tmcl: Cardinal;
{$ifndef wince}
bi: TBITMAPINFO;
DC: Cardinal;
{$endif}
Bits: PByteArray;
i, j, k, CO, bps: Integer;
tm: array [1..4] of byte absolute tmcl;
bm: Windows.TBITMAP;
CM: PColorMap;
{$ifdef wince}
tbmp, tbmp2: PBitmap;
{$else}
DW: HWnd;
{$endif wince}
begin
Result := LoadBitmap( Instance, BmpRsrcName );
if Result = 0 then
begin
{$IFDEF DEBUG}
ShowMessage( 'Can not load bitmap ' + BmpRsrcName + ', error ' +
Int2Str( GetLastError ) + ': ' + SysErrorMessage( GetLastError ) );
{$ENDIF}
Exit;
end;
FillChar( bm, SizeOf(bm), #0 );
GetObject( Result, SizeOf( bm ), @bm );
{$ifdef wince}
tbmp:=NewDIBBitmap(bm.bmWidth, bm.bmHeight, pf24bit);
tbmp2:=NewBitmap(0, 0);
tbmp2.Handle:=Result;
tbmp2.Draw(tbmp.Canvas.Handle, 0, 0);
tbmp.RemoveCanvas;
Bits:=tbmp.DIBBits;
bps := CalcScanLineSize( @tbmp.DibHeader.bmiHeader );
CM:=ColorMap;
for k := 1 to NumMaps do begin
tbmp2.Pixels[0, 0]:=Color2RGB(CM.{$ifdef wince}from{$else}cFrom{$endif});
CM.{$ifdef wince}from{$else}cFrom{$endif}:=tbmp2.Pixels[0, 0];
CM.{$ifdef wince}_to{$else}cTo{$endif}:=Color2RGB(CM.{$ifdef wince}_to{$else}cTo{$endif});
Inc(CM);
end;
tbmp2.Free;
{$else}
FillChar( bi, SizeOf( bi ), #0 );
bi.bmiHeader.biSize := SizeOf( bi.bmiHeader );
bi.bmiHeader.biWidth := bm.bmWidth;
bi.bmiHeader.biHeight := -bm.bmHeight;
bi.bmiHeader.biPlanes := 1;
bi.bmiHeader.biBitCount := 24;
// BitCout - always 24 for easy algorythm
bi.bmiHeader.biCompression:=BI_RGB;
bps := CalcScanLineSize( @bi.bmiHeader );
GetMem( Bits, bps * bm.bmHeight );
DW := GetDesktopWindow;
DC := GetDC(DW);
GetDIBits( DC, Result, 0, bm.bmHeight, @Bits[0], bi, DIB_RGB_COLORS );
DeleteObject( Result );
{$endif wince}
for i := 0 to bm.bmHeight - 1 do begin
for j := 0 to bm.bmWidth - 1 do begin
CO := bps * i + 3 * j;
for k := 0 to NumMaps - 1 do begin
CM := Pointer( cardinal( ColorMap ) + SizeOf( TColorMap ) * cardinal(k) );
if RGB( Bits[CO+2], Bits[CO+1], Bits[CO] ) = CM.{$ifdef wince}from{$else}cFrom{$endif} then
begin
tmcl := CM.{$ifdef wince}_to{$else}cTo{$endif};
tm[4]:=tm[1];
tm[1]:=tm[3];
tm[3]:=tm[4];
Move( tmcl, Bits[CO], 3);
end;
end;
end;
end;
{$ifdef wince}
Result:=tbmp.ReleaseHandle;
tbmp.Free;
{$else}
Result := CreateDIBitmap( DC, bi.bmiHeader, CBM_INIT, @Bits[0], bi,
DIB_RGB_COLORS );
ReleaseDC( DW, DC );
FreeMem( Bits );
{$endif wince}
end;
{$ifdef wince}
function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;
Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
Result:=CreateMappedBitmapEx(Instance, PKOLChar(Bitmap), Flags, ColorMap, NumMaps);
end;
{$else}
//[API CreateMappedBitmap]
function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;
Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; {$ifdef wince}cdecl{$else}stdcall{$endif};
external cctrl name 'CreateMappedBitmap';
{$endif wince}
//*
//[function LoadMappedBitmap]
function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor )
: HBitmap;
var Map2Pass: Pointer;
begin
Map2Pass := nil;
if High( Map ) > 0 then
Map2Pass := PColorMap( @Map[ 0 ] );
Result := CreateMappedBitmap( hInst, BmpResID, 0, Map2Pass, (High( Map ) + 1) div 2 );
end;
//[function LoadMappedBitmapEx]
function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PKOLChar; const Map: array of TColor )
: HBitmap;
var Map2Pass: Pointer;
begin
Map2Pass := nil;
if High( Map ) > 0 then
Map2Pass := PColorMap( @Map[ 0 ] );
Result := CreateMappedBitmapEx( hInst, BmpResName, 0, Map2Pass, (High( Map ) + 1) div 2 );
if MasterObj <> nil then
MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) );
end;
{ -- Toolbar -- }
{$IFDEF ASM_noVERSION} // width
//[procedure TControl.TBAddBitmap]
procedure TControl.TBAddBitmap(Bitmap: HBitmap);
const szBI = sizeof(TBitmapInfo);
asm
TEST EDX, EDX
JZ @@exit
JGE @@1
CMP EDX, -6
JL @@1
NEG EDX
DEC EDX
PUSH EDX
PUSH -1
XOR EDX, EDX
JMP @@2
@@1: PUSH EDX // AB.hInst = Bitmap
PUSH 0 // AB.nID = 0
PUSH EAX // > @Self
ADD ESP, -szBI
PUSH ESP
PUSH szBI
PUSH EDX
CALL GetObject
TEST EAX, EAX
JG @@11
ADD ESP, szBI
JMP @@exit
@@11: MOV EAX, [ESP].TBitmapInfo.bmiHeader.biWidth
MOV ECX, [ESP].TBitmapInfo.bmiHeader.biHeight
TEST ECX, ECX
JGE @@12
NEG ECX
@@12: ADD ESP, szBI
CDQ // EDX = 0
DIV ECX // EAX = N
XCHG EAX, [ESP] // > N
PUSH EAX // > @Self
MOV EDX, ECX
SHL EDX, 16
OR ECX, EDX
CDQ
PUSH EDX
PUSH EDX
PUSH TB_AUTOSIZE
PUSH EAX
PUSH ECX
PUSH EDX
PUSH TB_SETBITMAPSIZE
PUSH EAX
CALL Perform
CALL Perform
POP EAX
POP EDX
@@2: PUSH ESP
PUSH EDX
PUSH TB_ADDBITMAP
PUSH EAX
CALL Perform
POP ECX
POP ECX
@@exit:
end;
{$ELSE ASM_VERSION} //Pascal
procedure TControl.TBAddBitmap(Bitmap: HBitmap);
//const NstdBitmaps: array[ 0..5 ] of DWORD = ( 15, 15, 0, 0, 13, 13 );
var BI: TBitmapInfo;
AB: TTBAddBitmap;
N, W: Integer;
begin
if Bitmap = 0 then Exit;
if (Integer( Bitmap ) >= -10) and (Integer( Bitmap ) <= -1) then
begin
AB.hInst := THandle(-1);
AB.nID := -Integer(Bitmap) - 1;
N := 0; //NstdBitmaps[ AB.nID ]; // (this value is ignored)
end
else
if GetObject( Bitmap, sizeof( TBitmapInfo ), @BI ) > 0 then
begin
AB.hInst := 0;
AB.nID := Bitmap;
W := fTBBtnImgWidth;
if W = 0 then
W := Abs( BI.bmiHeader.biHeight );
N := BI.bmiHeader.biWidth div W;
Perform( TB_SETBITMAPSIZE, 0, MAKELONG( W, Abs(BI.bmiHeader.biHeight )) );
Perform( TB_AUTOSIZE, 0, 0 );
end
else Exit;
Perform( TB_ADDBITMAP, N, Integer( @AB ) );
end;
{$ENDIF ASM_VERSION}
//[function TControl.TBAddInsButtons]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TControl.TBAddInsButtons(Idx: Integer; const Buttons: array of PKOLChar;
const BtnImgIdxArray: array of Integer): Integer;
function AddInsButtons: Integer;
type TTBBtnArray = array[ 0..100000 ] of TTBButton;
PTBBtnArray = ^TTBBtnArray;
var AB: PTBBtnArray;
I, N, nBmp: Integer;
PAB: PTBButton;
Str: PKOLChar;
begin
Result := -1;
AB := nil;
if High( Buttons ) >= 0 then
GetMem( AB, Sizeof( TTBButton ) * (High(Buttons) + 1) );
N := 0;
PAB := @AB[ 0 ];
nBmp := -2;
if High(BtnImgIdxArray) >= 0 then
nBmp := BtnImgIdxArray[ 0 ] - 1;
for I:= 0 to High( Buttons ) do
begin
if Buttons[ I ] = nil then break;
if {$IFDEF UNICODE_CTRLS} WStrComp {$ELSE} StrComp {$ENDIF}
( Buttons[ I ], {$IFDEF F_P}''+{$ENDIF} '-' ) = 0 then
begin
PAB.iBitmap := -1;
//PAB.idCommand := 0;
PAB.fsState := 0;
PAB.fsStyle := TBSTYLE_SEP;
PAB.iString := -1;
end
else
begin
Str := Buttons[ I ];
Inc( nBmp );
PAB.iBitmap := nBmp;
if nBmp < 0 then
Dec( nBmp );
if High( BtnImgIdxArray ) >= N then
PAB.iBitmap := BtnImgIdxArray[ N ];
PAB.fsState := TBSTATE_ENABLED;
PAB.fsStyle := TBSTYLE_BUTTON or TBSTYLE_AUTOSIZE;
if Str^ = '^' then
begin
PAB.fsStyle := TBSTYLE_DROPDOWN or TBSTYLE_AUTOSIZE;
Inc( Str );
end;
if CharIn( Str^, [ '-', '+' ] ) then
begin
PAB.fsStyle := PAB.fsStyle or TBSTYLE_CHECK;
if Str^ = '+' then
PAB.fsState := PAB.fsState or TBSTATE_CHECKED;
Inc( Str );
if Str^ = '!' then
begin
PAB.fsStyle := PAB.fsStyle or TBSTYLE_GROUP;
Inc( Str );
end;
end;
{$IFDEF TOOLBAR_DOT_NOAUTOSIZE_BUTTON}
if Str^ = '.' then
begin
PAB.fsStyle := PAB.fsStyle and not TBSTYLE_AUTOSIZE;
inc( Str );
end;
{$ENDIF TOOLBAR_DOT_NOAUTOSIZE_BUTTON}
if (Str = KOLString( {$IFDEF F_P}''+{$ENDIF} KOLChar( ' ' ) )) or (Str^ = #0) then
PAB.iString := -1
//Perform( TB_ADDSTRING, 0, Integer( PChar( '' + #0 ) ) )
// an experiment: is it possible to remove space right to image
// without setting tboTextBottom option (non compatible with FixFlatXP)
// answer: seems not possible.
else
PAB.iString :=
Perform( TB_ADDSTRING, 0, Integer( PKOLChar( KOLString( '' + Str + #0 ) ) ) );
end;
PAB.idCommand := ToolbarsIDcmd;
if Result < 0 then Result := PAB.idCommand;
Inc( ToolbarsIDcmd );
PAB.dwData := Integer( @Self );
Inc( N );
Inc( PAB );
end;
if N > 0 then
begin
if Idx < 0 then
Perform( TB_ADDBUTTONS, N, Integer( @AB[ 0 ] ) )
else
Perform( TB_INSERTBUTTON, Idx, Integer( @AB[ 0 ] ) );
end;
if AB <> nil then
FreeMem( AB );
end;
begin
if High( Buttons ) < 0 then
Result := -1
else
Result := AddInsButtons;
end;
{$ENDIF ASM_VERSION}
//[function TControl.TBAddButtons]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.TBAddButtons(const Buttons: array of PKOLChar;
const BtnImgIdxArray: array of Integer): Integer;
begin
Result := TBAddInsButtons( -1, Buttons, BtnImgIdxArray );
end;
{$ENDIF ASM_VERSION}
//*
//[function TControl.TBInsertButtons]
function TControl.TBInsertButtons(BeforeIdx: Integer;
Buttons: array of PKOLChar; BtnImgIdxArray: array of Integer): Integer;
var I, J, K: Integer;
begin
J := -1;
Result := -1;
for I := 0 to High( Buttons ) do
begin
if I <= High( BtnImgIdxArray ) then
J := BtnImgIdxArray[ I ]
else
if J >= 0 then Inc( J );
K := TBAddInsButtons( BeforeIdx, [ Buttons[ I ], '' ], [ J ] );
if Result < 0 then Result := K;
end;
end;
//[function GetTBBtnGoodID]
function GetTBBtnGoodID( Toolbar: PControl; BtnIDorIdx: Integer ): Integer;
// change by Alexander Pravdin (to fix toolbar with separator first):
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
var Btn1st, i: Integer; btn: TTBButton;
begin
Result := BtnIDorIdx;
Btn1st := 0;
for i := 0 to Toolbar.TBButtonCount - 1 do begin
Toolbar.Perform( TB_GETBUTTON, i, Integer( @btn ) );
if btn.fsStyle <> TBSTYLE_SEP then begin
Btn1st := i;
Break;
end;
end;
if Result < Toolbar.TBIndex2Item( Btn1st ) then
Result := Toolbar.TBIndex2Item( Result );
end;
type
TTBButtonEvent = {$ifndef wince}packed{$endif} Record
BtnID: DWORD;
Event: TOnToolbarButtonClick;
end;
PTBButtonEvent = ^TTBButtonEvent;
//[procedure TControl.TBFreeTBevents]
procedure TControl.TBFreeTBevents;
begin
//if fTBevents <> nil then
begin
fTBevents.Release;
//fTBevents := nil;
end;
end;
//[function WndProcToolbarButtonsClicks]
function WndProcToolbarButtonsClicks( TB: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
Event: PTBButtonEvent;
begin
Result := FALSE;
if Msg.message = CM_COMMAND then
begin
for I := TB.fTBevents.fCount-1 downto 0 do
begin
Event := TB.fTBevents.fItems[ I ];
if Integer( Event.BtnID ) = LoWord( Msg.wParam ) then
begin
if Assigned( Event.Event ) then
begin
TB.RefInc;
Rslt := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam );
Event.Event( TB, Event.BtnID );
TB.RefDec;
Result := TRUE;
Exit;
end;
break;
end;
end;
end;
end;
//[procedure TControl.TBAssignEvents]
procedure TControl.TBAssignEvents(BtnID: Integer;
Events: array of TOnToolbarButtonClick);
var I: Integer;
EventRec: PTBButtonEvent;
begin
if fTBevents = nil then
begin
fTBevents := NewList;
Add2AutoFreeEx( TBFreeTBevents );
AttachProc( WndProcToolbarButtonsClicks );
end;
BtnID := GetTBBtnGoodID( @Self, BtnID );
for I := 0 to High( Events ) do
begin
GetMem( EventRec, Sizeof( TTBButtonEvent ) );
fTBevents.Add( EventRec );
EventRec.Event := Events[ I ];
EventRec.BtnID := BtnID;
Inc( BtnID );
end;
end;
//[procedure TControl.TBResetImgIdx]
procedure TControl.TBResetImgIdx( BtnID, BtnCount: Integer );
begin
while BtnCount > 0 do
begin
TBButtonImage[ BtnID ] := -2;
Inc( BtnID );
Dec( BtnCount );
end;
end;
//*
//[function TControl.TBGetButtonVisible]
function TControl.TBGetButtonVisible(BtnID: Integer): Boolean;
begin
Result := Perform( TB_ISBUTTONHIDDEN, GetTBBtnGoodID( @ Self, BtnID ), 0 ) = 0;
end;
//*
//[function TControl.TBItem2Index]
function TControl.TBItem2Index(BtnID: Integer): Integer;
begin
Result := Perform( TB_COMMANDTOINDEX, BtnID, 0 );
end;
//*
//[procedure TControl.TBSetButtonVisible]
procedure TControl.TBSetButtonVisible(BtnID: Integer;
const Value: Boolean);
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
Perform( TB_HIDEBUTTON, BtnID, Integer( not Value ) );
end;
//[function TControl.TBGetBtnStt]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
Result := Perform( Index + 8, BtnID, 0 ) <> 0;
end;
{$ENDIF ASM_VERSION}
//+
//[procedure TControl.TBSetBtnStt]
procedure TControl.TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean);
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
Perform( Index, BtnID, Integer( Value ) );
end;
//[function TControl.TBIndex2Item]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.TBIndex2Item(Idx: Integer): Integer;
var ButtonInfo: TTBButton;
begin
Result := -1;
if Perform( TB_GETBUTTON, Idx, Integer( @ButtonInfo ) ) <> 0 then
Result := ButtonInfo.idCommand;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.TBConvertIdxArray2ID]
procedure TControl.TBConvertIdxArray2ID(const IdxVars: array of PDWORD);
var i: Integer;
begin
for i := 0 to High( IdxVars ) do
IdxVars[ i ]^ := TBIndex2Item( IdxVars[ I ]^ );
end;
//[function TControl.TBGetButtonText]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
function TControl.TBGetButtonText( BtnID: Integer ): KOLString;
var Buffer: array[ 0..1023 ] of KOLChar;
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
if Perform( TB_GETBUTTONTEXT, BtnID, Integer( @Buffer[ 0 ] ) ) > 0 then
Result := Buffer
else
Result := '';
end;
{$ENDIF ASM_VERSION}
//*
//[function TControl.TBGetButtonRect]
function TControl.TBGetButtonRect(BtnID: Integer): TRect;
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
Perform( TB_GETITEMRECT, TBItem2Index( BtnID ), Integer( @Result ) );
end;
function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect;
begin
Result := Toolbar.TBGetButtonRect(BtnID);
end;
//*
//[function TControl.TBGetRows]
function TControl.TBGetRows: Integer;
begin
Result := 1;
UpdateWndStyles;
if (TBSTYLE_WRAPABLE and fStyle) <> 0 then
Result := Perform( TB_GETROWS, 0, 0 );
end;
//*
//[procedure TControl.TBSetRows]
procedure TControl.TBSetRows(const Value: Integer);
begin
Perform( TB_SETROWS, Value, 0 );
end;
//[function TControl.TBMoveBtn]
function TControl.TBMoveBtn(FromIdx, ToIdx: Integer): Boolean;
var btn: TTBButton;
begin
Perform(TB_GETBUTTON,FromIdx,integer(@btn));
Result := Perform(TB_DELETEBUTTON,FromIdx,0) <> 0;
if Result then
Perform(TB_INSERTBUTTON,ToIdx,integer(@btn));
end;
//[procedure TControl.TBSetTooltips]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.TBSetTooltips(BtnID1st: Integer;
const Tooltips: array of PKOLChar);
var I, J: Integer;
begin
if not assigned( fTBttTxt ) then
begin
{$ifndef wince}
fTBttCmd := NewList;
{$endif wince}
fTBttTxt := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
{$IFDEF USE_AUTOFREE4CONTROLS}
{$ifndef wince}
Add2AutoFree( fTBttCmd );
{$endif wince}
Add2AutoFree( fTBttTxt );
{$ENDIF}
end;
{$ifdef wince}
j:=TBItem2Index(BtnID1st);
BtnID1st:=-1;
for i:=0 to j do
if not TBButtonSeparator(i) then
Inc(BtnID1st);
for i:=fTBttTxt.Count - 1 to BtnID1st - 1 do
fTBttTxt.Add('');
for I:=0 to High( Tooltips ) do begin
if BtnID1st < fTBttTxt.Count then
fTBttTxt.Items[BtnID1st]:=Tooltips[ I ]
else
fTBttTxt.Add( Tooltips[ I ] );
Inc(BtnID1st);
end;
Perform(TB_SETTOOLTIPS, fTBttTxt.Count, LPARAM(fTBttTxt.fList.fItems));
{$else}
for I:= 0 to High( Tooltips ) do
begin
J := fTBttCmd.IndexOf( Pointer( BtnID1st ) );
if J < 0 then
begin
fTBttCmd.Add( Pointer( BtnID1st ) );
fTBttTxt.Add( Tooltips[ I ] );
end
else
fTBttTxt.Items[ J ] := Tooltips[ I ];
Inc( BtnID1st );
end;
{$endif wince}
end;
{$ENDIF ASM_VERSION}
procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer;
const Tooltips: array of PKOLChar );
begin
Toolbar.TBSetTooltips( BtnID1st, Tooltips );
end;
function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean;
begin
Result := Toolbar.TBButtonEnabled[ BtnID ];
end;
procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean );
begin
Toolbar.TBButtonEnabled[ BtnID ] := Enable;
end;
function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean;
begin
Result := Toolbar.TBButtonVisible[ BtnID ];
end;
procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean );
begin
Toolbar.TBButtonVisible[ BtnID ] := Show;
end;
function ToolbarButtonChecked( Toolbar: PControl; BtnID: Integer): Boolean;
begin
Result := Toolbar.TBButtonChecked[ BtnID ];
end;
procedure ToolbarButtonSetChecked( Toolbar: PControl; BtnID: Integer; Checked: Boolean );
begin
Toolbar.TBButtonChecked[ BtnID ] := Checked;
end;
//[function TControl.TBButtonAtPos]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.TBButtonAtPos(X, Y: Integer): Integer;
var I: Integer;
begin
I := TBBtnIdxAtPos( X, Y );
if I >= 0 then
I := TBIndex2Item( I );
Result := I;
end;
{$ENDIF ASM_VERSION}
//[function TControl.TBBtnIdxAtPos]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.TBBtnIdxAtPos(X, Y: Integer): Integer;
var I: Integer;
R: TRect;
P: TPoint;
begin
P := MakePoint( X, Y );
for I := TBButtonCount - 1 downto 0 do
begin
Perform( TB_GETITEMRECT, I, Integer( @R ) );
if PointInRect( P, R ) then
begin
Result := I;
Exit;
end;
end;
Result := -1;
end;
{$ENDIF ASM_VERSION}
//[function TControl.TBButtonSeparator]
function TControl.TBButtonSeparator(BtnID: Integer): Boolean;
var B: TTBButton;
begin
Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID )), Integer( @B ) ) ;
Result := B.fsStyle = TBSTYLE_SEP;
end;
//*
//[procedure TControl.TBDeleteButton]
procedure TControl.TBDeleteButton(BtnID: Integer);
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
Perform( TB_DELETEBUTTON, TBItem2Index( BtnID ), 0 );
end;
//*
//[procedure TControl.TBDeleteBtnByIdx]
procedure TControl.TBDeleteBtnByIdx(Idx: Integer);
begin
Perform( TB_DELETEBUTTON, Idx, 0 );
end;
//*
//[procedure TControl.Clear]
procedure TControl.Clear;
begin
fCommandActions.aClear( @Self );
end;
{$IFDEF ASM_noVERSION}
//[function TControl.TBGetBtnImgIdx]
function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer;
const szTBButton = sizeof( TTBButton );
asm
ADD ESP, -szTBButton
PUSH ESP
PUSH EAX
CALL TBItem2Index
POP EDX
PUSH EAX
PUSH TB_GETBUTTON
PUSH EDX
CALL Perform
POP EAX
ADD ESP, szTBButton-4
end;
{$ELSE ASM_VERSION} //Pascal
function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer;
var B: TTBButton;
begin
Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID ) ), Integer( @B ) );
Result := B.iBitmap;
end;
{$ENDIF ASM_VERSION}
//*
//[procedure TControl.TBSetBtnImgIdx]
procedure TControl.TBSetBtnImgIdx(BtnID: Integer; const Value: Integer);
begin
Perform( TB_CHANGEBITMAP, GetTBBtnGoodID( @Self, BtnID ), Value );
end;
//[procedure TControl.TBSetButtonText]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.TBSetButtonText(BtnID: Integer; const Value: KOLString);
var BI: TTBButtonInfo;
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
BI.cbSize := Sizeof( BI );
BI.dwMask := TBIF_TEXT;
BI.pszText := PKOLChar( Value );
Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );
end;
{$ENDIF ASM_VERSION}
//[function TControl.TBGetBtnWidth]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.TBGetBtnWidth(BtnID: Integer): Integer;
var R: TRect;
begin
R := TBButtonRect[ BtnID ];
Result := R.Right - R.Left;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.TBSetBtnWidth]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.TBSetBtnWidth(BtnID: Integer; const Value: Integer);
var BI: TTBButtonInfo;
begin
BI.cbSize := Sizeof( BI );
BI.dwMask := TBIF_SIZE or TBIF_STYLE;
BtnID := GetTBBtnGoodID( @Self, BtnID );
Perform( TB_GETBUTTONINFO, BtnID, Integer( @BI ) );
BI.cx := Value;
BI.fsStyle := BI.fsStyle and not TBSTYLE_AUTOSIZE;
Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.TBSetBtMinMaxWidth]
procedure TControl.TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer);
begin
case Idx of
0: FTBBtMinWidth := Value;
1: FTBBtMaxWidth := Value;
end;
Perform( TB_SETBUTTONWIDTH, 0, FTBBtMaxWidth or (FTBBtMinWidth shl 16) );
end;
{$IFDEF F_P}
//[function TControl.TBGetBtMinMaxWidth]
function TControl.TBGetBtMinMaxWidth(const Idx: Integer): Integer;
begin
CASE Idx OF
0: Result := FTBBtMinWidth;
1: Result := FTBBtMaxWidth;
END;
end;
{$ENDIF F_P}
{$ifndef wince}
function WndProcTBCustomDraw( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var CD: PNMTBCustomDraw;
Br: HBrush;
begin
Result := FALSE;
if Msg.message = WM_NOTIFY then
begin
CD := Pointer( Msg.lParam );
if longint(CD.nmcd.hdr.code) = NM_CUSTOMDRAW then
begin
if Assigned( Sender.OnTBCustomDraw ) then
Rslt := Sender.OnTBCustomDraw( Sender, CD^ )
else
begin
if Assigned( Sender.fBrush ) then
Windows.FillRect( CD.nmcd.hdc, Sender.ClientRect, Sender.fBrush.Handle )
else
begin
Br := CreateSolidBrush( Color2RGB( Sender.Color ) );
Windows.FillRect( CD.nmcd.hdc, Sender.ClientRect, Br );
DeleteObject( Br );
end;
Rslt := CDRF_SKIPDEFAULT;
end;
end;
end;
end;
procedure TControl.SetOnTBCustomDraw( const Value: TOnTBCustomDraw );
begin
fOnTBCustomDraw := Value;
AttachProc( WndProcTBCustomDraw );
end;
{$endif wince}
//[procedure TControl.SetDroppedDown]
procedure TControl.SetDroppedDown(const Value: Boolean);
begin
//fDropped := Value;
Perform( CB_SHOWDROPDOWN, Integer( Value ), 0 );
end;
//[procedure TControl.AddDirList]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.AddDirList(const Filemask: KOLString; Attrs: DWORD);
begin
if fCommandActions.aDir <> 0 then
Perform( fCommandActions.aDir, Attrs, Integer( PKOLChar( Filemask ) ) );
end;
{$ENDIF ASM_VERSION}
//[FUNCTION WndProcShowModal]
{$IFDEF ASM_noVERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
//var Accept: Boolean; // {Alexander Pravdin, AP}
begin
if Msg.message = WM_CLOSE then
begin
if Self_.ModalResult = 0 then { (Sergey Shishmintzev) }
Self_.ModalResult := -1;
Rslt := 0;
Result := True; // Do not process !
end
else
{$ifdef wince}
if Msg.message = WM_COMMAND then begin
if (HIWORD(Msg.wParam) = 4096) or (HWND(Msg.lParam) = Msg.hwnd) then begin
if Self_.fDefaultBtnCtl <> nil then
if Self_.fDefaultBtnCtl.Enabled then
Self_.fDefaultBtnCtl.Click
else
Self_.ModalResult:=IDCANCEL
else
Self_.ModalResult:=IDOK;
Rslt := 0;
Result := True;
end
else begin
Rslt := 1;
Result := False;
end;
end
else
{$endif wince}
Result := False;
end;
{$ENDIF ASM_VERSION}
//[END WndProcShowModal]
//[function WndProcFixModal]
// by TR"]F
function WndProcFixModal( Self_: PControl; var Msg: TMsg; var Rslt:
Integer ): Boolean;
const HTERROR = $FFFE;
LBtnDown = $201;
LBtnUp = $202;
RBtnDown = $204;
RBtnUp = $205;
WeelDown = $207;
WeelUp = $208;
{$IFDEF MODAL_ACTIVATE_FIX}
var i: Integer;
C: PControl;
{$ENDIF MODAL_ACTIVATE_FIX}
begin
Result := false;
if (Msg.message = WM_SETCURSOR) then
if (LoWord(Msg.lParam) = HTERROR) then
if (HiWord(Msg.lParam) >= LBtnDown) and
(HiWord(Msg.lParam) <= RBtnUp) then
begin
if Applet.fModalForm <> nil then
SetForegroundWindow(Applet.fModalForm.Handle);
Rslt := 1;
Result := TRUE;
end;
{$IFDEF MODAL_ACTIVATE_FIX}
if (Msg.message = WM_ACTIVATEAPP) then
begin
if not Applet.fActivating then
begin
Applet.fActivating := TRUE;
if Msg.wParam <> 0 then
begin
for i := Applet.ChildCount-1 downto 0 do
begin
C := Applet.Children[ i ];
if C.Visible and not C.Enabled then
SetForegroundWindow( C.Handle );
end;
SetForegroundWindow( Applet.fModalForm.Handle );
end;
Applet.fActivating := FALSE;
end;
end;
{$ENDIF MODAL_ACTIVATE_FIX}
end;
//[END WndProcFixModal]
{$IFDEF ASM_noVERSION}
//[function TControl.ShowModal]
function TControl.ShowModal: Integer;
asm
MOV ECX, [EAX].fParent
JECXZ @@show
MOVZX ECX, [EAX].fIsControl
JECXZ @@show_modal
@@show:
CALL Show
XOR EAX, EAX
RET
@@show_modal:
PUSHAD
MOV EBX, EAX
MOV EDI, [Applet]
XOR EBP, EBP // CurCtl = nil
MOV EAX, [EDI].fCurrentControl
CMP [EDI].TControl.FIsApplet, 0
{$IFDEF USE_CMOV}
CMOVZ EAX, EDI
{$ELSE}
JNZ @@curctrl_save
MOV EAX, EDI
@@curctrl_save:
{$ENDIF}
PUSH EAX
MOV EDX, offset[WndProcShowModal]
PUSH EDX
MOV EAX, EBX
CALL TControl.AttachProc
XOR EDX, EDX
MOV [EBX].fModalResult, EDX
CALL NewList
XCHG EAX, EBP
XOR ECX, ECX
INC ECX
MOV ESI, EDI
CMP [EDI].TControl.FIsApplet, 0
JZ @@isapplet
MOV EBP, [EDI].fCurrentControl // CurCtl = Applet.fCurrentControl
MOV ESI, [EDI].fChildren
MOV ECX, [ESI].TList.fCount
MOV ESI, [ESI].TList.fItems
@@1loo: LODSD
@@isapplet:
PUSH ECX
CMP EAX, EBX
JE @@1nx
PUSH EAX
CALL GetEnabled
TEST AL, AL
POP EAX
JZ @@1nx
PUSH EAX
MOV DL, 0
CALL SetEnabled
POP EDX
MOV EAX, EBP
CALL TList.Add
@@1nx: POP ECX
LOOP @@1loo
INC [EBX].fModal
MOV EAX, [Applet]
MOV [EAX].fModalForm, EBX
MOV EAX, EBX
CALL Show
@@msgloo:
MOVZX ECX, [AppletTerminated]
OR ECX, [EBX].fModalResult
JNZ @@e_msgloo
CALL WaitMessage
MOV EAX, EDI
CALL ProcessMessages
{$IFDEF USE_OnIdle}
MOV EAX, EBX
CALL [ProcessIdle]
{$ENDIF}
JMP @@msgloo
@@e_msgloo:
POP EDX
MOV EAX, EBX
CALL TControl.DetachProc
DEC [EBX].fModal
MOV EAX, [Applet]
XOR ECX, ECX
MOV [EAX].fModalForm, ECX
MOV ECX, [EBP].TList.fCount
JECXZ @@2end
MOV ESI, [EBP].TList.fItems
@@2loo: LODSD
PUSH ECX
MOV DL, 1
CALL TControl.SetEnabled
POP ECX
LOOP @@2loo
@@2end:
MOV EAX, EBP
CALL TObj.Free
POP ECX
JECXZ @@exit
PUSH 0
PUSH WA_ACTIVE
PUSH WM_ACTIVATE
PUSH [ECX].fHandle
CALL PostMessage
TEST EBP, EBP // CurCtl = nil ?
JZ @@exit
MOV EAX, EBP
MOV DL, 1
CALL TControl.SetFocused
@@exit:
POPAD
MOV EAX, [EAX].fModalResult
end;
{$ELSE ASM_VERSION} //Pascal
{$IFDEF USE_SHOWMODALPARENTED_ALWAYS}
function TControl.ShowModal: Integer;
begin
Result := ShowModalParented(Applet);
end;
{$ELSE not USE_SHOWMODALPARENTED_ALWAYS}
function TControl.ShowModal: Integer;
var FL: PList;
var CurForm: PControl;
I: Integer;
F: PControl;
CurCtl: PControl; // { Alexander Pravdin }
begin
Result := 0;
if (fIsControl) or (fParent = nil) then
begin
Show;
Exit;
end;
{$ifdef wince}
SHDoneButton(GetWindowHandle, SHDB_SHOW);
Style:=Style and not WS_SYSMENU;
{$endif wince}
AttachProc( WndProcShowModal );
CurForm := Applet.fCurrentControl;
FL := NewList;
CurCtl := nil; // { Alexander Pravdin }
if Applet.IsApplet then
begin
for I := 0 to Applet.ChildCount - 1 do
begin
F := Applet.fChildren.Items[ I ];
if F <> @Self then
if F.Enabled then
begin
FL.Add( F );
F.Enabled := FALSE;
{$IFNDEF NOT_FIX_MODAL}
Inc( F.fFixingModal );
F.AttachProc(WndProcFixModal); {**************}
{$ENDIF}
end;
end
end
else
begin
CurForm := Applet;
if Applet.Enabled then
begin
FL.Add( Applet );
CurCtl := Applet.fCurrentControl; { Alexander Pravdin }
Applet.Enabled := FALSE;
{$IFNDEF NOT_FIX_MODAL}
Inc( Applet.fFixingModal );
Applet.AttachProc(WndProcFixModal); {**************}
{$ENDIF}
end;
end;
Inc( fModal );
Applet.fModalForm := @ Self;
Enabled := TRUE;
Show;
ModalResult := 0;
while not AppletTerminated and (ModalResult = 0) do
begin
Applet.WaitAndProcessMessages;
{$IFDEF USE_OnIdle}
ProcessIdle( @Self );
{$ENDIF}
end;
Dec( fModal );
Applet.fModalForm := nil;
DetachProc( WndProcShowModal );
for I := 0 to FL.Count - 1 do
begin
F := FL.Items[ I ];
{$IFNDEF NOT_FIX_MODAL}
Dec( F.fFixingModal );
if F.fFixingModal <= 0 then
F.DetachProc(WndProcFixModal); {**************}
{$ENDIF}
F.Enabled := TRUE;
end;
FL.Free;
if CurForm <> nil then
PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 );
if CurCtl <> nil then CurCtl.SetFocused( TRUE ); { Alexander Pravdin }
Result := ModalResult;
{$ifdef wince}
Applet.ProcessMessages;
{$endif wince}
end;
{$ENDIF USE_SHOWMODALPARENTED_ALWAYS}
{$ENDIF ASM_VERSION}
//[function TControl.ShowModalParented]
{$IFNDEF NEW_MODAL}
function TControl.ShowModalParented( const AParent: PControl ): Integer;
begin
Result := 0;
end;
{$ELSE NEW_MODAL defined}
function TControl.ShowModalParented( const AParent: PControl ): Integer;
var
FL: PList;
OldMF, F: PControl;
I: Integer;
begin
Result := 0;
if ( AParent = nil ) then Exit;
Inc( fModal );
FL := NewList;
OldMF := AParent.fModalForm;
AParent.fModalForm := @Self;
if AParent.fIsApplet or ( AParent.IsMainWindow and AParent.fIsForm ) then
begin
for I := 0 to AParent.ChildCount - 1 do
begin
F := AParent.fChildren.Items[ I ];
if ( F <> @Self ) and F.fIsForm and F.fEnabled and F.fVisible then
begin
FL.Add( F );
F.Enabled := FALSE;
{$IFNDEF NOT_FIX_MODAL}
F.AttachProc(WndProcFixModal); {**************}
{$ENDIF}
end;
end;
end;
if AParent.fIsForm and AParent.Enabled then
begin
FL.Add( AParent );
AParent.Enabled := FALSE;
end;
ModalResult := 0;
Show;
while not AppletTerminated and ( ModalResult = 0 ) do
begin
AParent.WaitAndProcessMessages;
{$IFDEF USE_OnIdle}
ProcessIdle( @Self );
{$ENDIF}
end;
AParent.fModalForm := OldMF;
Dec( fModal );
for I := 0 to FL.Count - 1 do
begin
F := PControl( FL.Items[ I ] );
F.Enabled := True;
{$IFNDEF NOT_FIX_MODAL}
F.DetachProc(WndProcFixModal); {**************}
{$ENDIF}
end;
FL.Free;
Hide;
Result := ModalResult;
end;
{$ENDIF NEW_MODAL}
//[function DisableWindows]
function DisableWindows( W: hwnd; LPARAM: Integer ): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
var FL: PList;
Buf: array[ 0..127 ] of Char;
begin
FL := Pointer( LPARAM );
if IsWindowEnabled( W ) and (W <> FL.Tag) then
begin
GetClassName( W, @ Buf[ 0 ], Sizeof( Buf ) );
if Buf <> 'ComboLBox' then
begin
FL.Add( Pointer( W ) );
EnableWindow( W, FALSE );
end;
end;
Result := TRUE;
end;
//[function TControl.ShowModalEx]
function TControl.ShowModalEx: Integer;
{$ifdef wince}
begin
Result:=ShowModal;
{$else}
var FL: PList;
var CurForm: PControl;
I: Integer;
W: HWnd;
CurCtl: PControl; { Alexander Pravdin }
begin
Result := 0;
if (fIsControl) or (fParent = nil) then
begin
Show;
Exit;
end;
AttachProc( WndProcShowModal );
CurForm := Applet.fCurrentControl;
FL := NewList;
FL.Tag := fHandle;
// ++++ { Alexander Pravdin }
if not Applet.fIsApplet then CurCtl := Applet.fCurrentControl
else CurCtl := nil;
// ----
CreateWindow;
EnumThreadWindows( GetCurrentThreadID, @ DisableWindows, Integer( FL ) );
Enabled := TRUE;
Inc( fModal );
Applet.fModalForm := @ Self;
Show;
ModalResult := 0;
while not AppletTerminated and (ModalResult = 0) do
begin
Applet.WaitAndProcessMessages;
{$IFDEF USE_OnIdle}
ProcessIdle( @Self );
{$ENDIF}
end;
Dec( fModal );
Applet.fModalForm := @ Self;
DetachProc( WndProcShowModal );
for I := 0 to FL.Count - 1 do
begin
W := THandle( FL.Items[ I ] );
EnableWindow( W, TRUE );
end;
FL.Free;
if CurForm <> nil then
PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 );
if CurCtl <> nil then CurCtl.SetFocused( True ); { Alexander Pravdin }
Result := ModalResult;
{$endif wince}
end;
//[function TControl.GetModal]
function TControl.GetModal: Boolean;
begin
Result := fModal > 0;
end;
{$IFDEF USE_SETMODALRESULT}
//[procedure TControl.SetModalResult]
procedure TControl.SetModalResult( const Value: Integer );
begin
//if fModal <= 0 then Exit;
fModalResult := Value;
if Value <> 0 then
PostMessage( GetWindowHandle, 0, 0, 0 );
end;
{$ENDIF}
{$IFNDEF NEW_MENU_ACCELL}
procedure TControl.DoDestroyAccelTable;
begin
if fAccelTable <> 0 then
begin
DestroyAcceleratorTable( fAccelTable );
fAccelTable := 0;
end;
end;
{$ENDIF}
{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
{$IFDEF _X_}
{$IFDEF GTK}
function control_clicked( Obj: PGtkWidget; Sender: PControl ): Boolean; cdecl;
begin
if Assigned( Sender.fOnClick ) then
Sender.fOnClick( Sender );
Result := FALSE;
end;
procedure TControl.SetOnClick( const Value: TOnEvent );
begin
fOnClick := Value;
if fEventboxHandle = fHandle then
begin
{$IFNDEF SMALLER_CODE}
if not Assigned( Value ) then
gtk_signal_disconnect( GTK_OBJECT( fEventboxHandle ), fClickedEvent )
else
{$ENDIF SMALLEST_CODE}
fClickedEvent := gtk_signal_connect( GTK_OBJECT( fEventboxHandle ), 'clicked',
@ control_clicked, @ Self )
end
else
SetMouseEvent( @ Self, 'button_release_event' );
end;
{$ENDIF GTK}
{$ENDIF _X_}
//////////////////////////////////////////////////////////////////
// T I M E R
//////////////////////////////////////////////////////////////////
var {$IFDEF WIN} TimerOwnerWnd: PControl; {$ENDIF} // in Linux, timer not need in a window
TimerCount: Integer = 0;
{ -- Constructor of timer -- }
//[function NewTimer]
function NewTimer( Interval: Integer ): PTimer;
begin
{-}
New( Result, Create );
{+}{++}(*Result := PTimer.Create;*){--}
if Interval <= 0 then Interval := 1000;
Result.fInterval := Interval;
Inc( TimerCount );
end;
//[END NewTimer]
{ -- Timer procedure -- }
{$IFDEF WIN}
//[FUNCTION TimerProc]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif};
begin
{$IFDEF STOPTIMER_AFTER_APPLETTERMINATED}
if not AppletTerminated then
{$ENDIF}
if Assigned( T.fOnTimer ) then
T.fOnTimer( T );
Result := 0;
end;
{$ENDIF ASM_VERSION}
//[END TimerProc]
{$ENDIF WIN}
{ TTimer }
//[destructor TTimer.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TTimer.Destroy;
begin
Enabled := False;
inherited;
Dec( TimerCount );
{$IFDEF WIN}
if TimerCount = 0 then
begin
TimerOwnerWnd.Free;
TimerOwnerWnd := nil;
end;
{$ENDIF WIN}
end;
{$ENDIF ASM_VERSION}
//[procedure TTimer.SetEnabled]
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TTimer.SetEnabled(const Value: Boolean);
var WasEnabled: Boolean;
begin
WasEnabled := fEnabled;
fEnabled := Value;
if WasEnabled = Value then Exit;
{$IFDEF TIMER_APPLETWND}
if Applet = nil then Exit;
{$ENDIF}
if Value then
begin
{$IFDEF TIMER_APPLETWND}
fHandle := SetTimer( Applet.GetWindowHandle, Integer( @Self ),
fInterval, @TimerProc );
{$ELSE}
if TimerOwnerWnd = nil then
begin
TimerOwnerWnd := _NewWindowed( nil, {$ifdef wince}'TWND'{$else}''{$endif}, TRUE );
TimerOwnerWnd.fStyle := 0;
TimerOwnerWnd.fIsControl := TRUE;
end;
fHandle := SetTimer( TimerOwnerWnd.GetWindowHandle, Integer( @Self ),
fInterval, @TimerProc );
{$ENDIF}
end
else
begin
if fHandle <> 0 then
begin
KillTimer( {$IFDEF TIMER_APPLETWND} Applet.fHandle
{$ELSE} TimerOwnerWnd.fHandle {$ENDIF}, fHandle );
fHandle := 0;
end;
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF _X_}
{$IFDEF GTK}
function TimerGTKTick( Sender: Pointer ): LONGBOOL; cdecl;
begin
if not PTimer( Sender ).fEnabled then Result := FALSE
else
begin
if Assigned( PTimer( Sender ).fOnTimer ) then
Ptimer( Sender ).fOnTimer( Sender );
Result := PTimer( Sender ).fEnabled;
end;
if Result then
PTimer( Sender ).RefDec;
end;
procedure TTimer.SetEnabled(const Value: Boolean);
begin
if FEnabled = Value then Exit;
fEnabled := Value;
if Value then
begin
RefInc;
fHandle := gtk_timeout_add( fInterval, TimerGTKTick, @ Self );
end
else
begin
if AppletTerminated then
begin
gtk_timeout_remove( fHandle );
RefDec;
end;
end;
end;
{$ELSE not GTK}
var fActiveTimerList: PTimer;
fClockPerSecond: Integer;
fAlarmHandling: Boolean;
procedure SetAlarm; forward;
procedure AlarmHandler(SigNum: Integer); cdecl;
var T, NT: PTimer;
c: Integer;
count_handled: Integer;
begin
c := clock;
fAlarmHandling := TRUE; // to prevent SetAlarm working while timers are handling
TRY
//--- 1. Clear fTimerHandled flag for all active timers
T := fActiveTimerList;
while T <> nil do
begin
T.fTimerHandled := FALSE;
T := T.fNext;
end;
//--- 2. Handle all expired timers
count_handled := 0;
while not AppletTerminated do // until all timers expired are handled or
begin // until the application is terminated
//--- 2.A. Search a timer which was expired before all others
T := fActiveTimerList;
NT := nil;
while T <> nil do
begin
if not T.fTimerHandled and (
(NT = nil) or ((T.fExpireNext - c) < (NT.fExpireNext - c))
) then
NT := T;
T := T.fNext;
end;
if NT = nil then break; // there are no more timers expired
if (count_handled > 0) and
((NT.fExpireNext - c > 0) or (NT.fExpireNext < 0) and (c > 0)) then break;
//--- 2.B. Handle found timer (NT)
inc( count_handled ); // count handled timer to ensure that at least 1 timer
// was handled in result of alarm call
{$IFDEF SUPPORT_LONG_TIMER}
NT.fExpireTotal := NT.fExpireTotal - (c - NT.fTimeStart);
if NT.fExpireTotal > 30 * 60 * fClockPerSecond then
NT.fExpireNext := c + 30 * 60 * fClockPerSecond
else
NT.fExpireNext := c + NT.fExpireTotal;
{$ELSE not SUPPORT_LONG_TIMER}
NT.fExpireNext := // next time to expire this timer
NT.fExpireNext + fClockPerSecond * NT.fInterval;
{$ENDIF SUPPORT_LONG_TIMER}
NT.fTimerHandled := TRUE; // do not handle that timer again in that loop
{$IFDEF SUPPORT_LONG_TIMER}
if NT.fExpireTotal <= 0 then
{$ENDIF SUPPORT_LONG_TIMER}
begin
if NT.fMultimedia and not NT.fPeriodic then
NT.Enabled := FALSE; // one-shot timer, disable it now
//--------------------------------------------------------------
//todo: for not a multimedia timer, post a signal to a window
// to synchronize timer handling with the main thread!
// (but not for fMultimedia timers)
//--------------------------------------------------------------
if Assigned( NT.fOnTimer ) then
NT.fOnTimer( NT ); // in result of this action, timer NT or any other active
// timer can be disabled and dropped from fActiveTimerList and any amount of
// previously disbled timers can be added
end;
end;
FINALLY
fAlarmHandling := FALSE;
END;
// 3. finally, install the next alarm to the nearest expirating timer if any
SetAlarm;
end;
procedure SetAlarm;
var i: Integer;
T, NT: PTimer;
TV: itimerval;
c: clock_t;
begin
if AppletTerminated then Exit; // if the application is terminated we do not install alarms
if fAlarmHandling then Exit; // while alarm is handling do not reinstall alarms
c := clock;
T := fActiveTimerList;
NT := T;
while T <> nil do
begin
if (T.fExpireNext - c) < (NT.fExpireNext - c) then
NT := T;
T := T.fNext;
end;
if NT = nil then Exit;
i := (NT.fExpireNext - c) * 1000 div fClockPerSecond;
if i < 0 then i := 10; // 10 milliseconds as minimum time to alarm
TV.it_interval.tv_sec := 0; // set interval to alarm once
TV.it_interval.tv_usec := 0;
TV.it_value.tv_sec := i div 1000; // set time to alarm next time
TV.it_value.tv_usec := (i mod 1000) * 1000;
signal( SIGALRM, AlarmHandler );
setitimer( ITIMER_REAL, TV, nil );
end;
procedure TTimer.SetEnabled(const Value: Boolean);
begin
if FEnabled = Value then Exit;
fEnabled := Value;
if Value then
begin
if fClockPerSecond = 0 then
fClockPerSecond := CLK_TCK;
fExpireTotal := Int64( fClockPerSecond ) * fInterval;
{$IFDEF SUPPORT_LONG_TIMER}
if fExpireTotal > 30 * 60 * fClockPerSecond then
fExpireNext := clock + 30 * 60 * fClockPerSecond
else
fExpireNext := clock + fExpireTotal;
{$ELSE}
fExpireNext := clock + fExpireTotal;
{$ENDIF SUPPORT_LONG_TIMER}
if fActiveTimerList <> nil then
begin
fNext := fActiveTimerList;
fActiveTimerList.fPrev := @ Self;
end;
fActiveTimerList := @ Self;
end
else
begin
if fPrev <> nil then
fPrev.fNext := fNext;
if fNext <> nil then
fNext.fPrev := fPrev;
if fActiveTimerList = @ Self then
fActiveTimerList := fNext;
fPrev := nil;
fNext := nil;
end;
if fActiveTimerList <> nil then
begin // set alarm to the nearest expiring timer
SetAlarm;
end;
end;
{$ENDIF not GTK}
{$ENDIF _X_}
procedure TTimer.SetInterval(const Value: Integer);
var WasEnabled : Boolean;
begin
if fInterval = Value then Exit;
fInterval := Value;
WasEnabled := Enabled;
Enabled := False;
Enabled := WasEnabled {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED}
and not AppletTerminated
{$ENDIF};
end;
{$IFDEF WIN}
{$ifdef win32}
{ TMMTimer }
{ ------------ declarations moved here from MMSystem -------------------- }
const
TIME_ONESHOT = 0; { program timer for single event }
TIME_PERIODIC = 1; { program for continuous periodic event }
TIME_CALLBACK_FUNCTION = $0000; { callback is function }
TIME_CALLBACK_EVENT_SET = $0010; { callback is event - use SetEvent }
TIME_CALLBACK_EVENT_PULSE = $0020; { callback is event - use PulseEvent }
type
TFNTimeCallBack = procedure(uTimerID, uMessage: UINT;
dwUser, dw1, dw2: DWORD) {$ifdef wince}cdecl{$else}stdcall{$endif};
//[API timeSetEvent]
function timeSetEvent(uDelay, uResolution: UINT;
lpFunction: TFNTimeCallBack; dwUser: DWORD; uFlags: UINT): THandle; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'winmm.dll' name 'timeSetEvent';
function timeKillEvent(uTimerID: UINT): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'winmm.dll' name 'timeKillEvent';
{ ----------------------------------------------------------------------- }
//[procedure MMTimerCallback]
procedure MMTimerCallback(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD);
{$ifdef wince}cdecl{$else}stdcall{$endif};
var MMTimer: PMMTimer;
begin
MMTimer := Pointer( dwUser );
if Assigned( MMTimer.FOnTimer ) then
MMTimer.fOnTimer( MMTimer );
end;
//[function NewMMTimer]
function NewMMTimer( Interval: Integer ): PMMTimer;
begin
{-}
New( Result, Create );
{+} {++}(* Result := PMMTimer.Create; *){--}
Result.fInterval := Interval;
Result.FPeriodic := TRUE;
end;
//[END NewMMTimer]
//[destructor TMMTimer.Destroy]
destructor TMMTimer.Destroy;
begin
Enabled := FALSE;
Inc( TimerCount );
inherited;
end;
//[procedure TMMTimer.SetEnabled]
procedure TMMTimer.SetEnabled(const Value: Boolean);
begin
if Value xor (fHandle <> 0) then
begin
if fHandle = 0 then
fHandle := timeSetEvent( Interval, Resolution, MMTimerCallback, DWORD( @ Self ),
Integer( Periodic ) or TIME_CALLBACK_FUNCTION )
else
begin
timeKillEvent( fHandle );
fHandle := 0;
end;
end;
fEnabled := Value;
end;
{$endif win32}
{$ENDIF WIN}
{$IFDEF LIN}
function NewMMTimer( Interval: Integer ): PTimer;
begin
Result := NewTimer( Interval );
{$IFNDEF GTK}
{$IFNDEF QT}
Result.fMultimedia := TRUE;
Result.fPeriodic := TRUE;
Result.fResolution := 1;
{$ENDIF QT}
{$ENDIF GTK}
end;
{$ENDIF LIN}
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
////////////////////////////////////////////////////////////////////////
// t B I T M A P
///////////////////////////////////////////////////////////////////////
{ -- bitmap -- }
//[FUNCTION PrepareBitmapHeader]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo;
begin
Assert( W > 0, 'Width must be >0' );
Assert( H > 0, 'Height must be >0' );
Result := AllocMem( 256*Sizeof(TRGBQuad)+Sizeof(TBitmapInfoHeader) );
Assert( Result <> nil, 'No memory' );
Result.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
Result.bmiHeader.biWidth := W;
Result.bmiHeader.biHeight := H; // may be, -H ?
Result.bmiHeader.biPlanes := 1;
Result.bmiHeader.biBitCount := BitsPerPixel;
end;
{$ENDIF ASM_VERSION}
//[END PrepareBitmapHeader]
const
BitsPerPixel_By_PixelFormat: array[ TPixelFormat ] of Byte =
( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
//[FUNCTION Bits2PixelFormat]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;
var I: TPixelFormat;
begin
for I := High(I) downto Low(I) do
if BitsPerPixel = BitsPerPixel_By_PixelFormat[ I ] then
begin
Result := I;
Exit;
end;
Result := pfDevice;
end;
{$ENDIF ASM_VERSION}
//[END Bits2PixelFormat]
//[procedure DummyDetachCanvas]
procedure DummyDetachCanvas( Sender: PBitmap );
begin
end;
//[FUNCTION NewBitmap]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewBitmap( W, H: Integer ): PBitmap;
var DC: HDC;
begin
{-}
New( Result, Create );
{+}{++}(*Result := PBitmap.Create;*){--}
Result.fHandleType := bmDDB;
Result.fDetachCanvas := DummyDetachCanvas;
Result.fWidth := W;
Result.fHeight := H;
if (W <> 0) and (H <> 0) then
begin
DC := GetDC( 0 );
Result.fHandle := CreateCompatibleBitmap( DC, W, H );
Assert( Result.fHandle <> 0, 'Can not create bitmap handle' );
ReleaseDC( 0, DC );
end;
end;
{$ENDIF ASM_VERSION}
//[END NewBitmap]
const InitColors: array[ 0..17 ] of DWORD = ( $F800, $7E0, $1F, 0, $800000, $8000,
$808000, $80, $800080, $8080, $808080, $C0C0C0, $FF0000, $FF00, $FFFF00, $FF,
$FF00FF, $FFFF );
//[PROCEDURE PreparePF16bit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure PreparePF16bit( DIBHeader: PBitmapInfo );
begin
DIBHeader.bmiHeader.biCompression := BI_BITFIELDS;
Move( InitColors[ 0 ], DIBHeader.bmiColors[ 0 ], 19*Sizeof(TRGBQUAD) );
end;
{$ENDIF ASM_VERSION}
//[END PreparePF16bit]
//[FUNCTION NewDIBBitmap]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;
const BitsPerPixel: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
var BitsPixel: Integer;
begin
{-}
New( Result, Create );
{+}{++}(*Result := PBitmap.Create;*){--}
Result.fDetachCanvas := DummyDetachCanvas;
Result.fWidth := W;
Result.fHeight := H;
if (W <> 0) and (H <> 0) then
begin
BitsPixel := BitsPerPixel[ PixelFormat ];
if BitsPixel = 0 then
begin
Result.fNewPixelFormat := DefaultPixelFormat;
BitsPixel := BitsPerPixel[DefaultPixelFormat];
end
else
Result.fNewPixelFormat := PixelFormat;
ASSERT( Result.fNewPixelFormat in [ pf1bit..pf32bit ], 'Strange pixel format' );
Result.fDIBHeader := PrepareBitmapHeader( W, H, BitsPixel );
if PixelFormat = pf16bit then
begin
PreparePF16bit( Result.fDIBHeader );
end;
Result.fDIBSize := Result.ScanLineSize * H;
Result.fDIBBits :=
Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, Result.fDIBSize + 16 ) );
ASSERT( Result.fDIBBits <> nil, 'No memory' );
end;
end;
{$ENDIF ASM_VERSION}
//[END NewDIBBitmap]
{ TBitmap }
//[procedure TBitmap.ClearData]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.ClearData;
begin
fDetachCanvas( @Self );
if fHandle <> 0 then
begin
DeleteObject( fHandle );
fHandle := 0;
fDIBBits := nil;
end;
if fDIBBits <> nil then
begin
GlobalFree( THandle( fDIBBits ) );
fDIBBits := nil;
end;
if fDIBHeader <> nil then
begin
FreeMem( fDIBHeader );
fDIBHeader := nil;
end;
fScanLineSize := 0;
fGetDIBPixels := nil;
fSetDIBPixels := nil;
ClearTransImage;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.Clear]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.Clear;
begin
RemoveCanvas;
ClearData;
fWidth := 0;
fHeight := 0;
fDIBAutoFree := FALSE;
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.GetBoundsRect]
function TBitmap.GetBoundsRect: TRect;
begin
Result := MakeRect( 0, 0, Width, Height );
end;
//[destructor TBitmap.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TBitmap.Destroy;
begin
Clear;
inherited;
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.BitsPerPixel]
function TBitmap.BitsPerPixel: Integer;
var B: tagBitmap;
begin
CASE PixelFormat OF
pf1bit: Result := 1;
pf4bit: Result := 4;
pf8bit: Result := 8;
pf15bit: Result := 15;
pf16bit: Result := 16;
pf24bit: Result := 24;
pf32bit: Result := 32;
else begin
Result := 0;
if fHandle <> 0 then
if GetObject( fHandle, Sizeof( B ), @B ) > 0 then
Result := B.bmBitsPixel * B.bmPlanes;
end;
END;
end;
//[procedure TBitmap.Draw]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.Draw(DC: HDC; X, Y: Integer);
var
DCfrom, DC0: HDC;
oldBmp: HBitmap;
oldHeight: Integer;
B: tagBitmap;
label
TRYAgain;
begin
TRYAgain:
if Empty then Exit;
if fHandle <> 0 then
begin
fDetachCanvas( @Self );
oldHeight := fHeight;
if GetObject( fHandle, sizeof( B ), @B ) <> 0 then
oldHeight := B.bmHeight;
ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
DC0 := GetDC( 0 );
DCfrom := CreateCompatibleDC( DC0 );
ReleaseDC( 0, DC0 );
oldBmp := SelectObject( DCfrom, fHandle );
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
BitBlt( DC, X, Y, fWidth, oldHeight, DCfrom, 0, 0, SRCCOPY );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
SelectObject( DCfrom, oldBmp );
DeleteDC( DCfrom );
end
else
if fDIBBits <> nil then
begin
oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);
ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
ASSERT( fWidth > 0, 'Width must be > 0' );
if StretchDIBits( DC, X, Y, fWidth, oldHeight, 0, 0, fWidth, oldHeight,
fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY ) = 0 then
begin
if GetHandle <> 0 then
goto TRYAgain;
end;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.StretchDraw]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.StretchDraw(DC: HDC; const Rect: TRect);
var DCfrom: HDC;
oldBmp: HBitmap;
label DrawHandle;
begin
if Empty then Exit;
DrawHandle:
if fHandle <> 0 then
begin
fDetachCanvas( @Self );
DCfrom := CreateCompatibleDC( 0 );
oldBmp := SelectObject( DCfrom, fHandle );
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
Rect.Bottom - Rect.Top, DCfrom, 0, 0, fWidth, fHeight,
SRCCOPY );
SelectObject( DCfrom, oldBmp );
DeleteDC( DCfrom );
end
else
if fDIBBits <> nil then
begin
if StretchDIBits( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
Rect.Bottom - Rect.Top, 0, 0, fWidth, fHeight,
fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY )<=0 then
begin
if GetHandle <> 0 then
goto DrawHandle;
end;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.DrawMasked]
procedure TBitmap.DrawMasked(DC: HDC; X, Y: Integer; Mask: HBitmap);
begin
StretchDrawMasked( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ), Mask );
end;
//[procedure TBitmap.DrawTransparent]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor);
begin
if TranspColor = clNone then
Draw( DC, X, Y )
else
StretchDrawTransparent( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ),
TranspColor );
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.StretchDrawTransparent]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
{$ifdef wince}
function TransparentImage(hdcDest : HDC;DstX : LONG;DstY : LONG;DstCx : LONG;DstCy : LONG;hSrc : HANDLE;SrcX : LONG;SrcY : LONG;SrcCx : LONG;SrcCy : LONG;TransparentColor : COLORREF): WINBOOL; cdecl; external KernelDLL name 'TransparentImage';
{$endif wince}
procedure TBitmap.StretchDrawTransparent(DC: HDC; const Rect: TRect; TranspColor: TColor);
begin
if TranspColor = clNone then
StretchDraw( DC, Rect )
else
begin
if GetHandle = 0 then Exit;
TranspColor := Color2RGB( TranspColor );
{$ifdef wince}
TransparentImage(DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, fHandle, 0, 0, Width, Height, TranspColor);
{$else}
if (fTransMaskBmp = nil) or (fTransColor <> TranspColor) then
begin
if fTransMaskBmp = nil then
fTransMaskBmp := NewBitmap( 0, 0 {fWidth, fHeight} );
fTransColor := TranspColor;
// Create here mask bitmap:
fTransMaskBmp.Assign( @Self );
fTransMaskBmp.Convert2Mask( TranspColor );
end;
StretchDrawMasked( DC, Rect, fTransMaskBmp.Handle );
{$endif wince}
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF DEBUG_DRAWTRANSPARENT}
procedure DebugDrawTransparent( DC: HDC; X, Y, W, H: Integer; PF: TPixelFormat;
const Note: String );
const PixelFormatAsStr: array[ TPixelFormat ] of String = ( 'pfDevice', 'pf1bit',
'pf4bit', 'pf8bit', 'pf15bit', 'pf16bit', 'pf24bit', 'pf32bit', 'pfCustom' );
var Bmp: PBitmap;
begin
Bmp := NewDibBitmap( W, H, pf32bit );
BitBlt( Bmp.Canvas.Handle, 0, 0, W, H, DC, X, Y, SrcCopy );
Bmp.SaveToFile( GetStartDir + PixelFormatAsStr[ PF ] + Note );
Bmp.Free;
end;
{$ENDIF DEBUG_DRAWTRANSPARENT}
const
ROP_DstCopy = $00AA0029;
//[procedure TBitmap.StretchDrawMasked]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.StretchDrawMasked(DC: HDC; const Rect: TRect; Mask: HBitmap);
var
DCfrom, MemDC, MaskDC: HDC;
MemBmp: HBITMAP;
//Save4From,
Save4Mem, Save4Mask: THandle;
crText, crBack: TColorRef;
{$IFDEF FIX_TRANSPBMPPALETTE}
FixBmp: PBitmap;
{$ENDIF FIX_TRANSPBMPPALETTE}
begin
{$IFDEF FIX_TRANSPBMPPALETTE}
if PixelFormat in [ pf4bit, pf8bit ] then
begin
FixBmp := NewBitmap( 0, 0 );
FixBmp.Assign( @ Self );
FixBmp.PixelFormat := pf32bit;
FixBmp.StretchDrawMasked( DC, Rect, Mask );
FixBmp.Free;
Exit;
end;
{$ENDIF FIX_TRANSPBMPPALETTE}
if GetHandle = 0 then Exit;
//fDetachCanvas( @Self );
//DCfrom := CreateCompatibleDC( 0 );
DCFrom := Canvas.Handle;
//Save4From := SelectObject( DCfrom, fHandle );
//ASSERT( Save4From <> 0, 'Can not select source bitmap to DC' );
MaskDC := CreateCompatibleDC( 0 );
Save4Mask := SelectObject( MaskDC, Mask );
ASSERT( Save4Mask <> 0, 'Can not select mask bitmap to DC' );
MemDC := CreateCompatibleDC( 0 );
MemBmp := CreateCompatibleBitmap( DCfrom, fWidth, fHeight );
Save4Mem := SelectObject( MemDC, MemBmp );
ASSERT( Save4Mem <> 0, 'Can not select memory bitmap to DC' );
StretchBlt( MemDC, 0, 0, fWidth, fHeight, MaskDC, 0, 0, fWidth, fHeight, SrcCopy);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '1SrcCopy.bmp' );
{$ENDIF}
StretchBlt( MemDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, fWidth, fHeight, SrcErase);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '2SrcErase.bmp' );
{$ENDIF}
crText := SetTextColor(DC, $0);
crBack := Windows.SetBkColor(DC, $FFFFFF);
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
MaskDC, 0, 0, fWidth, fHeight, SrcAnd);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '3SrcAnd.bmp' );
{$ENDIF}
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
MemDC, 0, 0, fWidth, fHeight, SrcInvert);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '4SrcInvert.bmp' );
{$ENDIF}
Windows.SetBkColor( DC, crBack);
SetTextColor( DC, crText);
//if Save4Mem <> 0 then
// SelectObject( MemDC, Save4Mem );
DeleteObject(MemBmp);
DeleteDC(MemDC);
//SelectObject( DCfrom, Save4From );
//DeleteDC( DCfrom );
SelectObject( MaskDC, Save4Mask );
DeleteDC( MaskDC );
end;
{$ENDIF ASM_VERSION}
//[procedure ApplyBitmapBkColor2Canvas]
procedure ApplyBitmapBkColor2Canvas( Sender: PBitmap );
begin
if Sender.fCanvas = nil then Exit;
Sender.fCanvas.Brush.Color := Sender.BkColor;
end;
//[PROCEDURE DetachBitmapFromCanvas]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure DetachBitmapFromCanvas( Sender: PBitmap );
begin
if Sender.fCanvasAttached = 0 then Exit;
SelectObject( Sender.fCanvas.fHandle, Sender.fCanvasAttached );
Sender.fCanvasAttached := 0;
end;
{$ENDIF ASM_VERSION}
//[END DetachBitmapFromCanvas]
//[function TBitmap.GetCanvas]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetCanvas: PCanvas;
var DC: HDC;
begin
Result := nil;
if Empty then Exit;
if GetHandle = 0 then Exit;
if fCanvas = nil then
begin
fApplyBkColor2Canvas := ApplyBitmapBkColor2Canvas;
DC := CreateCompatibleDC( 0 );
fCanvas := NewCanvas( DC );
fCanvas.fIsPaintDC := FALSE;
fCanvas.OnChange := CanvasChanged;
if fBkColor <> 0 then
fCanvas.Brush.Color := fBkColor;
end;
Result := fCanvas;
if fCanvas.fHandle = 0 then
begin
DC := CreateCompatibleDC( 0 );
fCanvas.Handle := DC;
fCanvasAttached := 0;
end;
if fCanvasAttached = 0 then
begin
fCanvasAttached := SelectObject( fCanvas.Handle, fHandle );
ASSERT( fCanvasAttached <> 0, 'Can not select bitmap to DC of Canvas' );
end;
fDetachCanvas := DetachBitmapFromCanvas;
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.GetEmpty]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetEmpty: Boolean;
begin
Result := (fWidth = 0) or (fHeight = 0);
ASSERT( (fWidth >= 0) and (fHeight >= 0), 'Bitmap dimensions can be negative' );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_noVERSION}
//[function TBitmap.GetHandle]
function TBitmap.GetHandle: HBitmap;
asm
PUSH EBX
MOV EBX, EAX
CALL GetEmpty
JZ @@exit
MOV EAX, EBX
CALL [EAX].fDetachCanvas
MOV ECX, [EBX].fHandle
INC ECX
LOOP @@exit
MOV ECX, [EBX].fDIBBits
JECXZ @@exit
PUSH ECX
PUSH 0
CALL GetDC
PUSH EAX
PUSH 0
PUSH 0
LEA EDX, [EBX].fDIBBits
PUSH EDX
PUSH DIB_RGB_COLORS
PUSH [EBX].fDIBHeader
PUSH EAX
CALL CreateDIBSection
MOV [EBX].fHandle, EAX
PUSH 0
CALL ReleaseDC
POP EAX
PUSH EAX
MOV EDX, [EBX].fDIBBits
MOV ECX, [EBX].fDIBSize
CALL System.Move
POP EAX
CMP [EBX].fDIBAutoFree, 0
JNZ @@freed
PUSH EAX
CALL GlobalFree
@@freed:MOV [EBX].fDIBAutoFree, 1
XOR EAX, EAX
MOV [EBX].fGetDIBPixels, EAX
MOV [EBX].fSetDIBPixels, EAX
@@exit: MOV EAX, [EBX].fHandle
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetHandle: HBitmap;
var OldBits: Pointer;
DC0: HDC;
begin
Result := 0;
if Empty then Exit;
fDetachCanvas( @ Self );
if fHandle = 0 then
begin
if fDIBBits <> nil then
begin
OldBits := fDIBBits;
DC0 := GetDC( 0 );
fDIBBits := nil;
fHandle := CreateDIBSection( DC0, fDIBHeader^, DIB_RGB_COLORS,
fDIBBits, 0, 0 );
{$IFDEF DEBUG}
if fHandle = 0 then
ShowMessage( 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +
', ' + SysErrorMessage( GetLastError ) );
{$ELSE}
ASSERT( fHandle <> 0, 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +
', ' + SysErrorMessage( GetLastError ) );
{$ENDIF}
ReleaseDC( 0, DC0 );
if fHandle <> 0 then
begin
Move( OldBits^, fDIBBits^, fDIBSize );
if not fDIBAutoFree then
GlobalFree( THandle( OldBits ) );
fDIBAutoFree := TRUE;
fGetDIBPixels := nil;
fSetDIBPixels := nil;
end
else
fDIBBits := OldBits;
end;
end;
Result := fHandle;
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.GetHandleAllocated]
function TBitmap.GetHandleAllocated: Boolean;
begin
Result := fHandle <> 0;
end;
//[procedure TBitmap.LoadFromFile]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.LoadFromFile(const Filename: KOLString);
var Strm: PStream;
begin
Strm := NewReadFileStream( Filename );
LoadFromStream( Strm );
Strm.Free;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.LoadFromResourceID]
procedure TBitmap.LoadFromResourceID(Inst: DWORD; ResID: Integer);
begin
LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ) );
end;
//[procedure TBitmap.LoadFromResourceName]
{$IFDEF ASM_UNICODE}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.LoadFromResourceName(Inst: DWORD; ResName: PKOLChar);
var ResHandle: HBitmap;
{$ifndef wince}
Flg: DWORD;
{$endif wince}
begin
Clear;
{$ifndef wince}
Flg := 0;
if fHandleType = bmDIB then
Flg := LR_CREATEDIBSECTION;
{$endif wince}
ResHandle := LoadImage( Inst, ResName, IMAGE_BITMAP, 0, 0, {$ifdef wince} 0 {$else} LR_DEFAULTSIZE or Flg {$endif} );
if ResHandle = 0 then Exit;
Handle := ResHandle;
end;
{$ENDIF ASM_VERSION}
{$IFDEF F_P}
type
TBITMAPFILEHEADER = packed record
bfType: Word;
bfSize: DWORD;
bfReserved1: Word;
bfReserved2: Word;
bfOffBits: DWORD;
end;
{$ENDIF}
{$IFDEF ASM_noVERSION} // error + 16Colors->swap(Gray,Silver) + Core
//[procedure TBitmap.LoadFromStream]
procedure TBitmap.LoadFromStream(Strm: PStream);
type tBFH = TBitmapFileHeader;
tBIH = TBitmapInfoHeader;
const szBIH = Sizeof( tBIH );
szBFH = Sizeof( tBFH );
asm
PUSH EBX
PUSH ESI
MOV EBX, EAX
PUSH EDX
CALL Clear
POP ESI
MOV EAX, ESI
CALL TStream.GetPosition
PUSH EAX // [EBP+4] = Strm.Pos (starting pos)
PUSH EBP
MOV EBP, ESP
ADD ESP, -(szBIH + szBFH)
// reading bitmap
XOR ECX, ECX
MOV [EBX].fHandleType, CL
MOV CL, szBFH
MOV EDX, ESP
PUSH ECX
MOV EAX, ESI
CALL TStream.Read
POP ECX
SUB ECX, EAX
JNZ @@eread1
CMP [ESP].tBFH.bfType, $4D42
JE @@1
MOV EDX, [EBP+4]
MOV EAX, ESI
CALL TStream.Seek
XOR EAX, EAX
XOR EDX, EDX
JMP @@2
@@1:
MOV EDX, [ESP].tBFH.bfSize
MOV EAX, [ESP].tBFH.bfOffBits
@@2:
PUSH EDX // Push Size
PUSH EAX // Push Off
XOR ECX, ECX
MOV CL, szBIH
LEA EDX, [EBP-szBIH]
MOV EAX, ESI
PUSH ECX
CALL TStream.Read // read BIH
POP ECX
@@eread1:
XOR ECX, EAX
JNZ @@eread
MOVZX EAX, [EBP-szBIH].tBIH.biBitCount
MOVZX EDX, [EBP-szBIH].tBIH.biPlanes
MUL EDX
CALL Bits2PixelFormat
{$IFDEF PARANOIA} DB $3C, pf15bit {$ELSE} CMP AL, pf15bit {$ENDIF}
JNZ @@no15bit
CMP [EBP-szBIH].tBIH.biCompression, 0
JZ @@no15bit
INC AL // AL = pf16bit
@@no15bit:
MOV [EBX].fNewPixelFormat, AL
MOV EAX, szBIH + 1024
CALL System.@GetMem
MOV [EBX].fDIBHeader, EAX
XCHG EDX, EAX
LEA EAX, [EBP-szBIH]
XOR ECX, ECX
MOV CL, szBIH
CALL System.Move
MOV EAX, [EBP-szBIH].tBIH.biWidth
MOV [EBX].fWidth, EAX
MOV EAX, [EBP-szBIH].tBIH.biHeight
TEST EAX, EAX
JGE @@20
NEG EAX
@@20: MOV [EBX].fHeight, EAX
MOV EAX, EBX
CALL GetScanLineSize
MOV EDX, [EBX].fHeight
MUL EDX
MOV [EBX].fDIBSize, EAX
PUSH EAX
PUSH GMEM_FIXED or GMEM_ZEROINIT
CALL GlobalAlloc
MOV [EBX].fDIBBits, EAX
MOVZX EAX, [EBP-szBIH].tBIH.biBitCount
{$IFDEF PARANOIA} DB $3C, 8 {$ELSE} CMP AL, 8 {$ENDIF}
JA @@3
MOV AL, 4
MOVZX ECX, [EBP-szBIH].tBIH.biBitCount
SAL EAX, CL
XCHG ECX, EAX
@@3:
CMP [EBX].TBitmap.fNewPixelFormat, pf16bit
JNE @@30
XOR ECX, ECX
MOV CL, 12 // ColorCount = 12
@@30:
POP EAX // EAX = off
TEST EAX, EAX
JLE @@4
SUB EAX, szBFH + szBIH
CMP EAX, ECX
JZ @@4
XCHG ECX, EAX
@@4:
JECXZ @@5
PUSH ECX
MOV EDX, [EBX].fDIBHeader
ADD EDX, szBIH
MOV EAX, ESI
CALL TStream.Read
POP ECX
XOR EAX, ECX
JNZ @@eread
@@5:
MOV ECX, [EBX].fDIBSize
@@7:
PUSH ECX
MOV EAX, ESI
CALL TStream.GetPosition
PUSH EAX
MOV EAX, ESI
CALL TStream.GetSize
POP EDX
SUB EAX, EDX
POP ECX // Size = fDIBSize
CMP EAX, ECX // Strm.Size - Strm.Position > Size ?
JL @@8
XCHG ECX, EAX
@@8: // ++++++++++++++ 26-Oct-2003 VK see comment in Pascal
MOV EAX, [EBX].fDIBSize
CMP ECX, EAX
JGE @@9
SUB EAX, ECX
PUSH EAX
MOV EAX, ESI
PUSH ECX
CALL TStream.GetPosition
POP ECX
POP EDX
CMP EDX, EAX
JG @@9
MOV EAX, ESI
NEG EDX
XOR ECX, ECX
INC ECX
CALL TStream.Seek
MOV ECX, [EBX].fDIBSize
@@9: // ++++++++++++++
PUSH ECX
MOV EDX, [EBX].fDIBBits
MOV EAX, ESI
CALL TStream.Read
POP ECX
XOR EAX, ECX
POP EAX // Strm.Size - Position
POP ECX // fDIBSize
// end of reading bitmap
@@eread:
MOV ESP, EBP
POP EBP
POP EDX
JZ @@exit
// not success:
XCHG EAX, ESI
XOR ECX, ECX // ECX = spBegin
CALL TStream.Seek
XCHG EAX, EBX
CALL Clear
@@exit: POP ESI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.LoadFromStream(Strm: PStream);
type
TColorsArray = array[ 0..15 ] of TColor;
PColorsArray = ^TColorsArray;
PColor = ^TColor;
var Pos : DWORD;
BFH : TBitmapFileHeader;
function ReadBitmap : Boolean;
var Size, Size1: Integer;
BCH: TBitmapCoreHeader;
RGBSize: DWORD;
C: PColor;
Off, HdSz, ColorCount: DWORD;
//BFHValid: Boolean;
begin
fHandleType := bmDIB;
Result := False;
//BFHValid := FALSE;
if Strm.Read( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit;
Off := 0; Size := 0;
if BFH.bfType <> $4D42 then
Strm.Seek( Pos, spBegin )
else
begin
//BFHValid := TRUE;
Off := BFH.bfOffBits - Sizeof( BFH );
Size := BFH.bfSize; // don't matter, just <> 0 is good
end;
RGBSize := 4;
HdSz := Sizeof( TBitmapInfoHeader );
fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + HdSz );
if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( DWORD ) ) <> Sizeof( DWORD ) then
Exit;
if fDIBHeader.bmiHeader.biSize = HdSz then
begin
if Strm.Read( fDIBHeader.bmiHeader.biWidth, HdSz - Sizeof( DWORD ) ) <>
HdSz - Sizeof( DWORD ) then
Exit;
end
else
if fDIBHeader.bmiHeader.biSize = Sizeof( TBitmapCoreHeader ) then
begin
RGBSize := 3;
HdSz := Sizeof( TBitmapCoreHeader );
if Strm.Read( BCH.bcWidth, HdSz - Sizeof( DWORD ) ) <>
HdSz - Sizeof( DWORD ) then
Exit;
fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
fDIBHeader.bmiHeader.biWidth := BCH.bcWidth;
fDIBHeader.bmiHeader.biHeight := BCH.bcHeight;
fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes;
fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount;
end
else Exit;
fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount
* fDIBHeader.bmiHeader.biPlanes );
if (fNewPixelFormat = pf15bit) and (fDIBHeader.bmiHeader.biCompression <> BI_RGB) then
begin
ASSERT( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );
end;
fWidth := fDIBHeader.bmiHeader.biWidth;
ASSERT( fWidth > 0, 'Bitmap width must be > 0' );
fHeight := Abs(fDIBHeader.bmiHeader.biHeight);
ASSERT( fHeight > 0, 'Bitmap height must be > 0' );
fDIBSize := ScanLineSize * fHeight;
fDIBBits :=
Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, fDIBSize ) );
ASSERT( fDIBBits <> nil, 'No memory' );
ColorCount := 0;
if fDIBHeader.bmiHeader.biBitCount <= 8 then
begin
if fDIBHeader.bmiHeader.biClrUsed > 0 then
ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad )
else
ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad )
end
else if (fNewPixelFormat in [ pf16bit ]) or
(fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
ColorCount := 12;
if Off > 0 then
begin
Off := Off - HdSz;
if (Off <> ColorCount) then
if not(fNewPixelFormat in [pf15bit,pf16bit])
or (Off = 0) //+++ to fix loading 15- and 16-bit bmps with mask omitted
then
ColorCount := Min( 1024, Off );
end;
if ColorCount <> 0 then
begin
if Off >= ColorCount then
Off := Off - ColorCount;
if RGBSize = 4 then
begin
if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )
<> DWORD( ColorCount ) then Exit;
end
else
begin
C := @ fDIBHeader.bmiColors[ 0 ];
while ColorCount > 0 do
begin
if Strm.Read( C^, RGBSize ) <> RGBSize then Exit;
Dec( ColorCount, RGBSize );
Inc( C );
end;
end;
end;
if Off > 0 then
Strm.Seek( Off, spCurrent );
if (Size = 0) or (Strm.Size <= 0) then
Size := fDIBSize
else
Size := Min( fDIBSize, Strm.Size - Strm.Position );
Size1 := Min( Size, fDIBSize );
if (Size1 < fDIBSize)
and (DWORD( fDIBSize - Size1 ) <= Strm.Position) then
begin
Strm.Seek( Size1 - fDIBSize, spCurrent );
Size1 := fDIBSize;
end;
//if BFHValid and (Integer( Strm.Size - BFH.bfOffBits - Pos ) >= Integer( Size )) then
//if Strm.Position - Pos <= BFH.bfOffbits then
// Strm.Position := Pos + BFH.bfOffbits;
if Size1 > fDIBSize then Size1 := fDIBSize;
// +++++++++++++++++++ to fix some "incorrect" bitmaps while loading
if Strm.Read( fDIBBits^, Size1 ) <> DWORD( Size1 ) then Exit;
if Size > Size1 then
Strm.Seek( Size - Size1, spCurrent );
Result := True;
end;
begin
Clear;
Pos := Strm.Position;
if not ReadBitmap then
begin
Strm.Seek( Pos, spBegin );
Clear;
end;
end;
{$ENDIF ASM_VERSION}
////////////////// bitmap RLE-decoding and loading - by Vyacheslav A. Gavrik
//[procedure DecodeRLE4]
// by Vyacheslav A. Gavrik
procedure DecodeRLE4(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD);
procedure OddMove(Src,Dst:PByte;Size:Integer);
begin
if Size=0 then Exit;
repeat
Dst^:=(Dst^ and $F0)or(Src^ shr 4);
Inc(Dst);
Dst^:=(Dst^ and $0F)or(Src^ shl 4);
Inc(Src);
Dec(Size);
until Size=0;
end;
procedure OddFill(Mem:PByte;Size,Value:Integer);
begin
Value:=(Value shr 4)or(Value shl 4);
Mem^:=(Mem^ and $F0)or(Value and $0F);
Inc(Mem);
if Size>1 then FillChar(Mem^,Size,Char( Value ))
else Mem^:=(Mem^ and $0F)or(Value and $F0);
end;
var
pb: PByte;
x,y,z,i: Integer;
begin
pb:=Data; x:=0; y:=0;
if Bmp.fScanLineSize = 0 then
Bmp.ScanLineSize;
while (y Sizeof( BFH ) then Exit;
Off := 0; Size := 0;
ColorTriples := FALSE;
if BFH.bfType <> $4D42 then
begin
Strm.Seek( Pos, spBegin );
BFH.bfOffBits := 0;
BFH.bfSize := 0;
end
else
begin
BFHValid := TRUE;
Off := BFH.bfOffBits;
Size := BFH.bfSize;
end;
fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + sizeof(TBitmapInfoHeader) );
if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( fDIBHeader.bmiHeader.biSize ) ) <>
Sizeof( fDIBHeader.bmiHeader.biSize ) then Exit;
if (fDIBHeader.bmiHeader.biSize <> Sizeof( TBITMAPCOREHEADER )) and
(fDIBHeader.bmiHeader.biSize <> Sizeof( TBitmapInfoHeader )) then Exit;
L := fDIBHeader.bmiHeader.biSize - Sizeof( fDIBHeader.bmiHeader.biSize );
if (fDIBHeader.bmiHeader.biSize = Sizeof( TBITMAPCOREHEADER )) then
begin
if Strm.Read( BCH.bcWidth, L ) <> L then Exit;
fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
fDIBHeader.bmiHeader.biWidth := BCH.bcWidth;
fDIBHeader.bmiHeader.biHeight := BCH.bcHeight;
fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes;
fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount;
ColorTriples := TRUE;
end
else
begin
if Strm.Read( fDIBHeader.bmiHeader.biWidth, L) <> L then
Exit;
end;
fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount
* fDIBHeader.bmiHeader.biPlanes );
//if fNewPixelFormat = pf15bit then fNewPixelFormat := pf16bit;
fWidth := fDIBHeader.bmiHeader.biWidth;
ASSERT( fWidth > 0, 'Bitmap width must be > 0' );
fHeight := Abs(fDIBHeader.bmiHeader.biHeight);
ASSERT( fHeight > 0, 'Bitmap height must be > 0' );
fDIBSize := ScanLineSize * fHeight;
ZI := 0;
if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
(fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
ZI := GMEM_ZEROINIT;
fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED or ZI, fDIBSize + 4 ) );
ASSERT( fDIBBits <> nil, 'No memory' );
ASSERT( (fDIBHeader.bmiHeader.biCompression and
(BI_RLE8 or BI_RLE4 or BI_RLE8 or BI_BITFIELDS) <> 0) or
(fDIBHeader.bmiHeader.biCompression = BI_RGB),
'Unknown compression algorithm');
ColorCount := 0;
if fDIBHeader.bmiHeader.biBitCount <= 8 then
begin
if fDIBHeader.bmiHeader.biClrUsed > 0 then
ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad )
else
ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad )
end
else if (fNewPixelFormat in [ pf15bit, pf16bit ]) or
(fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
begin
if (Strm.Size = 0) or (Strm.Size - Strm.Position - DWORD( Size ) >= 12) then
ColorCount := 12;
end;
if ColorTriples then
ColorCount := ColorCount div 4 * 3;
if Off > 0 then
begin
Off := Off - SizeOf( TBitmapFileHeader ) - Sizeof( TBitmapInfoHeader );
if (Off <> ColorCount) and (fNewPixelFormat <= pf8bit) then
if ColorTriples then
ColorCount := min( Off, 3 * 256 )
else
ColorCount := min( Off, 4 * 256 );
end;
if (fNewPixelFormat in [ pf15bit, pf16bit ]) then
if (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
begin
PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := ( $00001F );
PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := ( $0007E0 );
TColor( fDIBHeader.bmiColors[ 0 ] ) := ( $00F800 );
end
else
begin
ColorCount := 0;
end;
if ColorCount <> 0 then
if ColorTriples then
begin
PColr := @ fDIBheader.bmiColors[ 0 ];
while ColorCount >= 3 do
begin
if strm.Read( PColr^, 3 ) <> 3 then Exit;
Inc( PColr );
Dec( ColorCount, 3 );
end;
end
else
begin
if (Integer( Strm.Size - Strm.Position ) > fDIBSize) or
(fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
(fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
begin
if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )
<> DWORD( ColorCount ) then Exit;
if Off - ColorCount > 0 then
Strm.Position := Integer( Strm.Position ) + Off - ColorCount;
end;
end;
if not BFHValid then
Size := fDIBSize
else
if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
(fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
begin
//if BFHValid then //-- already TRUE here
Size := BFH.bfSize - BFH.bfOffBits;
end
else
begin
if (Strm.Size = 0) or
(Integer( Strm.Size - BFH.bfOffBits - Pos ) > Integer(Size)) then
Size := fDIBSize
else
Size := Strm.Size - BFH.bfOffBits - DWORD( Pos );
if Size > fDIBSize then Size := fDIBSize
else if (Size < fDIBSize) and (fDIBheader.bmiHeader.biClrUsed <> 0) then
begin
BFHValid := FALSE;
Strm.Position := Strm.Position + fDIBheader.bmiHeader.biClrUsed * 4;
Size := Strm.Size - Strm.Position;
end;
end;
if (fDIBHeader.bmiHeader.biCompression = BI_RGB) or
(fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
begin
if BFHValid and
( (Strm.Size > 0) and
(Integer( Strm.Size - BFH.bfOffBits - Pos) > Integer(Size))
or
(Strm.Size = 0) and
(Off > 0)
) then
if Integer( Strm.Position - Pos ) <= Integer( BFH.bfOffbits ) then
Strm.Position := Pos + BFH.bfOffbits;
i := Strm.Read( fDIBBits^, Size );
if i <> Size then
begin
//Exit;
{$IFDEF FILL_BROKEN_BITMAP}
FillChar( Pointer( Integer( fDIBBits ) + i )^,
Size - i, #0 );
{$ENDIF FILL_BROKEN_BITMAP}
end;
end
else
begin
if (Integer( fDIBHeader.bmiHeader.biSizeImage ) > 0) and
(Integer( fDIBHeader.bmiHeader.biSizeImage ) < Size) then
Size := Integer( fDIBHeader.bmiHeader.biSizeImage ); // - ColorCount;
// it is possible that bitmap "compressed" with RLE has size
// greater then non-compressed one:
FinalPos := Strm.Position + DWORD( Size );
//Size := Size * 3;
L := Strm.Size - Strm.Position;
if L > DWORD( Size ) then
L := Size;
Buffer := AllocMem( Size * 3 );
if Strm.Read(Buffer^,L) <> DWORD( L ) then ; //Exit;
if fDIBHeader.bmiHeader.biCompression=BI_RLE8 then
DecodeRLE8(@Self,Buffer,Size * 3)
else
DecodeRLE4(@Self,Buffer,Size * 3);
Strm.Position := FinalPos;
fDIBHeader.bmiHeader.biCompression := BI_RGB;
FreeMem(Buffer);
end;
Result := True;
end;
begin
Clear;
Pos := Strm.Position;
result := ReadBitmap;
if not result then
begin
Strm.Seek( Pos, spBegin );
Clear;
end;
end;
///////////////////////////
//[function TBitmap.ReleaseHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.ReleaseHandle: HBitmap;
var OldBits: Pointer;
begin
HandleType := bmDIB;
Result := GetHandle;
if Result = 0 then Exit; // only when bitmap is empty
if fDIBAutoFree then
begin
OldBits := fDIBBits;
fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) );
Move( OldBits^, fDIBBits^, fDIBSize );
fDIBAutoFree := FALSE;
end;
fHandle := 0;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.SaveToFile]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SaveToFile(const Filename: KOLString);
var Strm: PStream;
begin
if Empty then Exit;
Strm := NewWritefileStream( Filename );
SaveToStream( Strm );
Strm.Free;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.SaveToStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SaveToStream(Strm: PStream);
var BFH : TBitmapFileHeader;
Pos : Integer;
function WriteBitmap : Boolean;
var ColorsSize, BitsSize, Size : Integer;
begin
Result := False;
if Empty then Exit;
HandleType := bmDIB; // convert to DIB if DDB
FillChar( BFH, Sizeof( BFH ), 0 );
ColorsSize := 0;
with fDIBHeader.bmiHeader do
if biBitCount <= 8 then
ColorsSize := (1 shl biBitCount) * Sizeof( TRGBQuad );
BFH.bfOffBits := Sizeof( BFH ) + Sizeof( TBitmapInfoHeader ) + ColorsSize;
BitsSize := fDIBSize; //ScanLineSize * fHeight;
BFH.bfSize := BFH.bfOffBits + DWord( BitsSize );
BFH.bfType := $4D42; // 'BM';
if fDIBHeader.bmiHeader.biCompression <> 0 then
begin
ColorsSize := 12 + 16*sizeof(TRGBQuad);
Inc( BFH.bfOffBits, ColorsSize );
end;
if Strm.Write( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit;
Size := Sizeof( TBitmapInfoHeader ) + ColorsSize;
if Strm.Write( fDIBHeader^, Size ) <> DWORD(Size) then Exit;
if Strm.Write( fDIBBits^, BitsSize ) <> DWord( BitsSize ) then Exit;
Result := True;
end;
begin
Pos := Strm.Position;
if not WriteBitmap then
Strm.Seek( Pos, spBegin );
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.SetHandle]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetHandle(const Value: HBitmap);
var B: tagBitmap;
Dib: TDIBSection;
begin
Clear;
if Value = 0 then Exit;
if (WinVer >= wvNT) and
(GetObject( Value, Sizeof( Dib ), @ Dib ) = Sizeof( Dib )) then
begin
fHandle := Value;
fHandleType := bmDIB;
fDIBHeader := PrepareBitmapHeader( Dib.dsBm.bmWidth, Dib.dsBm.bmHeight,
Dib.dsBm.bmBitsPixel );
Move( Dib.dsBitfields, fDIBHeader.bmiColors, 3 * 4 );
fWidth := Dib.dsBm.bmWidth;
fHeight := Dib.dsBm.bmHeight;
fDIBBits := Dib.dsBm.bmBits;
fDIBSize := Dib.dsBmih.biSizeImage;
fDIBAutoFree := true;
{$ifdef wince}
if fDIBBits = nil then
HandleType:=bmDDB;
{$endif wince}
end
else
begin
if GetObject( Value, Sizeof( B ), @B ) = 0 then Exit;
fHandle := Value;
fWidth := B.bmWidth;
fHeight := B.bmHeight;
fHandleType := bmDDB;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.SetWidth]
procedure TBitmap.SetWidth(const Value: Integer);
begin
if fWidth = Value then Exit;
fWidth := Value;
FormatChanged;
end;
//[procedure TBitmap.SetHeight]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetHeight(const Value: Integer);
begin
if fHeight = Value then Exit;
HandleType := bmDDB;
// Not too good, but provides correct changing of height
// preserving previous image
fHeight := Value;
FormatChanged;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.SetPixelFormat]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
begin
if PixelFormat = Value then Exit;
if Empty then Exit;
if Value = pfDevice then
HandleType := bmDDB
else
begin
fNewPixelFormat := Value;
fHandleType := bmDIB;
FormatChanged;
end;
end;
{$ENDIF ASM_VERSION}
//[FUNCTION CalcScanLineSize]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;
begin
Result := ((Header.biBitCount * Header.biWidth + 31) shr 3) and $FFFFFFFC;
end;
{$ENDIF ASM_VERSION}
//[END CalcScanLineSize]
//[PROCEDURE FillBmpWithBkColor]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer );
var oldBmp: HBitmap;
R: TRect;
Br: HBrush;
begin
with Bmp{-}^{+} do
if Color2RGB( fBkColor ) <> 0 then
if (oldWidth < fWidth) or (oldHeight < fHeight) then
if GetHandle <> 0 then
begin
oldBmp := SelectObject( DC2, fHandle );
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
Br := CreateSolidBrush( Color2RGB( fBkColor ) );
R := MakeRect( oldWidth, oldHeight, fWidth, fHeight );
if oldWidth = fWidth then
R.Left := 0;
if oldHeight = fHeight then
R.Top := 0;
Windows.FillRect( DC2, R, Br );
DeleteObject( Br );
SelectObject( DC2, oldBmp );
end;
end;
{$ENDIF ASM_VERSION}
//[END FillBmpWithBkColor]
const BitCounts: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
//[procedure TBitmap.FormatChanged]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.FormatChanged;
// This method is used whenever Width, Height, PixelFormat or HandleType
// properties are changed.
// Old image will be drawn here to a new one (excluding cases when
// old width or height was 0, and / or new width or height is 0).
// To avoid inserting this code into executable, try not to change
// properties Width / Height of bitmat after it is created using
// NewBitmap( W, H ) function or after it is loaded from file, stream
// or resource.
var B: tagBitmap;
oldBmp, NewHandle: HBitmap;
DC0, DC2: HDC;
oldHeight, oldWidth: Integer;
Br: HBrush;
NewHeader: PBitmapInfo;
NewBits: Pointer;
sizeBits, bitsPixel: Integer;
NewDIBAutoFree: Boolean;
{$ifndef wince}
N: Integer;
Hndl: THandle;
{$endif wince}
begin
if Empty then Exit;
{$ifndef wince}
NewDIBAutoFree := FALSE;
{$endif wince}
fDetachCanvas( @Self );
fScanLineSize := 0;
fGetDIBPixels := nil;
fSetDIBPixels := nil;
oldWidth := fWidth;
oldHeight := fHeight;
if fDIBBits <> nil then
begin
oldWidth := fDIBHeader.bmiHeader.biWidth;
oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);
end
else
if fHandle <> 0 then
begin
if GetObject( fHandle, Sizeof( B ), @ B ) <> 0 then
begin
oldWidth := B.bmWidth;
oldHeight := B.bmHeight;
end;
end;
DC2 := CreateCompatibleDC( 0 );
if fHandleType = bmDDB then
begin
// New HandleType is bmDDB: old bitmap can be copied using Draw method
DC0 := GetDC( 0 );
NewHandle := CreateCompatibleBitmap( DC0, fWidth, fHeight );
ASSERT( NewHandle <> 0, 'Can not create DDB' );
ReleaseDC( 0, DC0 );
oldBmp := SelectObject( DC2, NewHandle );
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
Br := CreateSolidBrush( Color2RGB( fBkColor ) );
FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br );
DeleteObject( Br );
{$ifdef win32}
if fDIBBits <> nil then
begin
SelectObject( DC2, oldBmp );
SetDIBits( DC2, NewHandle, 0, fHeight, fDIBBits, fDIBHeader^, DIB_RGB_COLORS );
end
else
{$endif win32}
begin
Draw( DC2, 0, 0 );
SelectObject( DC2, oldBmp );
end;
ClearData; // Image is cleared but fWidth and fHeight are preserved
fHandle := NewHandle;
end
else
begin
// New format is DIB. GetDIBits applied to transform old data to new one.
if fNewPixelFormat = pfDevice then
bitsPixel := GetDeviceCaps( DC2, Windows.BITSPIXEL )*GetDeviceCaps( DC2, PLANES )
else
bitsPixel := BitCounts[ fNewPixelFormat ];
if bitsPixel = 0 then
bitsPixel := BitCounts[DefaultPixelFormat];
NewHandle := 0;
NewHeader := PrepareBitmapHeader( fWidth, fHeight, bitsPixel );
if bitsPixel = 16 then
PreparePF16bit( NewHeader );
sizeBits := CalcScanLineSize( @NewHeader.bmiHeader ) * fHeight;
{$ifndef wince}
NewBits := Pointer( GlobalAlloc( GMEM_FIXED, sizeBits ) );
ASSERT( NewBits <> nil, 'No memory' );
Hndl := GetHandle;
if Hndl = 0 then Exit;
N :=
GetDIBits( DC2, Hndl, 0, Min( fHeight, oldHeight ),
NewBits, NewHeader^, DIB_RGB_COLORS );
if N <> Min( fHeight, oldHeight ) then
begin
GlobalFree( DWORD( NewBits ) );
{$endif wince}
NewBits := nil;
NewHandle := CreateDIBSection( DC2, NewHeader^, DIB_RGB_COLORS, NewBits, 0, 0 );
NewDIBAutoFree := TRUE;
ASSERT( NewHandle <> 0, 'Can not create DIB secion for pf16bit bitmap' );
oldBmp := SelectObject( DC2, NewHandle );
ASSERT( oldBmp <> 0, 'Can not select pf16bit to DC' );
Draw( DC2, 0, 0 );
SelectObject( DC2, oldBmp );
{$ifndef wince}
end;
{$endif wince}
ClearData;
fDIBSize := sizeBits;
fDIBBits := NewBits;
fDIBHeader := NewHeader;
fHandle := NewHandle;
fDIBAutoFree := NewDIBAutoFree;
end;
if Assigned( fFillWithBkColor ) then
fFillWithBkColor( @Self, DC2, oldWidth, oldHeight );
DeleteDC( DC2 );
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.GetScanLine]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetScanLine(Y: Integer): Pointer;
begin
ASSERT( (Y >= 0) {and (Y < fHeight)}, 'ScanLine index out of bounds' );
ASSERT( fDIBBits <> nil, 'No bits available' );
Result := nil;
if fDIBHeader = nil then Exit;
if fDIBHeader.bmiHeader.biHeight > 0 then
Y := fHeight - 1 - Y;
if fScanLineSize = 0 then
ScanLineSize;
Result := Pointer( cardinal( fDIBBits ) + cardinal(fScanLineSize * Y) );
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.GetScanLineSize]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetScanLineSize: Integer;
begin
Result := 0;
if fDIBHeader = nil then Exit;
FScanLineSize := CalcScanLineSize( @fDIBHeader.bmiHeader );
Result := FScanLineSize;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.CanvasChanged]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.CanvasChanged( Sender : PObj );
begin
fBkColor := PCanvas( Sender ).Brush.Color;
ClearTransImage;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.Dormant]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.Dormant;
begin
RemoveCanvas;
if fHandle <> 0 then
DeleteObject( ReleaseHandle );
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.SetBkColor]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetBkColor(const Value: TColor);
begin
if fBkColor = Value then Exit;
fBkColor := Value;
fFillWithBkColor := FillBmpWithBkColor;
if Assigned( fApplyBkColor2Canvas ) then
fApplyBkColor2Canvas( @Self );
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.Assign]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.Assign(SrcBmp: PBitmap): Boolean;
{$ifdef wince}
var
DC: HDC;
OldBmp: HBITMAP;
{$endif wince}
begin
Clear;
Result := False;
if SrcBmp = nil then Exit;
if SrcBmp.Empty then Exit;
fWidth := SrcBmp.fWidth;
fHeight := SrcBmp.fHeight;
fHandleType := SrcBmp.fHandleType;
if SrcBmp.fHandleType = bmDDB then
begin
{$ifdef wince}
DC := GetDC( 0 );
fHandle := CreateCompatibleBitmap( DC, fWidth, fHeight );
ReleaseDC( 0, DC );
DC:=CreateCompatibleDC(0);
OldBmp:=SelectObject(DC, fHandle);
SrcBmp.Draw(DC, 0, 0);
SelectObject(DC, OldBmp);
DeleteDC(DC);
{$else}
fHandle := CopyImage( SrcBmp.fHandle, IMAGE_BITMAP, 0, 0, 0 {LR_COPYRETURNORG} );
ASSERT( fHandle <> 0, 'Can not copy bitmap image' );
{$endif wince}
Result := fHandle <> 0;
if not Result then Clear;
end
else
begin
GetMem( fDIBHeader, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );
ASSERT( fDIBHeader <> nil, 'No memory' );
Move( SrcBmp.fDIBHeader^, fDIBHeader^, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );
fDIBSize := SrcBmp.fDIBSize;
fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) );
ASSERT( fDIBBits <> nil, 'No memory' );
Move( SrcBmp.fDIBBits^, fDIBBits^, fDIBSize );
Result := True;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.RemoveCanvas]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.RemoveCanvas;
begin
fDetachCanvas( @Self );
fCanvas.Free;
fCanvas := nil;
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.DIBPalNearestEntry]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.DIBPalNearestEntry(Color: TColor): Integer;
var I, Diff, D: Integer;
C : Integer;
begin
Color := TColor( Color2RGBQuad( Color ) );
Result := 0;
Diff := MaxInt;
for I := 0 to DIBPalEntryCount - 1 do
begin
C := Color xor PInteger( cardinal( @fDIBHeader.bmiColors[ 0 ] )
+ cardinal(I * Sizeof( TRGBQuad )) )^;
D := TRGBQuad( C ).rgbBlue + TRGBQuad( C ).rgbGreen + TRGBQuad( C ).rgbRed;
if D < Diff then
begin
Diff := D;
Result := I;
end;
end;
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.GetDIBPalEntries]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetDIBPalEntries(Idx: Integer): TColor;
begin
Result := TColor(-1);
if fDIBBits = nil then Exit;
ASSERT( PixelFormat in [pf1bit..pf8bit], 'Format has no DIB palette entries available' );
ASSERT( (Idx >= 0) and (Idx < (1 shl fDIBHeader.bmiHeader.biBitCount)),
'DIB palette index out of bounds' );
Result := PDWORD( cardinal( @fDIBHeader.bmiColors[ 0 ] )
+ cardinal(Idx * Sizeof( TRGBQuad ) ))^;
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.GetDIBPalEntryCount]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetDIBPalEntryCount: Integer;
begin
Result := 0;
if Empty then Exit;
case PixelFormat of
pf1bit: Result := 2;
pf4bit: Result := 16;
pf8bit: Result := 256;
else;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.SetDIBPalEntries]
procedure TBitmap.SetDIBPalEntries(Idx: Integer; const Value: TColor);
begin
if fDIBBits = nil then Exit;
Dormant;
PDWORD( cardinal( @fDIBHeader.bmiColors[ 0 ] )
+ cardinal(Idx * Sizeof( TRGBQuad )) )^ := Color2RGB( Value );
end;
//[procedure TBitmap.SetHandleType]
procedure TBitmap.SetHandleType(const Value: TBitmapHandleType);
begin
if fHandleType = Value then Exit;
fHandleType := Value;
FormatChanged;
end;
//[function TBitmap.GetPixelFormat]
function TBitmap.GetPixelFormat: TPixelFormat;
begin
if (HandleType = bmDDB) or (fDIBBits = nil) then
Result := pfDevice
else
begin
Result := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount );
if fDIBHeader.bmiHeader.biCompression <> 0 then
begin
Assert( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );
if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $F800) and
(PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $7E0) and
(PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then
Result := pf16bit
else
if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $7C00) and
(PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $3E0) and
(PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then
Result := pf15bit
else
Result := pfCustom;
end;
end;
end;
//[procedure TBitmap.ClearTransImage]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.ClearTransImage;
begin
fTransColor := clNone;
fTransMaskBmp.Free;
fTransMaskBmp := nil;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.Convert2Mask]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
{$IFDEF USE_OLDCONVERT2MASK}
procedure TBitmap.Convert2Mask(TranspColor: TColor);
var MonoHandle: HBitmap;
SaveMono, SaveFrom: THandle;
MonoDC, {DC0,} DCfrom: HDC;
SaveBkColor: TColorRef;
begin
if GetHandle = 0 then Exit;
fDetachCanvas( @Self );
///DC0 := GetDC( 0 );
MonoHandle := CreateBitmap( fWidth, fHeight, 1, 1, nil );
ASSERT( MonoHandle <> 0, 'Can not create monochrome bitmap' );
MonoDC := CreateCompatibleDC( 0 );
SaveMono := SelectObject( MonoDC, MonoHandle );
ASSERT( SaveMono <> 0, 'Can not select bitmap to DC' );
DCfrom := CreateCompatibleDC( 0 );
SaveFrom := SelectObject( DCfrom, fHandle );
ASSERT( SaveFrom <> 0, 'Can not select source bitmap to DC' );
TranspColor := Color2RGB( TranspColor );
SaveBkColor := Windows.SetBkColor( DCfrom, TranspColor );
BitBlt( MonoDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, SRCCOPY );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
Windows.SetBkColor( DCfrom, SaveBkColor );
SelectObject( DCfrom, SaveFrom );
DeleteDC( DCfrom );
SelectObject( MonoDC, SaveMono );
DeleteDC( MonoDC );
///ReleaseDC( 0, DC0 );
ClearData;
fHandle := MonoHandle;
fHandleType := bmDDB;
end;
{$ELSE NOT USE_OLDCONVERT2MASK} //Pascal
procedure TBitmap.Convert2Mask(TranspColor: TColor);
var Y, X, i: Integer;
Src, Dst: PByte;
W: Word;
TmpMsk: PBitmap;
B, C: Byte;
TranspColor32: TColor;
begin
HandleType := bmDIB;
if PixelFormat < pf4bit then
PixelFormat := pf4bit;
if PixelFormat > pf32bit then
PixelFormat := pf32bit;
TranspColor := Color2RGB( TranspColor ) and $FFFFFF;
TranspColor32 := TColor( Color2RGBQuad( TranspColor ) );
TmpMsk := NewDIBBitmap( fWidth, fHeight, pf1bit );
TmpMsk.DIBPalEntries[ 1 ] := $FFFFFF;
for Y := 0 to fHeight-1 do
begin
Src := ScanLine[ Y ];
Dst := TmpMsk.ScanLine[ Y ];
B := 0; C := 8;
CASE PixelFormat OF
pf4bit:
begin
W := 16;
for i := 0 to 15 do
if DIBPalEntries[ i ] = TranspColor32 then
begin
W := i; break;
end;
for X := 0 to (fWidth div 2)-1 do
begin
B := B shl 1;
if Src^ shr 4 = W then inc( B );
B := B shl 1;
if Src^ and $0F = W then inc( B );
Inc( Src );
Dec( C, 2 );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf8bit:
begin
W := 256;
for i := 0 to 255 do
if DIBPalEntries[ i ] = TranspColor32 then
begin
W := i; break;
end;
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if Src^ = W then inc( B );
Inc( Src );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf15bit:
begin
W := Color2Color15( TranspColor );
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if PWord( Src )^ = W then inc( B );
Inc( Src, 2 );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf16bit:
begin
W := Color2Color16( TranspColor );
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if PWord( Src )^ = W then inc( B );
Inc( Src, 2 );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf24bit:
begin
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B );
Inc( Src, 3 );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf32bit:
begin
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B );
Inc( Src, 4 );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
END;
if (C > 0) and (C < 8) then
begin
while C > 0 do
begin
B := B shl 1;
dec( C );
end;
Dst^ := B;
end;
end;
Assign( TmpMsk );
TmpMsk.Free;
end;
{$ENDIF USE_OLDCONVERT2MASK} //Pascal
{$ENDIF ASM_VERSION}
//[procedure TBitmap.Invert]
procedure TBitmap.Invert;
var R: TRect;
begin
//BitBlt( Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, DSTINVERT )
R := BoundsRect;
InvertRect(Canvas.Handle, R);
end;
//[procedure TBitmap.DIBDrawRect]
procedure TBitmap.DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect );
begin
if fDIBBits = nil then Exit;
StretchDIBits( DC, X, Y, R.Right - R.Left, R.Bottom - R.Top,
R.Left, fHeight - R.Bottom, R.Right - R.Left, R.Bottom - R.Top,
fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY );
end;
//[PROCEDURE _RotateBitmapMono]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Z, Shf, Wbytes, BytesPerDstLine: Integer;
Src, Dst, Dst1: PByte;
Tmp: Byte;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 7) and not 7, pf1bit );
Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 2 * Sizeof( TRGBQuad ) );
// Calculate ones:
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
Wbytes := (SrcBmp.fWidth + 7) shr 3;
Inc( Dst, (DstBmp.fWidth - 1) shr 3 );
Shf := (DstBmp.fWidth - 1) and 7;
// Rotating bits:
for Y := 0 to SrcBmp.fHeight - 1 do
begin
Src := SrcBmp.ScanLine[ Y ];
Dst1 := Dst;
for X := Wbytes downto 1 do
begin
Tmp := Src^;
Inc( Src );
for Z := 8 downto 1 do
begin
Dst1^ := Dst1^ or ( (Tmp and $80) shr Shf );
Tmp := Tmp shl 1;
Inc( Dst1, BytesPerDstLine );
end;
end;
Dec( Shf );
if Shf < 0 then
begin
Shf := 7;
Dec( Dst );
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END _RotateBitmapMono]
//[PROCEDURE _RotateBitmap4bit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Shf, Wbytes, BytesPerDstLine: Integer;
Src, Dst, Dst1: PByte;
Tmp: Byte;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 1) and not 1, pf4bit );
Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 16 * Sizeof( TRGBQuad ) );
// Calculate ones:
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
Wbytes := (SrcBmp.fWidth + 1) shr 1;
Inc( Dst, (DstBmp.fWidth - 1) shr 1 );
Shf := ((DstBmp.fWidth - 1) and 1) shl 2;
// Rotating bits:
for Y := 0 to SrcBmp.fHeight - 1 do
begin
Src := SrcBmp.ScanLine[ Y ];
Dst1 := Dst;
for X := Wbytes downto 1 do
begin
Tmp := Src^;
Inc( Src );
Dst1^ := Dst1^ or ( (Tmp and $F0) shr Shf );
Inc( Dst1, BytesPerDstLine );
Dst1^ := Dst1^ or ( ((Tmp shl 4) and $F0) shr Shf );
Inc( Dst1, BytesPerDstLine );
end;
Dec( Shf, 4 );
if Shf < 0 then
begin
Shf := 4;
Dec( Dst );
end;
end;
end;
{$ENDIF ASM_VERSION}
//[END _RotateBitmap4bit]
//[PROCEDURE _RotateBitmap8bit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Wbytes, BytesPerDstLine: Integer;
Src, Dst, Dst1: PByte;
Tmp: Byte;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 256 * Sizeof( TRGBQuad ) );
// Calculate ones:
Wbytes := SrcBmp.fWidth;
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
Inc( Dst, DstBmp.fWidth - 1 );
// Rotating bits:
for Y := 0 to SrcBmp.fHeight - 1 do
begin
Src := SrcBmp.ScanLine[ Y ];
Dst1 := Dst;
for X := Wbytes downto 1 do
begin
Tmp := Src^;
Inc( Src );
Dst1^ := Tmp;
Inc( Dst1, BytesPerDstLine );
end;
Dec( Dst );
end;
end;
{$ENDIF ASM_VERSION}
//[END _RotateBitmap8bit]
//[PROCEDURE _RotateBitmap16bit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Wwords, BytesPerDstLine: Integer;
Src, Dst, Dst1: PWord;
Tmp: Word;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
Wwords := SrcBmp.fWidth;
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
Inc( Dst, DstBmp.fWidth - 1 );
// Rotating bits:
for Y := 0 to SrcBmp.fHeight - 1 do
begin
Src := SrcBmp.ScanLine[ Y ];
Dst1 := Dst;
for X := Wwords downto 1 do
begin
Tmp := Src^;
Inc( Src );
Dst1^ := Tmp;
Inc( PByte(Dst1), BytesPerDstLine );
end;
Dec( Dst );
end;
end;
{$ENDIF ASM_VERSION}
//[END _RotateBitmap16bit]
//[PROCEDURE _RotateBitmap2432bit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Wwords, BytesPerDstLine, IncW: Integer;
Src, Dst, Dst1: PDWord;
Tmp: DWord;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
// Calculate ones:
IncW := 4;
if DstBmp.PixelFormat = pf24bit then
IncW := 3;
Wwords := SrcBmp.fWidth;
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
Inc( PByte(Dst), (DstBmp.fWidth - 1) * IncW );
// Rotating bits:
for Y := 0 to SrcBmp.fHeight - 1 do
begin
Src := SrcBmp.ScanLine[ Y ];
Dst1 := Dst;
for X := Wwords downto 1 do
begin
Tmp := Src^ and $FFFFFF;
Inc( PByte(Src), IncW );
Dst1^ := Dst1^ or Tmp;
Inc( PByte(Dst1), BytesPerDstLine );
end;
Dec( PByte(Dst), IncW );
end;
end;
{$ENDIF ASM_VERSION}
//[END _RotateBitmap2432bit]
type
TRotateBmpRefs = {$ifndef wince}packed{$endif} record
proc_RotateBitmapMono: procedure( var Dst: PBitmap; Src: PBitmap );
proc_RotateBitmap4bit: procedure( var Dst: PBitmap; Src: PBitmap );
proc_RotateBitmap8bit: procedure( var Dst: PBitmap; Src: PBitmap );
proc_RotateBitmap16bit: procedure( var Dst: PBitmap; Src: PBitmap );
proc_RotateBitmap2432bit: procedure( var Dst: PBitmap; Src: PBitmap );
end;
var
RotateProcs: TRotateBmpRefs;
//[PROCEDURE _RotateBitmapRight]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmapRight( SrcBmp: PBitmap );
var DstBmp: PBitmap;
RotateProc: procedure( var DstBmp: PBitmap; SrcBmp: PBitmap );
begin
if SrcBmp.fHandleType <> bmDIB then Exit;
case SrcBmp.PixelFormat of
pf1bit: RotateProc := RotateProcs.proc_RotateBitmapMono;
pf4bit: RotateProc := RotateProcs.proc_RotateBitmap4bit;
pf8bit: RotateProc := RotateProcs.proc_RotateBitmap8bit;
pf15bit, pf16bit: RotateProc := RotateProcs.proc_RotateBitmap16bit;
else RotateProc := RotateProcs.proc_RotateBitmap2432bit;
end;
if not Assigned( RotateProc ) then Exit;
RotateProc( DstBmp, SrcBmp );
if DstBmp.fHeight > SrcBmp.fWidth then
begin
DstBmp.fDIBSize := DstBmp.fScanLineSize * SrcBmp.fWidth;
if DstBmp.fDIBHeader.bmiHeader.biHeight > 0 then
Move( DstBmp.ScanLine[ SrcBmp.fWidth - 1 ]^, DstBmp.ScanLine[ DstBmp.fHeight - 1 ]^,
DstBmp.fDIBSize );
DstBmp.fHeight := SrcBmp.fWidth;
DstBmp.fDIBHeader.bmiHeader.biHeight := DstBmp.fHeight;
end;
SrcBmp.ClearData;
SrcBmp.fDIBHeader := DstBmp.fDIBHeader;
DstBmp.fDIBHeader := nil;
SrcBmp.fDIBBits := DstBmp.fDIBBits;
DstBmp.fDIBBits := nil;
SrcBmp.fDIBAutoFree := DstBmp.fDIBAutoFree;
SrcBmp.fDIBSize := DstBmp.fDIBSize;
SrcBmp.fWidth := DstBmp.fWidth;
SrcBmp.fHeight := DstBmp.fHeight;
DstBmp.Free;
end;
{$ENDIF ASM_VERSION}
//[END _RotateBitmapRight]
//[procedure TBitmap.RotateRight]
procedure TBitmap.RotateRight;
const AllRotators: TRotateBmpRefs = (
proc_RotateBitmapMono: _RotateBitmapMono;
proc_RotateBitmap4bit: _RotateBitmap4bit;
proc_RotateBitmap8bit: _RotateBitmap8bit;
proc_RotateBitmap16bit: _RotateBitmap16bit;
proc_RotateBitmap2432bit: _RotateBitmap2432bit );
begin
RotateProcs := AllRotators;
_RotateBitmapRight( @Self );
end;
//[procedure _RotateBitmapLeft]
procedure _RotateBitmapLeft( Src: PBitmap );
begin
_RotateBitmapRight( Src );
_RotateBitmapRight( Src );
_RotateBitmapRight( Src );
end;
//[procedure TBitmap.RotateLeft]
procedure TBitmap.RotateLeft;
begin
RotateRight;
_RotateBitmapRight( @Self );
_RotateBitmapRight( @Self );
end;
//[procedure TBitmap.RotateLeftMono]
procedure TBitmap.RotateLeftMono;
begin
if PixelFormat <> pf1bit then Exit;
RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono;
_RotateBitmapRight( @Self );
end;
//[procedure TBitmap.RotateRightMono]
procedure TBitmap.RotateRightMono;
begin
if PixelFormat <> pf1bit then Exit;
RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono;
_RotateBitmapLeft( @Self );
end;
//[procedure TBitmap.RotateLeft16bit]
procedure TBitmap.RotateLeft16bit;
begin
if PixelFormat <> pf16bit then Exit;
RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit;
_RotateBitmapLeft( @Self );
end;
//[procedure TBitmap.RotateLeft4bit]
procedure TBitmap.RotateLeft4bit;
begin
if PixelFormat <> pf4bit then Exit;
RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit;
_RotateBitmapLeft( @Self );
end;
//[procedure TBitmap.RotateLeft8bit]
procedure TBitmap.RotateLeft8bit;
begin
if PixelFormat <> pf8bit then Exit;
RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit;
_RotateBitmapLeft( @Self );
end;
//[procedure TBitmap.RotateLeftTrueColor]
procedure TBitmap.RotateLeftTrueColor;
begin
if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit;
RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit;
_RotateBitmapLeft( @Self );
end;
//[procedure TBitmap.RotateRight16bit]
procedure TBitmap.RotateRight16bit;
begin
if PixelFormat <> pf16bit then Exit;
RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit;
_RotateBitmapRight( @Self );
end;
//[procedure TBitmap.RotateRight4bit]
procedure TBitmap.RotateRight4bit;
begin
if PixelFormat <> pf4bit then Exit;
RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit;
_RotateBitmapRight( @Self );
end;
//[procedure TBitmap.RotateRight8bit]
procedure TBitmap.RotateRight8bit;
begin
if PixelFormat <> pf8bit then Exit;
RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit;
_RotateBitmapRight( @Self );
end;
//[procedure TBitmap.RotateRightTrueColor]
procedure TBitmap.RotateRightTrueColor;
begin
if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit;
RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit;
_RotateBitmapRight( @Self );
end;
//[function TBitmap.GetPixels]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetPixels(X, Y: Integer): TColor;
var DC: HDC;
Save: THandle;
begin
Result := clNone;
//if GetHandle = 0 then Exit;
if Empty then Exit;
fDetachCanvas( @Self );
DC := CreateCompatibleDC( 0 );
Save := SelectObject( DC, GetHandle );
ASSERT( Save <> 0, 'Can not select bitmap to DC' );
Result := Windows.GetPixel( DC, X, Y );
SelectObject( DC, Save );
DeleteDC( DC );
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.SetPixels]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetPixels(X, Y: Integer; const Value: TColor);
var DC: HDC;
Save: THandle;
begin
//if GetHandle = 0 then Exit;
if Empty then Exit;
fDetachCanvas( @Self );
DC := CreateCompatibleDC( 0 );
Save := SelectObject( DC, GetHandle );
ASSERT( Save <> 0, 'Can not select bitmap to DC' );
Windows.SetPixel( DC, X, Y, Color2RGB( Value ) );
SelectObject( DC, Save );
DeleteDC( DC );
end;
{$ENDIF ASM_VERSION}
//[FUNCTION _GetDIBPixelsPalIdx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function _GetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer ): TColor;
var Pixel: Byte;
begin
Pixel := PByte( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta
+ (X div (Bmp.fPixelsPerByteMask + 1))) )^;
Pixel := ( Pixel shr ( (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask))
* Bmp.fDIBHeader.bmiHeader.biBitCount ) )
and Bmp.fPixelMask;
Result := TColor( Color2RGBQuad( TColor( PRGBQuad( DWORD(@Bmp.fDIBHeader.bmiColors[ 0 ])
+ DWORD(Pixel) * Sizeof( TRGBQuad ) )^ ) ) );
end;
{$ENDIF ASM_VERSION}
//[END _GetDIBPixelsPalIdx]
//[FUNCTION _GetDIBPixels16bit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function _GetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer ): TColor;
var Pixel: Word;
begin
Pixel := PWord( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta + X * 2) )^;
if Bmp.fPixelMask = 15 then
Result := (Pixel shr 7) and $F8 or (Pixel shl 6) and $F800
or (Pixel shl 19) and $F80000
else
Result := (Pixel shr 8) and $F8 or (Pixel shl 5) and $FC00
or (Pixel shl 19) and $F80000;
end;
{$ENDIF ASM_VERSION}
//[END _GetDIBPixels16bit]
//[FUNCTION _GetDIBPixelsTrueColor]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function _GetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer ): TColor;
var Pixel: DWORD;
begin
Pixel := PDWORD( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta +
X * Bmp.fBytesPerPixel) )^ and $FFFFFF;
Result := TColor( Color2RGBQuad( TColor( Pixel ) ) );
end;
{$ENDIF ASM_VERSION}
//[END _GetDIBPixelsTrueColor]
//[function TBitmap.GetDIBPixels]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetDIBPixels(X, Y: Integer): TColor;
begin
if not Assigned( fGetDIBPixels ) then
begin
if fHandleType = bmDIB then
begin
fScanLine0 := ScanLine[ 0 ];
fScanLineDelta := cardinal(ScanLine[ 1 ]) - cardinal(fScanLine0);
case PixelFormat of
pf1bit:
begin
fPixelMask := $01;
fPixelsPerByteMask := 7;
fGetDIBPixels := _GetDIBPixelsPalIdx;
end;
pf4bit:
begin
fPixelMask := $0F;
fPixelsPerByteMask := 1;
fGetDIBPixels := _GetDIBPixelsPalIdx;
end;
pf8bit:
begin
fPixelMask := $FF;
fPixelsPerByteMask := 0;
fGetDIBPixels := _GetDIBPixelsPalIdx;
end;
pf15bit:
begin
fPixelMask := 15;
fGetDIBPixels := _GetDIBPixels16bit;
end;
pf16bit:
begin
fPixelMask := 16;
fGetDIBPixels := _GetDIBPixels16bit;
end;
pf24bit:
begin
fPixelsPerByteMask := 0;
fBytesPerPixel := 3;
fGetDIBPixels := _GetDIBPixelsTrueColor;
end;
pf32bit:
begin
fPixelsPerByteMask := 1;
fBytesPerPixel := 4;
fGetDIBPixels := _GetDIBPixelsTrueColor;
end;
else;
end;
end;
if not Assigned( fGetDIBPixels ) then
begin
Result := Pixels[ X, Y ];
Exit;
end;
end;
Result := fGetDIBPixels( @Self, X, Y );
end;
{$ENDIF ASM_VERSION}
//[PROCEDURE _SetDIBPixels1bit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );
var Pixel: Byte;
Pos: PByte;
Shf: Integer;
begin
Value := Color2RGB( Value );
if ((Value shr 16) and $FF) + ((Value shr 8) and $FF) + (Value and $FF)
< 255 * 3 div 2 then Pixel := 0 else Pixel := $80;
Pos := PByte( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta + X div 8) );
Shf := X and 7;
Pos^ := Pos^ and ($FF7F shr Shf) or (Pixel shr Shf);
end;
{$ENDIF ASM_VERSION}
//[END _SetDIBPixels1bit]
//[PROCEDURE _SetDIBPixelsPalIdx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor );
var Pixel: Byte;
Pos: PByte;
Shf: Integer;
begin
Pixel := Bmp.DIBPalNearestEntry( Value );
Pos := PByte( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta
+ X div (Bmp.fPixelsPerByteMask + 1)) );
Shf := (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask))
* Bmp.fDIBHeader.bmiHeader.biBitCount;
Pos^ := Pos^ and not (Bmp.fPixelMask shl Shf) or (Pixel shl Shf);
end;
{$ENDIF ASM_VERSION}
//[END _SetDIBPixelsPalIdx]
//[PROCEDURE _SetDIBPixels16bit]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );
var RGB16: Word;
Pos: PWord;
begin
Value := Color2RGB( Value );
if Bmp.fPixelMask = 15 then
RGB16 := (Value shr 19) and $001F or (Value shr 6) and $03E0
or (Value shl 7) and $7C00
else
RGB16 := (Value shr 19) and $001F or (Value shr 5) and $07E0
or (Value shl 8) and $F800;
Pos := PWord( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta + X * 2) );
Pos^ := RGB16;
end;
{$ENDIF ASM_VERSION}
//[END _SetDIBPixels16bit]
//[PROCEDURE _SetDIBPixelsTrueColor]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor );
var RGB: TRGBQuad;
Pos: PDWord;
begin
RGB := Color2RGBQuad( Value );
Pos := PDWORD( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta
+ X * Bmp.fBytesPerPixel) );
Pos^ := Pos^ and $FF000000 or DWORD(RGB);
end;
{$ENDIF ASM_VERSION}
//[END _SetDIBPixelsTrueColor]
//[procedure TBitmap.SetDIBPixels]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetDIBPixels(X, Y: Integer; const Value: TColor);
begin
if not Assigned( fSetDIBPixels ) then
begin
if fHandleType = bmDIB then
begin
fScanLine0 := ScanLine[ 0 ];
fScanLineDelta := cardinal(ScanLine[ 1 ]) - cardinal(fScanLine0);
case PixelFormat of
pf1bit:
begin
//fPixelMask := $01;
//fPixelsPerByteMask := 7;
fSetDIBPixels := _SetDIBPixels1bit;
end;
pf4bit:
begin
fPixelMask := $0F;
fPixelsPerByteMask := 1;
fSetDIBPixels := _SetDIBPixelsPalIdx;
end;
pf8bit:
begin
fPixelMask := $FF;
fPixelsPerByteMask := 0;
fSetDIBPixels := _SetDIBPixelsPalIdx;
end;
pf15bit:
begin
fPixelMask := 15;
fSetDIBPixels := _SetDIBPixels16bit;
end;
pf16bit:
begin
fPixelMask := 16;
fSetDIBPixels := _SetDIBPixels16bit;
end;
pf24bit:
begin
fPixelsPerByteMask := 0;
fBytesPerPixel := 3;
fSetDIBPixels := _SetDIBPixelsTrueColor;
end;
pf32bit:
begin
fPixelsPerByteMask := 1;
fBytesPerPixel := 4;
fSetDIBPixels := _SetDIBPixelsTrueColor;
end;
else;
end;
end;
if not Assigned( fSetDIBPixels ) then
begin
Pixels[ X, Y ] := Value;
Exit;
end;
end;
fSetDIBPixels( @Self, X, Y, Value );
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.FlipVertical]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.FlipVertical;
var DC: HDC;
Save: THandle;
TmpScan: PByte;
Y: Integer;
begin
if fHandle <> 0 then
begin
fDetachCanvas( @Self );
DC := CreateCompatibleDC( 0 );
Save := SelectObject( DC, fHandle );
StretchBlt( DC, 0, fHeight - 1, fWidth, -fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );
SelectObject( DC, Save );
DeleteDC( DC );
end
else
if fDIBBits <> nil then
begin
GetMem( TmpScan, ScanLineSize );
for Y := 0 to fHeight div 2 do
begin
Move( ScanLine[ Y ]^, TmpScan^, fScanLineSize );
Move( ScanLine[ fHeight - Y - 1 ]^, ScanLine[ Y ]^, fScanLineSize );
Move( TmpScan^, ScanLine[ fHeight - Y - 1 ]^, fScanLineSize );
end;
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.FlipHorizontal]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.FlipHorizontal;
var DC: HDC;
Save: THandle;
begin
if GetHandle <> 0 then
begin
fDetachCanvas( @Self );
DC := CreateCompatibleDC( 0 );
Save := SelectObject( DC, fHandle );
StretchBlt( DC, fWidth - 1, 0, -fWidth, fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );
SelectObject( DC, Save );
DeleteDC( DC );
end;
end;
{$ENDIF ASM_VERSION}
//[procedure TBitmap.CopyRect]
{$IFDEF ASM_VERSION}
procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap;
const SrcRect: TRect);
asm
PUSHAD
MOV EBX, EAX
MOV ESI, ECX
MOV EDI, EDX
CALL GetHandle
TEST EAX, EAX
JZ @@exit
MOV EAX, ESI
CALL GetHandle
TEST EAX, EAX
JZ @@exit
CALL StartDC
XCHG EBX, ESI
CMP EBX, ESI
JNZ @@diff1
PUSH EAX
PUSH 0
JMP @@nodiff1
@@diff1:
CALL StartDC
@@nodiff1:
PUSH SrcCopy // ->
MOV EBP, [SrcRect]
MOV EAX, [EBP].TRect.Bottom
MOV EDX, [EBP].TRect.Top
SUB EAX, EDX
PUSH EAX // ->
MOV EAX, [EBP].TRect.Right
MOV ECX, [EBP].TRect.Left
SUB EAX, ECX
PUSH EAX // ->
PUSH EDX // ->
PUSH ECX // ->
PUSH dword ptr [ESP+24] // -> DCsrc
MOV EAX, [EDI].TRect.Bottom
MOV EDX, [EDI].TRect.Top
SUB EAX, EDX
PUSH EAX // ->
MOV EAX, [EDI].TRect.Right
MOV ECX, [EDI].TRect.Left
SUB EAX, ECX
PUSH EAX // ->
PUSH EDX // ->
PUSH ECX // ->
PUSH dword ptr [ESP+13*4] // -> DCdst
CALL StretchBlt
CMP EBX, ESI
JNE @@diff2
POP ECX
POP ECX
JMP @@nodiff2
@@diff2:
CALL FinishDC
@@nodiff2:
CALL FinishDC
@@exit:
POPAD
end;
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap;
const SrcRect: TRect);
var DCsrc, DCdst: HDC;
SaveSrc, SaveDst: THandle;
begin
if (GetHandle = 0) or (SrcBmp.GetHandle = 0) then Exit;
fDetachCanvas( @Self );
SrcBmp.fDetachCanvas( SrcBmp );
DCsrc := CreateCompatibleDC( 0 );
SaveSrc := SelectObject( DCsrc, SrcBmp.fHandle );
DCdst := DCsrc;
SaveDst := 0;
if SrcBmp <> @Self then
begin
DCdst := CreateCompatibleDC( 0 );
SaveDst := SelectObject( DCdst, fHandle );
end;
StretchBlt( DCdst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
DstRect.Bottom - DstRect.Top, DCsrc, SrcRect.Left, SrcRect.Top,
SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
SRCCOPY );
if SrcBmp <> @Self then
begin
SelectObject( DCdst, SaveDst );
DeleteDC( DCdst );
end;
SelectObject( DCsrc, SaveSrc );
DeleteDC( DCsrc );
end;
{$ENDIF ASM_VERSION}
//[function TBitmap.CopyToClipboard]
function TBitmap.CopyToClipboard: Boolean;
var DibMem: PChar;
HdrSize: Integer;
Gbl: HGlobal;
//Mem: PStream;
//Sz: Integer;
//Pt: Pointer;
Restore_Compression: Integer;
begin
Result := FALSE;
if Applet = nil then Exit;
if not OpenClipboard( Applet.GetWindowHandle ) then
Exit;
if EmptyClipboard then
begin
HandleType := bmDIB;
HdrSize := sizeof( TBitmapInfoHeader );
Restore_Compression := -1;
TRY
if fDIBHeader.bmiHeader.biBitCount <= 8 then
Inc( HdrSize,
(1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad ) )
else
begin
if fDIBHeader.bmiHeader.biCompression = BI_RGB then
begin
CASE fDIBHeader.bmiHeader.biBitCount OF
{24,} 32:
begin
Restore_Compression := fDIBHeader.bmiHeader.biCompression;
fDIBHeader.bmiHeader.biCompression := BI_BITFIELDS;
PDWORD( @ fDIBHeader.bmiColors[ 0 ] )^ := $FF0000;
PDWORD( cardinal( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := $FF00;
PDWORD( cardinal( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := $FF;
Inc( HdrSize, 12 );
end;
END;
end;
end;
Gbl := GlobalAlloc( GMEM_MOVEABLE, HdrSize + fDIBSize );
DibMem := GlobalLock( Gbl );
if DibMem <> nil then
begin
Move( fDIBHeader^, DibMem^, HdrSize );
Move( fDIBBits^, Pointer( cardinal( DibMem ) + cardinal(HdrSize) )^, fDIBSize );
if not GlobalUnlock( Gbl ) and (GetLastError = NO_ERROR) then
begin
Result := SetClipboardData( CF_DIB, Gbl ) <> 0;
end;
end;
FINALLY
if Restore_Compression >= 0 then
fDIBHeader.bmiHeader.biCompression := Restore_Compression;
END;
end;
CloseClipboard;
end;
//[function TBitmap.PasteFromClipboard]
function TBitmap.PasteFromClipboard: Boolean;
var Gbl: HGlobal;
//DIBPtr: PChar;
Size {, HdrSize}: Integer;
Mem: PChar;
Strm: PStream;
begin
Result := FALSE;
if Applet = nil then Exit;
if not OpenClipboard( Applet.GetWindowHandle ) then Exit;
TRY
if IsClipboardFormatAvailable( CF_DIB ) then
begin
Gbl := GetClipboardData( CF_DIB );
if Gbl <> 0 then
begin
Size := GlobalSize( Gbl );
Mem := GlobalLock( Gbl );
TRY
if (Size > 0) and (Mem <> nil) then
begin
Strm := NewMemoryStream;
Strm.Write( Mem^, Size );
Strm.Position := 0;
LoadFromStreamEx( Strm );
////Strm.SaveToFile( GetStartDir + 'test_paste.bmp', 0, Strm.Size );
Strm.Free;
Result := not Empty;
end;
FINALLY
GlobalUnlock( Gbl );
END;
end;
end;
FINALLY
CloseClipboard;
END;
end;
///////////////////////////////////////////////////////////////////////
// I C O N
///////////////////////////////////////////////////////////////////////
{ -- icon -- }
//[function NewIcon]
function NewIcon: PIcon;
begin
{-}
New( Result, Create );
{+}{++}(*Result := TIcon.Create;*){--}
{$IFDEF ICON_DIFF_WH}
Result.FWidth := 32;
Result.FHeight := 32;
{$ELSE}
Result.FSize := 32;
{$ENDIF}
end;
{ TIcon }
//[PROCEDURE asmIconEmpty]
{$IFDEF ASM_VERSION}
{$ENDIF ASM_VERSION}
//[END asmIconEmpty]
//[procedure TIcon.Clear]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TIcon.Clear;
begin
if fHandle <> 0 then
begin
if not FShareIcon then
DestroyIcon( fHandle );
fHandle := 0;
end;
fShareIcon := False;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_LOCAL}
{$UNDEF ASM_LOCAL}
{$ENDIF}
{$IFNDEF ICON_DIFF_WH}
{$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
{$ENDIF}
//[function TIcon.Convert2Bitmap]
{$IFDEF ASM_LOCAL}
{$ELSE ASM_VERSION} //Pascal
function TIcon.Convert2Bitmap(TranColor: TColor): HBitmap;
var DC0, DC2: HDC;
Save: THandle;
Br: HBrush;
begin
Result := 0;
if Empty then Exit;
DC0 := GetDC( 0 );
DC2 := CreateCompatibleDC( DC0 );
{$IFDEF ICON_DIFF_WH}
Result := CreateCompatibleBitmap( DC0, fWidth, fHeight );
{$ELSE}
Result := CreateCompatibleBitmap( DC0, fSize, fSize );
{$ENDIF}
Save := SelectObject( DC2, Result );
Br := CreateSolidBrush( Color2RGB( TranColor ) );
{$IFDEF ICON_DIFF_WH}
FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br );
{$ELSE}
FillRect( DC2, MakeRect( 0, 0, fSize, fSize ), Br );
{$ENDIF}
DeleteObject( Br );
Draw( DC2, 0, 0 );
SelectObject( DC2, Save );
DeleteDC( DC2 );
ReleaseDC( 0, DC0 );
end;
{$ENDIF ASM_VERSION}
//[destructor TIcon.Destroy]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
destructor TIcon.Destroy;
begin
Clear;
inherited;
end;
{$ENDIF ASM_VERSION}
//[procedure TIcon.Draw]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TIcon.Draw(DC: HDC; X, Y: Integer);
begin
if Empty then Exit;
{$IFDEF ICON_DIFF_WH}
DrawIconEx( DC, X, Y, fHandle, fWidth, fHeight, 0, 0, DI_NORMAL );
{$ELSE}
DrawIconEx( DC, X, Y, fHandle, fSize, fSize, 0, 0, DI_NORMAL );
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
//[procedure TIcon.StretchDraw]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TIcon.StretchDraw(DC: HDC; Dest: TRect);
begin
if Empty then Exit;
DrawIconEx( DC, Dest.Left, Dest.Top, FHandle, Dest.Right - Dest.Left,
Dest.Bottom - Dest.Top, 0, 0, DI_NORMAL );
end;
{$ENDIF ASM_VERSION}
//[function TIcon.GetEmpty]
function TIcon.GetEmpty: Boolean;
begin
Result := (fHandle = 0)
{$IFDEF ICONLOAD_PRESERVEBMPS}
and ((ImgBmp = nil) or ImgBmp.Empty)
{$ENDIF ICONLOAD_PRESERVEBMPS}
;
end;
//*
//[function TIcon.GetHotSpot]
function TIcon.GetHotSpot: TPoint;
{$ifdef win32}
var II : TIconInfo;
{$endif win32}
begin
Result := MakePoint( 0, 0 );
{$ifdef win32}
if FHandle = 0 then Exit;
GetIconInfo( FHandle, II );
Result.x := II.xHotspot;
Result.y := II.yHotspot;
if II.hbmMask <> 0 then
DeleteObject( II.hbmMask );
if II.hbmColor <> 0 then
DeleteObject( II.hbmColor );
{$endif win32}
end;
//*
//[procedure TIcon.LoadFromFile]
procedure TIcon.LoadFromFile(const FileName: KOLString);
var Strm : PStream;
begin
Strm := NewReadFileStream( Filename );
LoadFromStream( Strm );
Strm.Free;
end;
//*
//[procedure TIcon.LoadFromStream]
procedure TIcon.LoadFromStream(Strm: PStream);
var DesiredSize : Integer;
Pos : DWord;
Mem : PStream;
{$IFNDEF ICONLOAD_PRESERVEBMPS}
ImgBmp, MskBmp : PBitmap;
{$ENDIF ICONLOAD_PRESERVEBMPS}
TmpBmp: PBitmap;
function ReadIcon : Boolean;
var IH : TIconHeader;
IDI, FoundIDI : TIconDirEntry;
I, J, SumSz, FoundSz, D : Integer;
II : TIconInfo;
BIH : TBitmapInfoheader;
SzImg: DWORD;
begin
Result := False;
if Strm.Read( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit;
if (IH.idReserved = Sizeof( TBitmapInfoHeader )) then
begin
Strm.Position := Strm.Position - Sizeof( IH );
{$IFDEF ICON_DIFF_WH} fWidth := 0;
fHeight := 0;
{$ELSE} fSize := 0;
{$ENDIF}
SumSz := 0;
end
else
if (IH.idReserved = 0) and ((IH.idType = 1) or (IH.idType = 2)) and
(IH.idCount >= 1) then
begin
if (IH.idReserved <> 0) or ((IH.idType <> 1) and (IH.idType <> 2)) or
(IH.idCount < 1) or (IH.idCount >= 1024) then Exit;
SumSz := Sizeof( IH );
FoundSz := 1000000;
for I := 1 to IH.idCount do
begin
if Strm.Read( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit;
Inc( SumSz, IDI.dwBytesInRes + Sizeof( IDI ) );
D := IDI.bWidth - DesiredSize;
if D < 0 then D := -D;
if D < FoundSz then
begin
FoundSz := D;
FoundIDI := IDI;
end;
end;
if FoundSz = 1000000 then Exit;
Strm.Position := Integer( Pos ) + FoundIDI.dwImageOffset;
{$IFDEF ICON_DIFF_WH} fWidth := FoundIDI.bWidth;
fHeight := FoundIDI.bHeight;
{$ELSE} fSize := FoundIDI.bWidth;
{$ENDIF}
end
else Exit;
if Strm.Read( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit;
{$IFDEF ICON_DIFF_WH}
fWidth := BIH.biWidth;
BIH.biHeight := BIH.biHeight div 2; // fSize;
fHeight := BIH.biHeight;
{$ELSE}
fSize := BIH.biWidth;
BIH.biHeight := BIH.biHeight div 2; // fSize;
{$ENDIF}
Mem := NewMemoryStream;
if (FoundIDI.bColorCount >= 2) or (FoundIDI.bReserved = 1) or
(FoundIDI.bColorCount = 0) then
begin
I := 0;
SzImg := ((BIH.biBitCount * BIH.biWidth + 31) div 32) * 4 * BIH.biHeight;
if (BIH.biSizeImage > 0) and (SzImg > BIH.biSizeImage) then
SzImg := BIH.biSizeImage;
if BIH.biBitCount <= 8 then
begin
I := (1 shl BIH.biBitCount) * Sizeof( TRGBQuad );
end;
Mem.Write( BIH, Sizeof( BIH ) );
if I > 0 then
begin
if Stream2Stream( Mem, Strm, I ) <> DWORD(I) then Exit;
end
else
if BIH.biBitCount = 16 then
begin
for I := 0 to 2 do
begin
J := InitColors[ I ];
Mem.Write( J, 4 );
end;
end;
I := Stream2Stream( Mem, Strm, SzImg );
if I <> Integer( SzImg ) then Exit;
{$IFDEF ICON_DIFF_WH}
ImgBmp := NewBitmap( fWidth, fHeight );
{$ELSE}
ImgBmp := NewBitmap( fSize, fSize );
{$ENDIF}
{$IFDEF ICONLOAD_PRESERVEBMPS}
Add2AutoFree( ImgBmp );
{$ENDIF ICONLOAD_PRESERVEBMPS}
Mem.Seek( 0, spBegin );
{$IFDEF LOADEX}
ImgBmp.LoadFromStreamEx( Mem );
{$ELSE}
ImgBmp.LoadFromStream( Mem );
{$ENDIF}
if ImgBmp.Empty then Exit;
end
else
begin
Mem.Write( BIH, Sizeof( BIH ) );
end;
BIH.biBitCount := 1;
BIH.biPlanes := 1;
BIH.biClrUsed := 0;
Mem.Seek( 0, spBegin );
BIH.biSizeImage := ((BIH.biWidth + 31) div 32) * 4 * BIH.biHeight;
Mem.Write( BIH, Sizeof( BIH ) );
I := 0;
Mem.Write( I, Sizeof( I ) );
I := $FFFFFF;
Mem.Write( I, Sizeof( I ) );
I := BIH.biSizeImage;
J := Stream2Stream( Mem, Strm, I );
while J < I do
begin
D := 0;
Mem.Write( D, 4 );
Inc( J, 4 );
end;
{$IFDEF ICON_DIFF_WH}
MskBmp := NewBitmap( fWidth, fHeight );
{$ELSE}
MskBmp := NewBitmap( fSize, fSize );
{$ENDIF}
{$IFDEF ICONLOAD_PRESERVEBMPS}
Add2AutoFree( MskBmp );
{$ENDIF ICONLOAD_PRESERVEBMPS}
Mem.Seek( 0, spBegin );
{$IFDEF LOADEX}
MskBmp.LoadFromStreamEx( Mem );
{$ELSE}
MskBmp.LoadFromStream( Mem );
{$ENDIF}
{$IFDEF ICONLOAD_PRESERVEBMPS}
Result := TRUE;
if not Only_Bmp then
{$ENDIF ICONLOAD_PRESERVEBMPS}
begin
II.fIcon := True;
II.xHotspot := 0;
II.yHotspot := 0;
II.hbmMask := 0;
if Assigned( MskBmp ) and not MskBmp.Empty then
II.hbmMask := MskBmp.Handle;
II.hbmColor := 0;
if ImgBmp <> nil then
II.hbmColor := ImgBmp.Handle;
fHandle := CreateIconIndirect( II );
if SumSz > 0 then
Strm.Seek( Integer( Pos ) + SumSz, spBegin );
Result := fHandle <> 0;
end;
end;
begin
DesiredSize := Size;
if DesiredSize = 0 then
DesiredSize := GetSystemMetrics( SM_CXICON );
Clear;
Pos := Strm.Position;
Mem := nil;
{$IFDEF ICONLOAD_PRESERVEBMPS}
if ImgBmp <> nil then
begin
RemoveFromAutoFree( ImgBmp );
RemoveFromAutoFree( MskBmp );
Free_And_Nil( ImgBmp );
Free_And_Nil( MskBmp );
end;
{$ELSE}
ImgBmp := nil;
MskBmp := nil;
{$ENDIF ICONLOAD_PRESERVEBMPS}
TmpBmp := nil;
if not ReadIcon then
begin
Clear;
Strm.Seek( Pos, spBegin );
end;
Mem.Free;
{$IFNDEF ICONLOAD_PRESERVEBMPS}
ImgBmp.Free;
MskBmp.Free;
{$ENDIF ICONLOAD_PRESERVEBMPS}
TmpBmp.Free;
end;
{$ifdef win32}
//[procedure TIcon.SaveToFile]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TIcon.SaveToFile(const FileName: KOLString);
begin
SaveIcons2File( [ @Self ], FileName );
end;
{$ENDIF ASM_VERSION}
//[procedure TIcon.SaveToStream]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TIcon.SaveToStream(Strm: PStream);
begin
SaveIcons2Stream( [ @Self ], Strm );
end;
{$ENDIF ASM_VERSION}
{$endif win32}
{$IFDEF ASM_noVERSION}
//[procedure TIcon.SetHandle]
procedure TIcon.SetHandle(const Value: HIcon);
const szII = sizeof( TIconInfo );
szBIH = sizeof(TBitmapInfoHeader);
asm //cmd //opd
CMP EDX, [EAX].fHandle
JE @@exit
PUSHAD
PUSH EDX
MOV EBX, EAX
CALL Clear
POP ECX
MOV [EBX].fHandle, ECX
JECXZ @@fin
ADD ESP, -szBIH
PUSH ESP
PUSH ECX
CALL GetIconInfo
MOV ESI, [ESP].TIconInfo.hbmMask
MOV EDI, [ESP].TIconInfo.hbmColor
PUSH ESP
PUSH szBIH
PUSH ESI
CALL GetObject
POP EAX
POP [EBX].fSize
ADD ESP, szBIH-8
TEST ESI, ESI
JZ @@1
PUSH ESI
CALL DeleteObject
@@1: TEST EDI, EDI
JZ @@fin
PUSH EDI
CALL DeleteObject
@@fin: POPAD
@@exit:
end;
{$ELSE ASM_VERSION} //Pascal
procedure TIcon.SetHandle(const Value: HIcon);
{$ifdef win32}
var II : TIconInfo;
B: TagBitmap;
{$endif win32}
begin
if FHandle = Value then Exit;
Clear;
FHandle := Value;
if Value <> 0 then
begin
{$ifdef wince}
{$IFDEF ICON_DIFF_WH}
fWidth := 32;
fHeight := 32;
{$ELSE}
fSize := 32;
{$ENDIF}
{$else}
GetIconInfo( FHandle, II );
GetObject( II.hbmMask, Sizeof( B ), @B );
{$IFDEF ICON_DIFF_WH}
fWidth := B.bmWidth;
fHeight := B.bmHeight;
{$ELSE}
fSize := B.bmWidth;
{$ENDIF}
if II.hbmMask <> 0 then
DeleteObject( II.hbmMask );
if II.hbmColor <> 0 then
DeleteObject( II.hbmColor );
{$endif wince}
end;
end;
{$ENDIF ASM_VERSION}
//*
//[procedure TIcon.SetSize]
procedure TIcon.SetSize(const Value: Integer);
begin
{$IFDEF ICON_DIFF_WH}
if (fWidth = Value) and (fHeight = Value) then Exit;
{$ELSE}
if FSize = Value then Exit;
{$ENDIF}
Clear;
{$IFDEF ICON_DIFF_WH}
fWidth := Value;
fHeight := Value;
{$ELSE}
FSize := Value;
{$ENDIF}
end;
{$IFDEF ICON_DIFF_WH}
function TIcon.GetIconSize: Integer;
begin
Result := Max( fWidth, fHeight );
end;
{$ENDIF}
//[FUNCTION ColorBits]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function ColorBits( ColorsCount : Integer ) : Integer;
var I : Integer;
begin
for I := 1 to 6 do
begin
Result := PossibleColorBits[ I ];
if (1 shl Result) >= ColorsCount then break;
end;
end;
{$ENDIF ASM_VERSION}
//[END ColorBits]
{$ifdef win32}
//[function SaveIcons2StreamEx]
function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean;
var I, Off : Integer;
IDI : TIconDirEntry;
BIH : TBitmapInfoHeader;
B: TagBitmap;
function RGBArraySize : Integer;
begin
Result := 0;
if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then
Result := (IDI.bColorCount + (IDI.bReserved shl 8)) * Sizeof( TRGBQuad );
end;
function ColorDataSize( W, H: Integer ) : Integer;
var N: Integer;
begin
if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then
N := (ColorBits( IDI.bColorCount + (IDI.bReserved shl 8) ) )
else
begin
N := IDI.wBitCount;
end;
Result := ((N * W + 31) div 32) * 4
* H;
end;
function MaskDataSize( W, H: Integer ) : Integer;
begin
Result := ((W + 31) div 32) * 4 * H;
end;
var BColor, BMask: HBitmap;
W, H: Integer;
ImgBmp, MskBmp: PBitmap;
IH : TIconHeader;
Colors : PList;
begin
Assert( (High(BmpHandles) >= 0) and (High(BmpHandles) and 1 <> 0),
'Incorrect parameters count in call to SaveIcons2StreamEx' );
Result := False;
IH.idReserved := 0;
IH.idType := 1;
IH.idCount := (High( BmpHandles )+1) div 2;
if Strm.Write( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit;
Off := Sizeof( IH ) + IH.idCount * Sizeof( IDI );
Colors := NewList;
ImgBmp := NewBitmap( 0, 0 );
MskBmp := NewBitmap( 0, 0 );
TRY
for I := 0 to High( BmpHandles ) div 2 do
begin
BColor := BmpHandles[ I * 2 ];
BMask := BmpHandles[ I * 2 + 1 ];
if (BColor = 0) and (BMask = 0) then break;
Assert( BMask <> 0, 'Mask bitmap not provided for saving icons in SaveIcons2StreamEx' );
GetObject( BMask, Sizeof( B ), @ B );
W := B.bmWidth;
H := B.bmHeight;
if BColor <> 0 then
begin
GetObject( BColor, Sizeof( B ), @B );
Assert( (B.bmWidth = W) and (B.bmHeight = H),
'Mask bitmap size must much color bitmap size in SaveIcons2StreamEx' );
end;
FillChar( IDI, Sizeof( IDI ), #0 );
IDI.bWidth := W;
IDI.bHeight := H;
if BColor = 0 then
IDI.bColorCount := 2
else
begin
ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H,
LR_CREATEDIBSECTION );
FillChar( BIH, Sizeof( BIH ), #0 );
BIH.biSize := Sizeof( BIH );
GetObject( ImgBmp.Handle, Sizeof( B ), @B );
if (B.bmPlanes = 1) and (B.bmBitsPixel >= 15) then
begin
IDI.bColorCount := 0;
IDI.bReserved := 0;
IDI.wBitCount := B.bmBitsPixel;
end
else
if B.bmPlanes * (1 shl B.bmBitsPixel) < 16 then
begin
ImgBmp.PixelFormat := pf1bit;
IDI.bColorCount := 2;
end
else
if B.bmPlanes * (1 shl B.bmBitsPixel) < 256 then
begin
ImgBmp.PixelFormat := pf4bit;
IDI.bColorCount := 16;
end
else
begin
ImgBmp.PixelFormat := pf8bit;
IDI.bColorCount := 0;
IDI.bReserved := 1;
end;
end;
Colors.Add( Pointer(IDI.bColorCount + (IDI.bReserved shl 8)) );
IDI.dwBytesInRes := Sizeof( BIH ) + RGBArraySize +
ColorDataSize( W, H ) + MaskDataSize( W, H );
IDI.dwImageOffset := Off;
if Strm.Write( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit;
Inc( Off, IDI.dwBytesInRes );
end;
for I := 0 to High( BmpHandles ) div 2 do
begin
BColor := BmpHandles[ I * 2 ];
BMask := BmpHandles[ I * 2 + 1 ];
if (BColor = 0) and (BMask = 0) then break;
GetObject( BMask, Sizeof( B ), @ B );
W := B.bmWidth;
H := B.bmHeight;
FillChar( BIH, Sizeof( BIH ), #0 );
BIH.biSize := Sizeof( BIH );
BIH.biWidth := W;
BIH.biHeight := H;
if BColor <> 0 then
BIH.biHeight := W * 2;
BIH.biPlanes := 1;
PWord( @ IDI.bColorCount )^ := DWord( Colors.Items[ I ] );
if IDI.wBitCount = 0 then
IDI.wBitCount := ColorBits( PWord( @ IDI.bColorCount )^ );
BIH.biBitCount := IDI.wBitCount;
BIH.biSizeImage := Sizeof( BIH ) + ColorDataSize( W, H ) + MaskDataSize( W, H );
if Strm.Write( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit;
if BColor <> 0 then
begin
ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H, 0 );
case BIH.biBitCount of
1 : ImgBmp.PixelFormat := pf1bit;
4 : ImgBmp.PixelFormat := pf4bit;
8 : ImgBmp.PixelFormat := pf8bit;
16: ImgBmp.PixelFormat := pf16bit;
24: ImgBmp.PixelFormat := pf24bit;
32: ImgBmp.PixelFormat := pf32bit;
end;
end
else
begin
ImgBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 );
ImgBmp.PixelFormat := pf1bit;
end;
if ImgBmp.FDIBBits <> nil then
begin
if Strm.Write( Pointer(cardinal(ImgBmp.FDIBHeader) + Sizeof(TBitmapInfoHeader))^,
PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) ) <>
DWORD(PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad )) then Exit;
if Strm.Write( ImgBmp.FDIBBits^, ColorDataSize( W, H ) ) <>
DWord( ColorDataSize( W, H ) ) then Exit;
end;
MskBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 );
MskBmp.PixelFormat := pf1bit;
if Strm.Write( MskBmp.FDIBBits^, MaskDataSize( W, H ) ) <>
DWord( MaskDataSize( W, H ) ) then Exit;
end;
FINALLY
Colors.Free;
ImgBmp.Free;
MskBmp.Free;
END;
Result := True;
end;
{$IFDEF FPC}
{$DEFINE _D3orFPC}
{$ENDIF}
{$IFDEF _D2orD3}
{$DEFINE _D3orFPC}
{$ENDIF}
//[procedure SaveIcons2Stream]
procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream );
var I, J, Pos : Integer;
{$IFDEF _D3orFPC}
Bitmaps: array[ 0..63 ] of HBitmap;
{$ELSE DELPHI}
Bitmaps: array of HBitmap;
{$ENDIF FPC/DELPHI}
II: TIconInfo;
Bmp: HBitmap;
begin
for I := 0 to High( Icons ) do
begin
if Icons[ I ].Handle = 0 then Exit;
for J := I + 1 to High( Icons ) do
if Icons[ I ].Size = Icons[ J ].Size then Exit;
end;
Pos := Strm.Position;
{$IFDEF _D3orFPC}
for I := 0 to High( Bitmaps ) do
Bitmaps[ I ] := 0;
{$ELSE DELPHI}
SetLength( Bitmaps, Length( Icons ) * 2 );
{$ENDIF FPC/DELPHI}
for I := 0 to High( Icons ) do
begin
GetIconInfo( Icons[ I ].Handle, II );
Bitmaps[ I * 2 ] := II.hbmColor;
Bitmaps[ I * 2 + 1 ] := II.hbmMask;
end;
if not SaveIcons2StreamEx( Bitmaps, Strm ) then
Strm.Seek( Pos, spBegin );
for I := 0 to High( Bitmaps ) do
begin
Bmp := Bitmaps[ I ];
if Bmp <> 0 then
DeleteObject( Bmp );
end;
end;
//[procedure SaveIcons2File]
procedure SaveIcons2File( const Icons : array of PIcon; const FileName : KOLString );
var Strm: PStream;
begin
Strm := NewWriteFileStream( FileName );
SaveIcons2Stream( Icons, Strm );
Strm.Free;
end;
{$endif win32}
//[procedure TIcon.LoadFromExecutable]
procedure TIcon.LoadFromExecutable(const FileName: KOLString; IconIdx: Integer);
var I: Integer;
begin
Clear;
{$ifdef wince}
if ExtractIconEx(PKOLChar( FileName ), IconIdx, @I, nil, 1) > 0 then
{$else}
I := ExtractIcon( hInstance, PKOLChar( FileName ), IconIdx );
if I > 1 then
{$endif wince}
Handle := I;
end;
//[function GetFileIconCount]
function GetFileIconCount( const FileName: KOLString ): Integer;
begin
{$ifdef wince}
Result := ExtractIconEx(PKOLChar( FileName ), -1, nil, nil, 0);
{$else}
Result := ExtractIcon( hInstance, PKOLChar( FileName ), DWORD(-1) );
{$endif wince}
end;
//[procedure TIcon.LoadFromResourceID]
procedure TIcon.LoadFromResourceID(Inst, ResID, DesiredSize: Integer);
begin
LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ), DesiredSize );
end;
//[procedure TIcon.LoadFromResourceName]
procedure TIcon.LoadFromResourceName(Inst: Integer; ResName: PKOLChar; DesiredSize: Integer);
begin
Handle := LoadImage( Inst, ResName, IMAGE_ICON, DesiredSize, DesiredSize, {$ifdef wince} 0 {$else} $8000 {LR_SHARED} {$endif} );
{$ifdef wince}
{$IFDEF ICON_DIFF_WH}
fWidth := DesiredSize;
fHeight := DesiredSize;
{$ELSE}
fSize := DesiredSize;
{$ENDIF}
{$endif wince}
if fHandle <> 0 then FShareIcon := True;
end;
//[function LoadImgIcon]
function LoadImgIcon( RsrcName: PKOLChar; Size: Integer ): HIcon;
begin
Result := LoadImage( hInstance, RsrcName, IMAGE_ICON, Size, Size, {$ifdef wince} 0 {$else} $8000 {LR_SHARED} {$endif} );
end;
//*
//[procedure AlignChildrenProc]
{$IFDEF OLD_ALIGN}
procedure AlignChildrenProc( Sender: PObj );
type
TAligns = set of TControlAlign;
var P: PControl;
CR: TRect;
procedure DoAlign( Allowed: TAligns );
var I: Integer;
C: PControl;
R, R1: TRect;
W, H: Integer;
ChgPos, ChgSiz: Boolean;
begin
for I := 0 to P.fChildren.fCount - 1 do
begin
C := P.fChildren.fItems[ I ];
if not C.ToBeVisible then continue;
// important: not fVisible, and even not Visible, but ToBeVisible!
if C.fNotUseAlign then continue;
if C.FAlign in Allowed then
begin
R := C.BoundsRect;
R1 := R;
W := R.Right - R.Left;
H := R.Bottom - R.Top;
case C.FAlign of
caTop:
begin
OffsetRect( R, 0, -R.Top + CR.Top + P.Margin );
Inc( CR.Top, H + P.Margin );
R.Left := CR.Left + P.Margin;
R.Right := CR.Right - P.Margin;
end;
caBottom:
begin
OffsetRect( R, 0, -R.Bottom + CR.Bottom - P.Margin );
Dec( CR.Bottom, H + P.Margin );
R.Left := CR.Left + P.Margin;
R.Right := CR.Right - P.Margin;
end;
caLeft:
begin
OffsetRect( R, -R.Left + CR.Left + P.Margin, 0 );
Inc( CR.Left, W + P.Margin );
R.Top := CR.Top + P.Margin;
R.Bottom := CR.Bottom - P.Margin;
end;
caRight:
begin
OffsetRect( R, -R.Right + CR.Right - P.Margin, 0 );
Dec( CR.Right, W + P.Margin );
R.Top := CR.Top + P.Margin;
R.Bottom := CR.Bottom - P.Margin;
end;
caClient:
begin
R := CR;
InflateRect( R, -P.Margin, -P.Margin );
end;
end;
if R.Right < R.Left then R.Right := R.Left;
if R.Bottom < R.Top then R.Bottom := R.Top;
ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top);
ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H);
if ChgPos or ChgSiz then
begin
C.BoundsRect := R;
if ChgSiz then
AlignChildrenProc( C );
end;
end;
end;
end;
begin
P := Pointer( Sender );
if P = nil then Exit; // Called for form - ignore.
CR := P.ClientRect;
if CR.Right <= CR.Left then Exit;
DoAlign( [ caTop, caBottom ] );
DoAlign( [ caLeft, caRight ] );
DoAlign( [ caClient ] );
end;
{$ELSE NEW_ALIGN}
procedure AlignChildrenProc_(P:PControl);
type TAligns = set of TControlAlign;
var CR: TRect;
procedure DoAlign( Allowed: TAligns );
var I, W, H: Integer;
C: PControl;
R, R1: TRect;
ChgPos, ChgSiz: Boolean;
begin
for I := 0 to P.fChildren.fCount - 1 do begin
C := P.fChildren.fItems[ I ];
with C{-}^{+} do begin
if not (fVisible or fCreateHidden)
or not (fAlign in Allowed)
or (oaAligning in fAligning) then continue;
if not fNotUseAlign and (fAlign <> caNone) then begin
R := BoundsRect;
R1 := R;
W := R.Right - R.Left;
H := R.Bottom - R.Top;
case FAlign of
caTop:
begin
OffsetRect( R, 0, -R.Top + CR.Top + P.Margin );
Inc( CR.Top, H + P.Margin );
R.Left := CR.Left + P.Margin;
R.Right := CR.Right - P.Margin;
end;
caBottom:
begin
OffsetRect( R, 0, -R.Bottom + CR.Bottom - P.Margin );
Dec( CR.Bottom, H + P.Margin );
R.Left := CR.Left + P.Margin;
R.Right := CR.Right - P.Margin;
end;
caLeft:
begin
OffsetRect( R, -R.Left + CR.Left + P.Margin, 0 );
Inc( CR.Left, W + P.Margin );
R.Top := CR.Top + P.Margin;
R.Bottom := CR.Bottom - P.Margin;
end;
caRight:
begin
OffsetRect( R, -R.Right + CR.Right - P.Margin, 0 );
Dec( CR.Right, W + P.Margin );
R.Top := CR.Top + P.Margin;
R.Bottom := CR.Bottom - P.Margin;
end;
caClient:
begin
R := CR;
InflateRect( R, -P.Margin, -P.Margin );
end;
end;
if R.Right < R.Left then R.Right := R.Left;
if R.Bottom < R.Top then R.Bottom := R.Top;
ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top);
ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H);
if ChgPos or ChgSiz then begin
include(fAligning,oaFromSelf);
BoundsRect := R;
exclude(fAligning,oaFromSelf);
end;
if ChgSiz then
include(fAligning,oaWaitAlign);
end;
if oaWaitAlign in fAligning then AlignChildrenProc_(C);
end;
end;
end;
begin
if oaAligning in P.fAligning then exit;
exclude(P.fAligning,oaWaitAlign);
if P.ChildCount = 0 then exit;
include(P.fAligning,oaAligning);
CR := P.ClientRect;
DoAlign( [ caTop, caBottom ] );
DoAlign( [ caLeft, caRight ] );
DoAlign( [ caClient,caNone ] );
exclude(P.fAligning,oaAligning);
end;
{$IFDEF ASM_VERSION}
{$ELSE PAS_VERSION} // Pascal
procedure AlignChildrenProc(Sender: PObj);
function ToBeAlign( S: PControl ):boolean;
begin
Result := (S.fVisible or S.fCreateHidden)
and (S.isForm or (S.fParent=nil) or ToBeAlign(S.fParent));
if not Result then include(S.fAligning,oaWaitAlign);
end;
var
S: PControl;
begin
if Sender = nil then Exit;
S := Pointer( Sender );
if oaFromSelf in S.fAligning then exit;
if not (S.fNotUseAlign or (S.fAlign = caNone)) and (S.fParent <> nil) and not S.isForm then begin
include(S.fAligning, oaWaitAlign);
S := S.Parent;
end;
if ToBeAlign(S) then
AlignChildrenProc_(S);
end;
{$ENDIF ASM_VERSION}
{$ENDIF OLD_ALIGN}
//*
//[procedure TControl.Set_Align]
procedure TControl.Set_Align(const Value: TControlAlign);
begin
Global_Align := AlignChildrenProc;
if fNotUseAlign then Exit;
if FAlign = Value then Exit;
FAlign := Value;
{$IFDEF OLD_ALIGN}
AlignChildrenProc( Parent );
{$ELSE NEW_ALIGN}
AlignChildrenProc(@Self);
{$ENDIF}
end;
//*
//[function TControl.SetAlign]
function TControl.SetAlign(AAlign: TControlAlign): PControl;
begin
Set_Align( AAlign );
Result := @Self;
end;
//*
//[function WndProcPreventResizeFlicks]
function WndProcPreventResizeFlicks( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
type TRectsArray = array[0..2] of TRect;
PRectsArray = ^TRectsArray;
TChange = ( ChgL, ChgT, ChgR, ChgB );
TChanges = Set of TChange;
var Rects : PRectsArray;
Changes : Set of TChange;
Resizing : Boolean;
X, Y, DX, DY : Integer;
EntireRect, Src, Dst : TRect;
function GetClientAfter : TRect;
var R : TRect;
begin
R := Rects[ 2 ];
OffsetRect( R, Rects[ 0 ].Left - Rects[ 1 ].Left,
Rects[ 0 ].Top - Rects[ 1 ].Top );
if Rects[ 0 ].Right - Rects[ 0 ].Left <> Rects[ 1 ].Right - Rects[ 1 ].Left then
R.Right := R.Left + (R.Right - R.Left)
+ (Rects[ 0 ].Right - Rects[ 0 ].Left)
- (Rects[ 1 ].Right - Rects[ 1 ].Left);
if Rects[ 0 ].Bottom - Rects[ 0 ].Top <> Rects[ 1 ].Bottom - Rects[ 1 ].Top then
R.Bottom := R.Top + (R.Bottom - R.Top)
+ (Rects[ 0 ].Bottom - Rects[ 0 ].Top)
- (Rects[ 1 ].Bottom - Rects[ 1 ].Top);
Result := R;
end;
procedure DoResize( F : PControl; Changes : TChanges );
procedure CollectClipRgn( V : PControl; Changes : TChanges );
var C : PControl;
I : Integer;
begin
for I := 0 to V.FChildren.FCount - 1 do
begin
C := V.FChildren.FItems[ I ];
if not C.Visible then Continue;
if C.fNotUseAlign then
begin
C.Update;
end;
end;
end; // of CollectClipRgn
begin // DoResize
CollectClipRgn( F, Changes );
end; // of DoResize
var PR: PRect;
R: TRect;
begin // Procedure WndProcResizeFlicks
Result := False;
case Msg.message of
WM_NCCALCSIZE:
if Msg.wParam <> 0 then
begin
Rects := Pointer( Msg.lParam );
Changes := [];
if Rects[ 0 ].Left <> Rects[ 1 ].Left then
Changes := Changes + [ ChgL ];
if Rects[ 0 ].Top <> Rects[ 1 ].Top then
Changes := Changes + [ ChgT ];
if Rects[ 0 ].Right <> Rects[ 1 ].Right then
Changes := Changes + [ ChgR ];
if Rects[ 0 ].Bottom <> Rects[ 1 ].Bottom then
Changes := Changes + [ ChgB ];
Resizing := Changes * [ ChgL, ChgT ] <> [ ];
if Resizing and not Sender.fNotUseAlign then
begin
EntireRect := GetClientAfter;
OffsetRect( EntireRect, -EntireRect.Left, -EntireRect.Top );
if EntireRect.Right - EntireRect.Left < Rects[ 2 ].Right - Rects[ 2 ].Left then
EntireRect.Right := Rects[ 2 ].Right - Rects[ 2 ].Left;
if EntireRect.Bottom - EntireRect.Top < Rects[ 2 ].Bottom - Rects[ 2 ].Top then
EntireRect.Bottom := Rects[ 2 ].Bottom - Rects[ 2 ].Top;
X := Min( Rects[ 0 ].Left, Rects[ 1 ].Left ) + Rects[ 2 ].Left - Rects[ 1 ].Left;
Y := Min( Rects[ 0 ].Top, Rects[ 1 ].Top ) + Rects[ 2 ].Top - Rects[ 2 ].Top;
OffsetRect( EntireRect, X, Y );
DX := 0; DY := 0;
if ChgL in Changes then
DX := Rects[ 0 ].Left - Rects[ 1 ].Left;
if ChgR in Changes then
DX := Rects[ 0 ].Right - Rects[ 1 ].Right;
if ChgT in Changes then
DY := Rects[ 0 ].Top - Rects[ 1 ].Top;
if ChgB in Changes then
DY := Rects[ 0 ].Bottom - Rects[ 1 ].Bottom;
DoResize( Sender, Changes );
Rslt := 0;
if (Changes = [ChgL]) then
begin
Rslt := WVR_VALIDRECTS;
Src := Rects[ 2 ];
Dst := GetClientAfter;
Src.Right := Src.Left - DX;
Dst.Right := Dst.Left - DX;
Rects[ 1 ] := Src;
Rects[ 2 ] := Dst;
end
else
if (Changes = [ChgR]) then
begin
Rslt := WVR_VALIDRECTS;
Src := Rects[ 2 ];
Dst := GetClientAfter;
Src.Left := Src.Right - DX;
Dst.Left := Dst.Right - DX;
Rects[ 1 ] := Src;
Rects[ 2 ] := Dst;
end
else
if (Changes = [ChgT]) then
begin
Rslt := WVR_VALIDRECTS;
Src := Rects[ 2 ];
Dst := GetClientAfter;
Src.Bottom := Src.Top - DY;
Dst.Bottom := Dst.Top - DY;
Rects[ 1 ] := Src;
Rects[ 2 ] := Dst;
end
else
if Changes = [ChgL,ChgT] then
begin
Rslt := WVR_VALIDRECTS;
Src := Rects[ 2 ];
Dst := GetClientAfter;
Src.Left := Src.Right - DX;
Dst.Left := Dst.Right - DX;
Src.Bottom := Src.Top - DY;
Dst.Bottom := Dst.Top - DY;
Rects[ 1 ] := Src;
Rects[ 2 ] := Dst;
end;
PostMessage( Sender.fHandle, CM_UPDATE, 0, 0 );
end;
end;
CM_UPDATE:
begin
if Sender.fNotUpdate then
begin
Sender.fNotUpdate := False;
Sender.Invalidate;
end;
Sender.Update;
end;
WM_SIZING:
begin
if (Msg.wParam = WMSZ_TOPLEFT) or (Msg.wParam = WMSZ_BOTTOMLEFT) or (Msg.wParam = WMSZ_TOPRIGHT) then
begin
PR := Pointer( Msg.lParam );
GetWindowRect( Sender.fHandle, R );
PostMessage( Sender.fHandle, CM_SIZEPOS, LoWord( PR.Left) or (PR.Top shl 16),
LoWord( PR.Right - PR.Left ) or ( (PR.Bottom - PR.Top) shl 16) );
if Msg.wParam = WMSZ_TOPLEFT then
if Abs( R.Top - PR.Top ) < Abs( R.Left - PR.Left ) then
PR.Top := R.Top
else
PR.Left := R.Left
else
if Msg.wParam = WMSZ_BOTTOMLEFT then
if Abs( R.Bottom - PR.Bottom ) < Abs( R.Left - PR.Left ) then
PR.Bottom := R.Bottom
else
PR.Left := R.Left
else // WMSZ_TOPRIGHT
if Abs( R.Top - PR.Top ) < Abs( R.Right - PR.Right ) then
PR.Top := R.Top
else
PR.Right := R.Right;
Sender.fNotUpdate := True;
Rslt := 1;
Result := TRUE;
end;
end;
CM_SIZEPOS:
begin
Sender.fNotUpdate := False;
SetWindowPos( Sender.fHandle, 0, SmallInt( LoWord( Msg.wParam ) ),
SmallInt( HiWord( Msg.wParam ) ), SmallInt( LoWord( Msg.lParam ) ),
SmallInt( HiWord( Msg.lParam ) ), SWP_NOZORDER or SWP_NOACTIVATE );
end;
WM_PAINT:
begin
if Sender.fNotUpdate then
begin
Rslt := 0;
Result := True;
end;
end;
WM_ERASEBKGND:
begin
if Sender.fNotUpdate then
begin
Rslt := 1;
Result := True;
end;
end;
end;
end;
//*
//[function TControl.PreventResizeFlicks]
function TControl.PreventResizeFlicks: PControl;
begin
fWndProcResizeFlicks := WndProcPreventResizeFlicks;
Result := @Self;
end;
//*
//[procedure TControl.Update]
procedure TControl.Update;
var I: Integer;
C: PControl;
begin
if fUpdateCount > 0 then
Exit;
if fNotUpdate then Exit;
if fHandle = 0 then Exit;
UpdateWindow( fHandle );
for I := 0 to fChildren.fCount - 1 do
begin
C := fChildren.fItems[ I ];
C.Update;
end;
end;
//[FUNCTION WndProcUpdate]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
if Sender.fUpdateCount <> 0 then
begin
case Msg.message of
WM_PAINT:
begin
ValidateRect( Sender.Handle, nil );
Rslt := 0;
end;
WM_ERASEBKGND: Rslt := 1;
else begin
Result := FALSE;
Exit;
end;
end;
Result := TRUE;
end
else Result := FALSE;
end;
{$ENDIF ASM_VERSION}
//[END WndProcUpdate]
//[procedure TControl.BeginUpdate]
procedure TControl.BeginUpdate;
begin
Inc( fUpdateCount );
AttachProc( @WndProcUpdate );
end;
//[procedure TControl.EndUpdate]
procedure TControl.EndUpdate;
begin
Dec( fUpdateCount );
if fUpdateCount <= 0 then
begin
Invalidate;
//Update;
end;
end;
//*
//[function TControl.GetSelection]
function TControl.GetSelection: KOLString;
var L: Integer;
begin
if fCommandActions.aGetSelection <> 0 then
begin
L := SelLength;
SetString( Result, nil, L + 1 );
Perform( fCommandActions.aGetSelection, 0, Integer( @Result[ 1 ] ) );
end
else
Result := Copy( Text, SelStart + 1, SelLength );
end;
//*
//[procedure TControl.SetSelection]
procedure TControl.SetSelection(const Value: KOLString);
begin
ReplaceSelection( Value, True );
end;
//*
//[procedure TControl.ReplaceSelection]
procedure TControl.ReplaceSelection(const Value: KOLString; aCanUndo: Boolean);
begin
if fCommandActions.aReplaceSel <> 0 then
begin
Perform( fCommandActions.aReplaceSel, Integer( aCanUndo ), Integer( PKOLchar( Value ) ) );
end;
end;
//[procedure TControl.DeleteLines]
procedure TControl.DeleteLines(FromLine, ToLine: Integer);
var I1, I2: DWORD;
SStart, SLength: DWORD;
begin
if FromLine > ToLine then Exit;
Assert( FromLine >= 0, 'Incorrect line index' );
I1 := Item2Pos( FromLine );
I2 := Item2Pos( ToLine+1 ) - I1;
SStart := SelStart;
SLength := SelLength;
SelStart := I1;
{if ToLine >= Count-1 then
I2 := MaxInt;}
SelLength := I2;
ReplaceSelection( '', TRUE );
if SStart >= I2 then
begin
SStart := SStart - (I2 - I1);
end
else
if SStart >= I1 then
begin
SLength := SLength - (I2 - SStart);
SStart := I1;
end
else
if SStart + SLength >= I2 then
begin
SLength := SLength - (I2 - I1);
end
else
if SStart + SLength >= I1 then
begin
SLength := I1 - SLength;
end;
SelStart := SStart;
SelLength := Max( 0, SLength );
end;
//*
//[procedure TControl.SetTabOrder]
procedure TControl.SetTabOrder(const Value: Integer);
var CL: PList;
I : Integer;
C: PControl;
begin
if Value = fTabOrder then Exit;
CL := CollectTabControls( ParentForm );
for I := 0 to CL.fCount - 1 do
begin
C := CL.fItems[ I ];
if C.fTabOrder >= Value then
Inc( C.fTabOrder );
end;
fTabOrder := Value;
CL.Free;
end;
//*
//[function TControl.GetFocused]
function TControl.GetFocused: Boolean;
begin
if fIsControl then
Result := ParentForm.fCurrentControl = @Self
else
Result := GetForegroundWindow = fHandle;
end;
//*
//[procedure TControl.SetFocused]
procedure TControl.SetFocused(const Value: Boolean);
var PF: PControl;
begin
if not Value or not fTabStop then Exit;
if fIsControl then
begin
PF := ParentForm;
if Assigned( PF.fCurrentControl ) and (PF.fCurrentControl <> @ Self) then
if Assigned( PF.fCurrentControl.fLeave ) then
PF.fCurrentControl.fLeave( PF.fCurrentControl )
else
Windows.SetFocus( 0 );
PF.fCurrentControl := @Self;
if Assigned( fSetFocus ) then
fSetFocus
else
SetFocus( GetWindowHandle );
end
else
SetForegroundWindow( GetWindowHandle );
end;
{$IFNDEF NOT_USE_RICHEDIT}
type
PCharFormat = ^TCharFormat;
//////////////////////////////////////////////////////////////////////
// R I C H E D I T
//////////////////////////////////////////////////////////////////////
{ -- rich edit -- }
//*
//[function TControl.REGetFont]
function TControl.REGetFont: PGraphicTool;
var CF: PCharFormat;
FS: TFontStyle;
begin
CF := @fRECharFormatRec;
FillChar( CF^, Sizeof( CF^ ), #0 );
{$IFDEF UNICODE_CTRLS}
CF.cbSize := Sizeof( CF^ );
{$ELSE}
CF.cbSize := sizeof( RichEdit.TCharFormat ) + fCharFmtDeltaSz;
{$ENDIF}
if fTmpFont = nil then
begin
fTmpFont := NewFont;
{$IFDEF USE_AUTOFREE4CONTROLS}
Add2AutoFree( fTmpFont );
{$ENDIF}
end;
Result := fTmpFont;
Result.OnChange := nil;
Perform( EM_GETCHARFORMAT, 1, Integer( CF ) );
Result.FontHeight := CF.yHeight;
FS := [ ];
if LongBool(CF.dwEffects and CFE_BOLD) then
FS := [ fsBold ];
if LongBool(CF.dwEffects and CFE_ITALIC) then
FS := FS + [ fsItalic ];
if LongBool(CF.dwEffects and CFE_STRIKEOUT) then
FS := FS + [ fsStrikeOut ];
if LongBool(CF.dwEffects and CFE_UNDERLINE) then
FS := FS + [ fsUnderline ];
Result.FontStyle := FS;
if not LongBool(CF.dwEffects and CFE_AUTOCOLOR) then
Result.Color := CF.crTextColor;
Result.FontPitch := TFontPitch( CF.bPitchAndFamily and 3 );
Result.FontCharset := CF.bCharSet;
Result.FontName := CF.szFaceName;
Result.OnChange := RESetFont;
end;
const RichAreas: array[ TRichFmtArea ] of Integer = ( SCF_SELECTION,
SCF_WORD, 4 {SCF_ALL} );
//*
//[procedure TControl.RESetFontEx]
procedure TControl.RESetFontEx(const Index: Integer);
var CF: PCharFormat;
FS: TFontStyle;
begin
CF := @fRECharFormatRec;
FillChar( CF^, {82} sizeof( CF^ ), #0 );
{$IFDEF UNICODE_CTRLS}
CF.cbSize := Sizeof( CF^ );
{$ELSE}
CF.cbSize := 60 { sizeof( TCharFormat ) } + fCharFmtDeltaSz;
{$ENDIF}
CF.dwMask := CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC
or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE;
CF.yHeight := fTmpFont.FontHeight;
FS := fTmpFont.FontStyle;
if fsBold in FS then CF.dwEffects := CFE_BOLD;
if fsItalic in FS then CF.dwEffects := CF.dwEffects or CFE_ITALIC;
if fsStrikeOut in FS then CF.dwEffects := CF.dwEffects or CFE_STRIKEOUT;
if fsUnderline in FS then CF.dwEffects := CF.dwEffects or CFE_UNDERLINE;
CF.crTextColor := Color2RGB(fTmpFont.Color);
CF.bCharSet := fTmpFont.FontCharset;
CF.bPitchAndFamily := Ord( fTmpFont.FontPitch );
{$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
( CF.szFaceName, PKOLChar( fTmpFont.FontName ), 31 );
Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( CF ) );
end;
//*
//[procedure TControl.RESetFont]
procedure TControl.RESetFont(Value: PGraphicTool);
var H: Integer;
begin
if Value <> fTmpFont then
REGetFont;
H := fTmpFont.fData.Font.Height;
fTmpFont := fTmpFont.Assign( Value );
if fTmpFont.fData.Font.Height = 0 then
fTmpFont.fData.Font.Height := H;
RESetFontEx( Integer( CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC
or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE ) );
end;
//*
//[function TControl.REGetFontMask]
function TControl.REGetFontMask( const Index: Integer ): Boolean;
begin
REGetFont;
Result := LongBool( fRECharFormatRec.dwMask and Index );
end;
//*
//[function TControl.REGetFontEffects]
function TControl.REGetFontEffects(const Index: Integer): Boolean;
begin
REGetFont;
Result := LongBool( fRECharFormatRec.dwEffects and Index );
end;
//*
//[procedure TControl.RESetFontEffect]
procedure TControl.RESetFontEffect(const Index: Integer;
const Value: Boolean);
var CF: PCharFormat;
begin
ReGetFont;
CF := @fRECharFormatRec;
CF.dwEffects := $FFFFFFFF and Index;
if not Value then CF.dwEffects := 0;
CF.dwMask := Index;
Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( CF ) );
end;
//*
//[function TControl.REGetFontAttr]
function TControl.REGetFontAttr(const Index: Integer): Integer;
var CF: PDWORD;
Mask: DWORD;
begin
REGetFont;
CF := Pointer( cardinal( @fRECharFormatRec ) + (HiWord(Index) and $7E) );
Mask := $FFFFFFFF;
if LongBool( HiWord(Index) and $1 ) then
Mask := $FF;
Result := CF^ and Mask;
end;
//*
//[procedure TControl.RESetFontAttr]
procedure TControl.RESetFontAttr(const Index, Value: Integer);
var CF: PDWORD;
Mask: DWORD;
begin
REGetFont;
CF := Pointer( cardinal( @fRECharFormatRec ) + (HiWord(Index) and $7E) );
Mask := 0;
if LongBool( HiWord(Index) and $1 ) then
Mask := $FFFFFF00;
CF^ := CF^ and Mask or DWORD(Value);
fRECharFormatRec.dwMask := Index and $FF81FFFF;
if LongBool( fRECharFormatRec.dwMask and (CFM_COLOR or CFM_BACKCOLOR) ) then
fRECharFormatRec.dwEffects := fRECharFormatRec.dwEffects and
not (CFE_AUTOCOLOR or CFE_AUTOBACKCOLOR);
Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( @fRECharFormatRec ) );
end;
//[procedure TControl.RESetFontAttr1]
procedure TControl.RESetFontAttr1(const Index, Value: Integer);
begin
RESetFontAttr( Index, Color2RGB( Value ) );
end;
//*
//[function TControl.REGetFontSizeValid]
function TControl.REGetFontSizeValid: Boolean;
begin
Result := REGetFontMask( Integer( CFM_SIZE ) );
end;
//*
//[function TControl.REGetFontName]
function TControl.REGetFontName: KOLString;
begin
ReGetFont;
Result := fRECharFormatRec.szFaceName;
end;
//*
//[procedure TControl.RESetFontName]
procedure TControl.RESetFontName(const Value: KOLString);
begin
ReGetFont;
{$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
( fRECharFormatRec.szFaceName, PKOLChar( Value ), Sizeof( fRECharFormatRec.szFaceName ) - 1 );
fRECharFormatRec.dwMask := CFM_FACE;
Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( @fRECharFormatRec ) );
end;
//*
//[function TControl.REGetCharformat]
function TControl.REGetCharformat: TCharFormat;
begin
REGetFont;
Result := fRECharFormatRec;
end;
//*
//[procedure TControl.RESetCharFormat]
procedure TControl.RESetCharFormat(const Value: TCharFormat);
begin
Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( @Value ) );
end;
//*
//[function REOut2Stream]
function REOut2Stream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger )
:DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
if Sz + Sender.fREStream.Position > Sender.fREStream.Size then
Sender.fREStream.Size := Sender.fREStream.Size + DWORD( {Min(} Sz {, 8192 )} );
pSz^ := Sender.fREStream.Write( Buf^, Sz );
if Assigned( Sender.fOnProgress ) then
Sender.fOnProgress( Sender );
Result := 0;
end;
const TextTypes: array[ TRETextFormat ] of WORD = ( SF_RTF, SF_TEXT,
SF_RTF or SFF_PLAINRTF, SF_RTFNOOBJS, SF_RTFNOOBJS or SFF_PLAINRTF,
SF_TEXTIZED, {SF_UNICODE} $0010, $0010 or SF_TEXT );
//*
//[function TControl.RE_SaveToStream]
function TControl.RE_SaveToStream(Stream: PStream; Format: TRETextFormat;
SelectionOnly: Boolean): Boolean;
var ES: TEditStream;
SelFlag: Integer;
begin
fREStream := Stream;
ES.dwCookie := Integer( @Self );
ES.dwError := 0;
ES.pfnCallback := @REOut2Stream;
SelFlag := 0;
if SelectionOnly then
SelFlag := SFF_SELECTION;
Perform( EM_STREAMOUT, TextTypes[ Format ] or SelFlag, Integer( @ES ) );
fREStream := nil;
fREError := ES.dwError;
Result := fREError = 0;
end;
//[procedure RE_AddText]
procedure RE_AddText( Self_: PControl; const S: String );
begin
Self_.SelStart := Self_.TextSize;
Self_.RE_Text[ reText, True ] := S;
end;
//*
//[function TControl.REReadText]
function TControl.REReadText(Format: TRETextFormat;
SelectionOnly: Boolean): KOLString;
var B0: Integer;
MS: PStream;
begin
fCommandActions.aAddText := RE_AddText;
MS := NewMemoryStream;
RE_SaveToStream( MS, Format, SelectionOnly );
B0 := 0;
MS.Write( B0, Sizeof( KOLChar ) );
if not (Format in [reUnicode,reTextUnicode]) then
Result := PChar( MS.fMemory ) // must be PChar, not PKOLChar!
else
Result := PKOLChar( MS.fMemory );
MS.Free;
end;
//*
//[function REInFromStream]
function REInFromStream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger )
:DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
{$IFDEF _D3} if Sender.fREStrLoadLen >= 0 then {$ENDIF}
if Sz > Sender.fREStrLoadLen then
Sz := Sender.fREStrLoadLen;
pSz^ := Sender.fREStream.Read( Buf^, Sz );
Dec( Sender.fREStrLoadLen, pSz^ );
if Assigned( Sender.fOnProgress ) then
Sender.fOnProgress( Sender );
Result := 0;
end;
//*
//[function TControl.RE_LoadFromStream]
function TControl.RE_LoadFromStream(Stream: PStream; Length: Integer;
Format: TRETextFormat; SelectionOnly: Boolean): Boolean;
var ES: TEditStream;
SelFlag: Integer;
begin
fREStream := Stream;
fREStrLoadLen := DWORD( Length );
ES.dwCookie := Integer( @Self );
ES.dwError := 0;
ES.pfnCallback := @REInFromStream;
SelFlag := 0;
if SelectionOnly then
SelFlag := SFF_SELECTION;
Perform( EM_STREAMIN, TextTypes[ Format ] or SelFlag, Integer( @ES ) );
fREStream := nil;
fREError := ES.dwError;
Result := fREError = 0;
end;
//*
//[procedure TControl.REWriteText]
procedure TControl.REWriteText(Format: TRETextFormat;
SelectionOnly: Boolean; const Value: KOLString);
var MS: PStream;
s: String; // not KOLString!
begin
fCommandActions.aAddText := RE_AddText;
if not (Format in [reUnicode,reTextUnicode]) then
begin
s := Value;
MS := NewExMemoryStream( @ s[ 1 ], Length( s ) );
end
else
MS := NewExMemoryStream( @ Value[ 1 ], Length( Value ) * Sizeof( KOLChar ) );
RE_LoadFromStream( MS, MS.fData.fSize, Format, SelectionOnly );
MS.Free;
end;
//*
//[function TControl.RE_LoadFromFile]
function TControl.RE_LoadFromFile(const Filename: KOLString;
Format: TRETextFormat; SelectionOnly: Boolean): Boolean;
var Strm: PStream;
begin
Strm := NewReadFileStream( Filename );
Result := RE_LoadFromStream( Strm, -1, Format, SelectionOnly );
Strm.Free;
end;
//*
//[function TControl.RE_SaveToFile]
function TControl.RE_SaveToFile(const Filename: KOLString;
Format: TRETextFormat; SelectionOnly: Boolean): Boolean;
var Strm: PStream;
begin
Strm := NewWriteFileStream( Filename );
Result := RE_SaveToStream( Strm, Format, SelectionOnly );
Strm.Free;
end;
//*
//[function TControl.REGetParaFmt]
function TControl.REGetParaFmt: TParaFormat;
begin
FillChar( Result, sizeof( TParaFormat2 ), #0 );
Result.cbSize := sizeof( RichEdit.TParaFormat ) + fParaFmtDeltaSz;
Perform( EM_GETPARAFORMAT, 0, Integer( @Result ) );
end;
//*
//[procedure TControl.RESetParaFmt]
procedure TControl.RESetParaFmt(const Value: TParaFormat);
begin
//Value.cbSize := szTParaFmtRec;
Perform( EM_SETPARAFORMAT, 0, Integer( @Value ) );
end;
//*
//[function TControl.REGetNumbering]
function TControl.REGetNumbering: Boolean;
begin
Result := LongBool( ReGetParaAttr( 9 shl 16 ) );
end;
//*
//[function TControl.REGetParaAttr]
function TControl.REGetParaAttr( const Index: Integer ): Integer;
var pDw : PDWORD;
begin
fREParaFmtRec := REGetParaFmt;
pDw := Pointer( cardinal( @fREParaFmtRec ) + ( HiWord( Index ) and $7E ) );
Result := pDw^;
if LongBool( HiWord( Index ) and 1 ) then
Result := Result and $FFFF;
end;
//*
//[function TControl.REGetParaAttrValid]
function TControl.REGetParaAttrValid( const Index: Integer ): Boolean;
begin
Result := LongBool( ReGetParaAttr( 4 shl 16 ) and Index );
end;
//*
//[function TControl.REGetTabCount]
function TControl.REGetTabCount: Integer;
begin
Result := ReGetParaAttr( 27 shl 16 );
end;
//*
//[function TControl.REGetTabs]
function TControl.REGetTabs(Idx: Integer): Integer;
begin
Result := ReGetParaAttr( (28 + 4 * Idx) shl 16 );
end;
//*
//[function TControl.REGetTextAlign]
function TControl.REGetTextAlign: TRichTextAlign;
begin
Result := TRichTextAlign( ReGetParaAttr( 25 shl 16 ) - 1 );
end;
//*
//[procedure TControl.RESetNumbering]
procedure TControl.RESetNumbering(const Value: Boolean);
begin
RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Integer( Value ) );
end;
//*
//[procedure TControl.RESetParaAttr]
procedure TControl.RESetParaAttr(const Index, Value: Integer);
var pDw: PDWORD;
Mask: Integer;
begin
REGetParaAttr( 0 );
pDw := Pointer( cardinal( @fREParaFmtRec ) + ( HiWord( Index ) and $7E ) );
Mask := 0;
if LongBool( HiWord( Index ) and 1 ) then
Mask := Integer( $FFFF0000 );
pDw^ := pDw^ and Mask or DWORD(Value);
fREParaFmtRec.dwMask := Index and $8000FFFF;
RESetParaFmt( fREParaFmtRec );
end;
//*
//[procedure TControl.RESetTabCount]
procedure TControl.RESetTabCount(const Value: Integer);
begin
REGetParaAttr( 0 );
RESetParaAttr( (27 shl 16) or PFM_TABSTOPS, Value );
end;
//*
//[procedure TControl.RESetTabs]
procedure TControl.RESetTabs(Idx: Integer; const Value: Integer);
begin
REGetParaAttr( 0 );
RESetParaAttr( (28 + 4 * Idx) or PFM_TABSTOPS, Value );
end;
//*
//[procedure TControl.RESetTextAlign]
procedure TControl.RESetTextAlign(const Value: TRichTextAlign);
begin
RESetParaAttr( (25 shl 16) or PFM_ALIGNMENT, Ord( Value ) + 1 );
end;
//*
//[function TControl.REGetStartIndentValid]
function TControl.REGetStartIndentValid: Boolean;
begin
Result := REGetParaAttrValid( Integer( PFM_STARTINDENT ) );
end;
//*
//[procedure TControl.RE_HideSelection]
procedure TControl.RE_HideSelection(aHide: Boolean);
begin
Perform( EM_HIDESELECTION, Integer( aHide ), 1 );
end;
//*
//[function TControl.RE_SearchText]
function TControl.RE_SearchText(const Value: KOLString; MatchCase,
WholeWord, ScanForward: Boolean; SearchFrom, SearchTo: Integer): Integer;
var Flags: Integer;
FT: {$IFDEF UNICODE_CTRLS} TFindTextW {$ELSE}
{$IFDEF _D2} TFindText {$ELSE} TFindTextA {$ENDIF} {$ENDIF};
begin
Flags := Integer( ScanForward );
if WholeWord then Flags := Flags or FT_WHOLEWORD;
if MatchCase then Flags := Flags or FT_MATCHCASE;
FT.chrg.cpMin := SearchFrom;
FT.chrg.cpMax := SearchTo;
FT.lpstrText := PKOLChar( Value );
Result := Perform( EM_FINDTEXT, Flags, Integer( @FT ) );
end;
{$IFNDEF _FPC}
{$IFNDEF _D2} //------- WideString not supported in D2
//[function TControl.RE_WSearchText]
function TControl.RE_WSearchText(const Value: WideString; MatchCase,
WholeWord, ScanForward: Boolean; SearchFrom, SearchTo: Integer): Integer;
var Flags: Integer;
FT: TFindTextW;
begin
Flags := Integer( ScanForward );
if WholeWord then Flags := Flags or FT_WHOLEWORD;
if MatchCase then Flags := Flags or FT_MATCHCASE;
FT.chrg.cpMin := SearchFrom;
FT.chrg.cpMax := SearchTo;
FT.lpstrText := PWideChar( Value );
Result := Perform( WM_USER+123 {EM_FINDTEXTW}, Flags, Integer( @FT ) );
end;
{$ENDIF}{$ENDIF}
{$ENDIF NOT_USE_RICHEDIT}
//*
//[function TControl.CanUndo]
function TControl.CanUndo: Boolean;
begin
Result := LongBool( Perform( EM_CANUNDO, 0, 0 ) );
end;
//*
//[procedure TControl.EmptyUndoBuffer]
procedure TControl.EmptyUndoBuffer;
begin
Perform( EM_EMPTYUNDOBUFFER, 0, 0 );
end;
//*
//[function TControl.Undo]
function TControl.Undo: Boolean;
begin
Result := LongBool( Perform( EM_UNDO, 0, 0 ) );
end;
//*
//[function TControl.GetMaxTextSize]
function TControl.GetMaxTextSize: DWORD;
begin
Result := Perform( EM_GETLIMITTEXT, 0, 0 );
end;
//*
//[procedure TControl.SetMaxTextSize]
procedure TControl.SetMaxTextSize(const Value: DWORD);
var V1, V2: Integer;
begin
if fCommandActions.aSetLimit <> 0 then
begin
V1 := 0; V2 := Value;
if fCommandActions.aSetLimit = EM_SETLIMITTEXT then
begin
V1 := Value; V2 := 0;
end;
Perform( fCommandActions.aSetLimit, V1, V2 );
end;
end;
{$IFNDEF NOT_USE_RICHEDIT}
//*
//[function TControl.RE_Redo]
function TControl.RE_Redo: Boolean;
begin
Result := LongBool( Perform( EM_REDO, 0, 0 ) );
end;
//*
//[function TControl.REGetAutoURLDetect]
function TControl.REGetAutoURLDetect: Boolean;
begin
Result := LongBool( Perform( EM_GETAUTOURLDETECT, 0, 0 ) );
end;
//*
//[procedure TControl.RESetAutoURLDetect]
procedure TControl.RESetAutoURLDetect(const Value: Boolean);
begin
AttachProc( WndProc_RE_LinkNotify );
Perform( EM_AUTOURLDETECT, Integer( Value ), 0 );
end;
procedure TControl.RESetZoom( const Value: TSmallPoint );
begin
Perform( EM_SETZOOM, Value.x, Value.y );
end;
function TControl.REGetZoom: TSmallPoint;
var P: TPoint;
begin
Perform( EM_GETZOOM, Integer( @ P.X ), Integer( @ P.Y ) );
Result := Point2SmallPoint( P );
end;
//*
//[function WndProc_REFmt]
function WndProc_REFmt( _Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Mask: Integer;
Shft, Alt, Ctrl, Flg: Boolean;
Delta: Integer;
TA: TRichTextAlign;
ChgTA: Boolean;
US: TRichUnderline;
NS: TRichNumbering;
NB: TRichNumBrackets;
Side: TBorderEdge;
Param: DWORD;
begin
Result := False;
if Msg.message = WM_CHAR then
if _Self_.FSupressTab then
begin
_Self_.FSupressTab := FALSE;
if Msg.wParam = 9 then
begin
Result := TRUE;
Exit;
end;
end;
if (Msg.message = WM_KEYDOWN) or (Msg.message = WM_SYSKEYDOWN) then
begin
Ctrl := GetKeyState( VK_CONTROL ) < 0;
Alt := GetKeyState( VK_MENU ) < 0;
Param := Msg.wParam;
if Ctrl or
Alt and IntIn(Param, [ VK_ADD, VK_SUBTRACT, Integer( '-' ), Integer( '=' ),
Integer( '+' ), 189 {-}, 187 {+} ]) then
begin
Shft := GetKeyState( VK_SHIFT ) < 0;
Rslt := 0;
Result := True;
Mask := 0;
ChgTA := False; TA := raLeft;
case Param of
Integer('Z'):
begin
if Shft then
begin
_Self_.RE_Redo;
Exit;
end;
Result := False;
end;
Integer('L'): begin ChgTA := True; TA := raLeft; end;
Integer('R'): begin ChgTA := True; TA := raRight; end;
Integer('E'): begin ChgTA := True; TA := raCenter; end;
Integer('J'): begin ChgTA := True; TA := raJustify; end;
Integer('N'): begin
if Shft then
begin
NS := _Self_.RE_NumStyle;
NB := _Self_.RE_NumBrackets;
if NS = rnBullets then
begin
_Self_.RE_NumStyle := rnNone;
Exit;
end;
if NS = rnNone then
begin
_Self_.RE_NumStyle := rnBullets;
//NB := rnbPlain;
Exit;
end
else
if Ord( NB ) = 0 then
NB := High(NB) else
NB := Pred(NB);
_Self_.RE_NumBrackets := NB;
end
else
begin
NS := _Self_.RE_NumStyle;
if Ord( NS ) = 0 then
begin
NS := rnURoman; //rnULetter; //High( NS );
{ because rnLRoman, rnURoman, rnNoNumber are not shown
in RichEdit. }
_Self_.RE_NumBrackets := rnbPeriod;
end else
NS := Pred(NS);
_Self_.RE_NumStyle := NS;
if NS in [ rnLRoman, rnURoman, rnArabic ] then
_Self_.RE_NumStart := 1;
end;
Exit;
end;
Integer('W'): begin
Delta := _Self_.RE_BorderWidth[ beLeft ] + 4;
if Shft then Delta := -1;
for Side := Low(Side) to High(Side) do
begin
if Delta < 0 then
_Self_.RE_BorderStyle[ Side ] := _Self_.RE_BorderStyle[ Side ] + 1
else
begin
_Self_.RE_BorderWidth[ Side ] := Delta;
_Self_.RE_BorderSpace[ Side ] := Delta;
end;
end;
Exit;
end;
(* TABLES STUFF -- to try, uncomment it and press CTRL+T in RichEdit.
(and uncomment declaration for Tmp above).
Not finished, and seems no way to figure it out - even RichEdit20.dll
(i.e. Rich Edit v3.0) can not display tables properly formatted. :(((
Integer('T'): begin
if _Self_.RE_Table then
begin
//MsgOK( 'table' );
end;
Tmp := _Self_.REReadText( reRTF, True );
if StrIsStartingFrom( PChar(Tmp), '{\rtf' )
and (CopyTail( Tmp, 3 ) = '}'#$D#$A) then
begin
//Tmp := Copy( Tmp, 1, Length(Tmp) - 3 );
_Self_.RE_Text[ reRTF, True ] := '{\rtf1' + //Copy( Tmp, 1, 6 ) +
'\trowd' +
//'\lytcalctblwd' +
//'\oldlinewrap' +
//'\alntblind' +
//'\trgaph108' +
'\trleft-108' +
{'\trbrdrt\brdrs\brdrw10' +
'\trbrdrl\brdrs\brdrw10' +
'\trbrdrb\brdrs\brdrw10' +
'\trbrdrr\brdrs\brdrw10' +
'\trbrdrh\brdrs\brdrw10' +
'\trbrdrv\brdrs\brdrw10' +}
//'\clvertalt' +
{'\clbrdrt\brdrs\brdrw10' +
'\clbrdrl\brdrs\brdrw10' +
'\clbrdrb\brdrs\brdrw10' +
'\clbrdrr\brdrs\brdrw10' +}
//'\cltxlrtb' +
'\cellx1414' +
//'\pard' +
//'\plain' +
//'\widctlpar' +
'\trautofit1' +
'\intbl' +
//'\adjustright' +
//'\fs20\lang1049' +
//'\cgrid' +
'\trrh0' +
'{\clFitText{{\box\brdrs\brdrw20\brsp20}'+
'\par}\cell\row}' +
//'\pard\widctlpar' +
//'\intbl'+
//'\adjustright'+
//'{\row}' +
'\pard\widctlpar' +
'}'#$D#$A;
_Self_.Perform( WM_KEYDOWN, VK_UP, 0 );
_Self_.Perform( WM_KEYUP, VK_UP, 0 );
end;
Exit;
end;
*)
Integer('B'): Mask := CFM_BOLD;
Integer('I'):
begin
Mask := CFM_ITALIC;
_Self_.FSupressTab := TRUE;
end;
Integer('U'):
begin
if Shft then
begin
US := _Self_.RE_FmtUnderlineStyle;
if Ord(US) = 0 then US := High(TRichUnderLine)
else US := Pred( US );
_Self_.RE_FmtUnderlineStyle := US;
Exit;
end;
Mask := CFM_UNDERLINE;
end;
Integer('O'): Mask := CFM_STRIKEOUT;
VK_SUBTRACT, VK_ADD, Integer( '+' ), 187, Integer( '-' ), 189:
;
else
begin
Result := False;
Msg.wParam := Param;
end;
end;
if not Result then Exit;
if ChgTA then
begin
if Shft then Result := False
else _Self_.RE_TextAlign := TA;
Exit;
end;
_Self_.REGetFont;
if Mask > 0 then
begin
if Shft then Result := False
else begin
Flg := _Self_.REGetFontEffects( Mask );
if not Flg then
_Self_.fRECharFormatRec.dwEffects := _Self_.fRECharFormatRec.dwEffects and not Mask;
_Self_.fRECharFormatRec.dwEffects := _Self_.fRECharFormatRec.dwEffects xor DWORD(Mask);
end;
end
else
if IntIn( Param, [ VK_ADD, VK_SUBTRACT, Integer( '+' ),
Integer( '-' ), 189, 187 ] ) then
begin
if (Param = VK_SUBTRACT) or (Param = DWORD( '-' )) or (Param = 189) then
Delta := -1
else
Delta := 1;
if Alt and Ctrl then
begin
Mask := Integer( CFM_SIZE ) or Integer( CFM_OFFSET );
Delta := 0;
_Self_.fRECharFormatRec.yOffset := 0;
_Self_.fRECharFormatRec.yHeight := 200;
end
else
if Alt then Mask := Integer( CFM_SIZE )
else Mask := Integer( CFM_OFFSET );
Inc( _Self_.fRECharFormatRec.yOffset, Delta * _Self_.fRECharFormatRec.yHeight div 3 );
Inc( _Self_.fRECharFormatRec.yHeight, Delta * _Self_.fRECharFormatRec.yHeight div 8 );
Flg := LongBool( _Self_.fRECharFormatRec.dwMask and Mask );
if not Flg then
_Self_.fRECharFormatRec.yOffset := 0;
end;
_Self_.fRECharFormatRec.dwMask := Mask;
if _Self_.SelLength = 0 then
_Self_.SelLength := 1;
_Self_.Perform( EM_SETCHARFORMAT, SCF_SELECTION { RichAreas[ _Self_.fRECharArea ] }, Integer( @_Self_.fRECharFormatRec ) );
end;
end;
end;
//*
//[function TControl.RE_FmtStandard]
function TControl.RE_FmtStandard: PControl;
begin
AttachProc( WndProc_REFmt );
Result := @Self;
end;
procedure TControl.RE_CancelFmtStandard;
begin
DetachProc( WndProc_REFmt );
end;
{$ENDIF NOT_USE_RICHEDIT}
//[FUNCTION EnumDynHandlers]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
Proc: TWindowFunc;
begin
Result := False;
if Self_.fRefCount < 0 then Exit;
if (Self_.fDynHandlers = nil) or (Self_.fDynHandlers.fCount = 0) then Exit;
Self_.RefInc; // Prevent destroying Self_
for I := Self_.fDynHandlers.fCount div 2 - 1 downto 0 do
begin
Proc := Self_.fDynHandlers.fItems[ I * 2 ];
{$IFNDEF SMALLEST_CODE}
{$IFNDEF ENUM_DYN_HANDLERS_AFTER_RUN}
if not AppletTerminated or (Self_.fDynHandlers.fItems[ I * 2 + 1 ] <> nil) then
{$ENDIF}
{$ENDIF}
if Proc( Self_, Msg, Rslt ) then
begin
Result := True;
break;
end;
end;
{$IFDEF DEBUG_ENDSESSION}
if EndSession_Initiated then
begin
LogFileOutput( GetStartDir + 'es_debug.txt',
'ENUM_DYN_HANDLERS: Self_:' + Int2Hex( DWORD( Self_ ), 8 ) );
LogFileOutput( GetStartDir + 'es_debug.txt',
'ENUM_DYN_HANDLERS: Self_.fRefCount:' + Int2Str( Self_.fRefCount ) );
end;
{$ENDIF}
if LongBool(Self_.fRefCount and 1) then
Result := True; // If Self_ will be destroyed now, stop further processing
Self_.RefDec; // Destroy Self_, if Free was called for it while processing attached procedures
end;
{$ENDIF ASM_VERSION}
//[END EnumDynHandlers]
{$ifdef win32}
procedure TransparentAttachProcExtension ( DynHandlers: PList );
var i: integer;
begin
I := DynHandlers.IndexOf( @WndProcTransparent );
if I >=0 then begin
DynHandlers.Delete( I );
DynHandlers.Delete( I );
DynHandlers.Add( @WndProcTransparent );
DynHandlers.Add( nil );
end;
end;
{$endif win32}
procedure DummyAttachProcExtension ( DynHandlers: PList );
begin
end;
//[procedure TControl.AttachProcEx]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
procedure TControl.AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );
begin
//if fDynHandlers = nil then
// fDynHandlers := NewList;
if not IsProcAttached( Proc ) then
begin
fDynHandlers.Add( @Proc );
fDynHandlers.Add( Pointer( Integer( ExecuteAfterAppletTerminated ) ) );
end;
{$IFNDEF SMALLEST_CODE}
Global_AttachProcExtension(fDynHandlers);
{$ENDIF}
fOnDynHandlers := EnumDynHandlers;
end;
{$ENDIF ASM_VERSION}
//[procedure TControl.AttachProc]
procedure TControl.AttachProc(Proc: TWindowFunc);
begin
AttachProcEx( Proc, FALSE );
end;
//*
//[procedure TControl.DetachProc]
procedure TControl.DetachProc(Proc: TWindowFunc);
var I: Integer;
begin
if fDynHandlers = nil then Exit;
I := fDynHandlers.IndexOf( @Proc );
if I >=0 then
begin
fDynHandlers.Delete( I );
fDynHandlers.Delete( I );
end;
end;
//[function TControl.IsProcAttached]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.IsProcAttached(Proc: TWindowFunc): Boolean;
var I: Integer;
begin
//Result := False;
//if fDynHandlers = nil then Exit;
I := fDynHandlers.IndexOf( @Proc );
Result := I >=0;
end;
{$ENDIF ASM_VERSION}
//[function WndProcAutoPopupMenu]
function WndProcAutoPopupMenu( Control: PControl; var Msg: TMsg; var MsgRslt: Integer ): Boolean;
function GetMenuPoint: TPoint;
var
R: TRect;
I, M: Integer;
begin
R:=Control.ClientRect;
Result.x:=(R.Left + R.Right) div 2;
Result.y:=R.Bottom;
I := Control.CurIndex;
M := Control.fCommandActions.aItem2XY;
if (I >= 0) and (M <> 0) then begin
CASE M OF
EM_POSFROMCHAR:
begin
I := Control.SelStart + Control.SelLength;
I := Control.Perform( M, I, 1 );
Result.X := SmallInt( LoWord( I ) );
Result.Y := SmallInt( HiWord( I ) );
end;
LB_GETITEMRECT, LVM_GETITEMRECT, TCM_GETITEMRECT:
begin
R.Left := LVIR_BOUNDS;
Control.Perform( M, I, Integer( @ R ) );
R.Left:=Max(R.Left, 0);
R.Right:=Min(R.Right, ScreenWidth);
Result.X := (R.Left + R.Right) div 2;
Result.Y := R.Bottom;
end;
TVM_GETITEMRECT:
begin
I := Control.TVSelected;
R.Left := I;
Control.Perform( M, 1, Integer( @ R ) );
Result.X := (R.Left + R.Right) div 2;
Result.Y := R.Bottom;
end;
END;
R := Control.ClientRect;
if Result.X < R.Left then Result.X := R.Left;
if Result.X > R.Right then Result.X := R.Right;
if Result.Y < R.Top then Result.Y := R.Top;
if Result.Y > R.Bottom then Result.Y := R.Bottom;
end;
end;
var P: TPoint;
{$ifdef wince}
shrg: SHRGINFO;
{$endif wince}
begin
{$ifdef wince}
if (Control.fAutoPopupMenu <> nil) and ((Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_KEYDOWN)) then begin
if Msg.message = WM_KEYDOWN then
P:=GetMenuPoint
else begin
P.X := SmallInt( LoWord( Msg.lParam ) );
P.Y := SmallInt( HiWord( Msg.lParam ) );
end;
with shrg do begin
cbSize:=SizeOf(shrg);
hwndClient:=Control.Handle;
ptDown.x:=P.X;
ptDown.y:=P.Y;
dwFlags:=SHRG_RETURNCMD;
end;
if (SHRecognizeGesture(shrg) = GN_CONTEXTMENU) and (Msg.message = WM_KEYDOWN) then begin
MsgRslt:=0;
Result:=True;
end
else
Result:=False;
end
else
{$endif wince}
if (Msg.message = WM_CONTEXTMENU) and
(Control.fAutoPopupMenu <> nil) then
begin
{$IFDEF USE_MENU_CURCTL}
PMenu( Control.fAutoPopupMenu ).fCurCtl := Control;
{$ENDIF USE_MENU_CURCTL}
if (Msg.lParam = -1) then
P:=Control.Client2Screen(GetMenuPoint)
else begin
P.X := SmallInt( LoWord( Msg.lParam ) );
P.Y := SmallInt( HiWord( Msg.lParam ) );
end;
PMenu( Control.fAutoPopupMenu ).Popup( P.X, P.Y );
Result := TRUE;
end
else
Result := FALSE;
end;
//[procedure TControl.SetAutoPopupMenu]
procedure TControl.SetAutoPopupMenu(PopupMenu: PObj);
{ new version - by Alexander Pravdin. Allows to attach a submenu (e.g. of the
main menu) as a popup menu to a control, to avoid duplicating menu object,
if it is the same already as desired. }
var pm: PMenu;
begin
if PopupMenu <> nil then
{$IFDEF USE_MENU_CURCTL}
begin
pm := PMenu( PopupMenu );
if ( pm.FParentMenu <> nil ) then
begin
while pm.FControl = nil do
pm := pm.FParentMenu;
PMenu( PopupMenu ).FControl := pm.FControl;
end
else
if pm.FControl = nil then
PMenu( PopupMenu ).FControl := @Self;
AttachProc(WndProcAutoPopupMenu);
AttachProc(WndProcMenu)
end
else begin
DetachProc(WndProcAutoPopupMenu);
DetachProc(WndProcMenu);
end;
{$ELSE}
begin
pm := PMenu( PopupMenu );
while pm.FControl = nil do pm := pm.Parent;
PMenu( PopupMenu ).FControl := pm.FControl;
end;
{$ENDIF}
fAutoPopupMenu := PopupMenu;
{$IFNDEF USE_MENU_CURCTL}
AttachProc( WndProcAutoPopupMenu );
{$ENDIF}
end;
{$ifdef win32}
//[function SearchAnsiMnemonics]
function SearchAnsiMnemonics( const S: KOLString ): KOLString;
var I: Integer;
Sh: ShortInt;
begin
Result := S;
for I := 1 to Length( Result ) do
begin
Sh := VkKeyScanEx( Result[ I ], MnemonicsLocale );
if Sh <> -1 then
Result[ I ] := KOLChar( Sh );
end;
end;
//[procedure SupportAnsiMnemonics]
procedure SupportAnsiMnemonics( LocaleID: Integer );
begin
MnemonicsLocale := LocaleID;
SearchMnemonics := SearchAnsiMnemonics;
end;
//[function WndProcMnemonics]
function WndProcMnemonics( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Form: PControl;
function HandleMnemonic( Prnt: PControl ): Boolean;
var C: PControl;
XY: Integer;
procedure DoPressMnemonic;
begin
if Msg.message = WM_SYSKEYDOWN then
begin
Form.FPressedMnemonic := Msg.wParam;
C.Perform( WM_LBUTTONDOWN, MK_LBUTTON, XY );
end
else
begin
Form.FPressedMnemonic := 0;
C.Perform( WM_LBUTTONUP, MK_LBUTTON, XY );
end;
end;
var I, J: Integer;
R: TRect;
begin
for I := 0 to Prnt.ChildCount-1 do
begin
C := Prnt.Children[ I ];
if not C.Visible then continue; // {YS} Do not process hidden controls
if C.IsButton then
if C.Enabled then
begin
if C.fCommandActions.aGetCount = TB_BUTTONCOUNT then
for J := 0 to C.Count-1 do
begin
if C.TBButtonEnabled[ J ] then
if pos( '&' + Char( Msg.wParam ), SearchMnemonics( C.TBButtonText[ J ] ) ) > 0 then
begin
C.fCurIndex := J;
C.fCurItem := C.TBIndex2Item( J );
R := C.TBButtonRect[ J ];
XY := R.Left or (R.Top shl 16);
DoPressMnemonic;
Result := TRUE;
Exit;
end;
end;
if pos( '&' + Char( Msg.wParam ), SearchMnemonics( C.Caption ) ) > 0 then
begin
XY := 0;
DoPressMnemonic;
Result := TRUE;
Exit;
end;
end;
if HandleMnemonic( C ) then
begin
Result := TRUE;
Exit;
end;
end;
Result := FALSE;
end;
{$IFDEF NEW_MENU_ACCELL}
function FindByCtlRef(C: PControl; Accell: TMenuAccelerator): Boolean;
function FindInMenu(M: PMenu): PMenu;
var
I: Integer;
SM: PMenu;
begin
for I := 0 to M.FItems.Count - 1 do begin
Result := M.FItems.Items[I];
if (Cardinal(Result.Accelerator) = Cardinal(Accell)) and Result.Enabled then
Exit;
end;
Result := nil;
for I := 0 to M.FItems.Count - 1 do begin
SM := PMenu(M.FItems.Items[I]);
if (SM.FItems.Count > 0) then
Result := FindInMenu(SM);
if (Result <> nil) then
Break;
end;
end;
function FindInMenu2(M: PMenu): Boolean;
var
MI: PMenu;
begin
if (M <> nil) then begin
MI := FindInMenu(M);
if (MI <> nil) then begin
//M.FControl.Perform(WM_COMMAND, MI.FId, 0);
C.Perform(WM_COMMAND, MI.FId, 0); // fixed
Result := True;
Exit;
end;
end;
Result := False;
end;
var
Parent: PControl;
begin
Result := False;
if not FindInMenu2(PMenu(C.fAutoPopupMenu)) then
if not FindInMenu2(PMenu(C.fMenuObj)) then begin
Parent := C.Parent;
if (Parent <> nil) then
Result := FindByCtlRef(Parent, Accell);
end;
end;
var
Ac: TMenuAccelerator;
{$ENDIF}
begin
Result := FALSE;
if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
begin
{$IFDEF NEW_MENU_ACCELL}
Ac := MakeAccelerator(FVIRTKEY or GetShiftState, Msg.wParam);
Result := FindByCtlRef(Sender, Ac);
{$ELSE}
if (Sender.fAccelTable <> 0)
{$IFDEF KEY_PREVIEW}
and (Sender.FKeyPreviewCount = 0)
{$ENDIF}
then
Result := LongBool( TranslateAccelerator( Sender.fHandle, Sender.fAccelTable, Msg ) );
if not Result then
begin
if Sender.fCurrentControl <> nil then
if Sender.fCurrentControl.fAccelTable <> 0 then
Result := LongBool( TranslateAccelerator( Sender.fCurrentControl.fHandle,
Sender.fCurrentControl.fAccelTable, Msg ) );
end;
if not Result then
begin
Form := Sender.ParentForm;
if (Form <> nil) and (Form <> Sender)
{$IFDEF KEY_PREVIEW}
and (Form.FKeyPreviewCount = 0)
{$ENDIF KEY_PREVIEW}
then
if Form.fAccelTable <> 0 then
Result := LongBool( TranslateAccelerator( Form.fHandle,
Form.fAccelTable, Msg ) );
end;
{$ENDIF}
end;
if Result then Exit;
if (Msg.message = WM_SYSKEYUP) or
(Msg.message = WM_SYSKEYDOWN) and (GetKeyState( VK_MENU ) < 0) then
begin
Rslt := 0;
Form := Sender.ParentForm;
if Form <> nil then
begin
if Char( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then
begin
if HandleMnemonic( Form ) then
begin
Result := TRUE;
Exit;
end;
end;
end;
end
else
if Msg.message = WM_KEYUP then
begin
Rslt := 0;
Form := Sender.ParentForm;
if Form <> nil then
begin
if Msg.wParam = VK_MENU then
begin
if Form.FPressedMnemonic <> 0 then
Form.FPressedMnemonic := Form.FPressedMnemonic or $80000000;
end
else
if Char( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then
begin
if HandleMnemonic( Form ) then
begin
Result := TRUE;
Exit;
end;
end;
end;
end;
Result := FALSE;
end;
{$endif win32}
//[function TControl.SupportMnemonics]
function TControl.SupportMnemonics: PControl;
begin
{$ifdef win32}
fGlobalProcKeybd := WndProcMnemonics;
{$endif win32}
Result := @Self;
end;
//*
//[procedure TControl.SelectAll]
procedure TControl.SelectAll;
begin
SelStart := 0;
SelLength := -1; // this can be not working for some controls... //*//*
end;
{$IFNDEF NOT_USE_RICHEDIT}
//*
//[API RevokeDragDrop]
function RevokeDragDrop(wnd: HWnd): HResult; {$ifdef wince}cdecl{$else}stdcall{$endif};
external 'ole32.dll' name 'RevokeDragDrop';
//*
//[function TControl.RE_NoOLEDragDrop]
function TControl.RE_NoOLEDragDrop: PControl;
begin
RevokeDragDrop( Handle );
Result := @Self;
end;
{$ENDIF NOT_USE_RICHEDIT}
//*
//[function WndProcOnResize]
function WndProcOnResize( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
if Msg.message = WM_SIZE then
begin
if Assigned( Self_.fOnResize ) then
Self_.fOnResize( Self_ );
end;
Result := False;
end;
//*
//[procedure TControl.SetOnResize]
procedure TControl.SetOnResize(const Value: TOnEvent);
begin
FOnResize := Value;
AttachProc( WndProcOnResize );
end;
//[function WndProcMove]
function WndProcMove( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
if Msg.message = WM_MOVE then
begin
if Assigned( Self_.FOnMove ) then
Self_.FOnMove( Self_ );
end;
Result := False;
end;
//[procedure TControl.SetOnMove]
procedure TControl.SetOnMove(const Value: TOnEvent);
begin
FOnMove := Value;
AttachProc( WndProcMove );
end;
//[function WndProcMove]
function WndProcMoving( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := False;
if Msg.message = WM_MOVING then
begin
if Assigned( Self_.FOnMoving ) then
Self_.FOnMoving( Self_, Pointer( Msg.lParam ) );
Rslt := 1;
Result := TRUE;
end;
end;
procedure TControl.SetOnMoving(const Value: TOnEventMoving);
begin
FOnMoving := Value;
AttachProc( WndProcMoving );
end;
{$IFNDEF NOT_USE_RICHEDIT}
//[function WndProc_REBottomless]
function WndProc_REBottomless( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
if Msg.message = WM_SIZE then
Self_.Perform( EM_REQUESTRESIZE, 0, 0 );
Result := False;
end;
//*
//[function TControl.RE_Bottomless]
function TControl.RE_Bottomless: PControl;
begin
AttachProc( WndProc_REBottomless );
Result := @Self;
end;
//*
//[procedure TControl.RE_Append]
procedure TControl.RE_Append(const S: KOLString; ACanUndo: Boolean);
begin
SelStart := TextSize;
if S <> '' then
begin
ReplaceSelection( S, ACanUndo );
SelStart := TextSize;
end;
end;
//*
//[procedure TControl.RE_InsertRTF]
procedure TControl.RE_InsertRTF(const S: KOLString);
var MS: PStream;
begin
MS := NewMemoryStream;
MS.Size := (Length( S ) + 1) * Sizeof(KOLChar);
Move( S[ 1 ], MS.Memory^, ( Length( S ) + 1 ) * Sizeof( KOLChar ) );
RE_LoadFromStream( MS, Length( S ), reRTF, TRUE );
MS.Free;
end;
{$ENDIF NOT_USE_RICHEDIT}
//*
//[procedure TControl.DoSelChange]
procedure TControl.DoSelChange;
begin
if Assigned( fOnSelChange ) then fOnSelChange( @Self )
else
if Assigned( fOnChange ) then fOnChange( @Self );
end;
//*
//[function TControl.GetTextSize]
function TControl.GetTextSize: Integer;
begin
Result := 0;
if fHandle <> 0 then
Result := GetWindowTextLength( fHandle );
end;
{$IFNDEF NOT_USE_RICHEDIT}
//*
//[function TControl.REGetUnderlineEx]
function TControl.REGetUnderlineEx: TRichUnderline;
begin
Result := TRichUnderline( REGetFontAttr( ((81
{$IFDEF UNICODE_CTRLS} + 32 {$ENDIF})
shl 16) or CFM_UNDERLINETYPE ) - 1 );
end;
//*
//[procedure TControl.RESetUnderlineEx]
procedure TControl.RESetUnderlineEx(const Value: TRichUnderline);
begin
RESetFontAttr( ((81
{$IFDEF UNICODE_CTRLS} + 32 {$ENDIF})
shl 16) or CFM_UNDERLINETYPE, Ord( Value ) + 1 );
RESetFontEffect( CFM_UNDERLINE, True );
end;
//*
//[function TControl.REGetTextSize]
function TControl.REGetTextSize(Units: TRichTextSize): Integer;
const TextLengthFlags: array[ TRichTextSizes ] of Integer =
( not GTL_UseCRLF, not GTL_Precise, GTL_Close, GTL_NUMBytes );
var GTL: TGetTextLengthEx;
begin
GTL.flags := MakeFlags( @Units, TextLengthFlags );
if not(rtsBytes in Units) then
GTL.flags := GTL.flags or GTL_NUMCHARS;
GTL.codepage := CP_ACP;
Result := Perform( EM_GETTEXTLENGTHEX, Integer( @GTL ), 0 );
end;
//[function TControl.RE_TextSizePrecise]
function TControl.RE_TextSizePrecise: Integer;
var gtlex : TGetTextLengthEx;
begin
gtlex.flags := GTL_PRECISE;
gtlex.codepage := CP_ACP;
Result := Perform(EM_GETTEXTLENGTHEX,WPARAM(@gtlex), 0 );
end;
//*
//[function TControl.REGetNumStyle]
function TControl.REGetNumStyle: TRichNumbering;
begin
Result := TRichNumbering( ReGetParaAttr( 9 shl 16 ) );
end;
//*
//[procedure TControl.RESetNumStyle]
procedure TControl.RESetNumStyle(const Value: TRichNumbering);
begin
RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Ord( Value ) );
end;
//*
//[function TControl.REGetNumBrackets]
function TControl.REGetNumBrackets: TRichNumBrackets;
begin
REGetParaAttr( 0 );
Result := TRichNumBrackets( (fREParaFmtRec.wNumberingStyle shr 8) {and 3} );
end;
//*
//[procedure TControl.RESetNumBrackets]
procedure TControl.RESetNumBrackets(const Value: TRichNumBrackets);
begin
REGetParaAttr( 0 );
fREParaFmtRec.wNumberingStyle := fREParaFmtRec.wNumberingStyle and $F8FF
or Word( Ord( Value ) shl 8 );
fREParaFmtRec.dwMask := PFM_NUMBERINGSTYLE;
RE_ParaFmt := fREParaFmtRec;
end;
//*
//[function TControl.REGetNumTab]
function TControl.REGetNumTab: Integer;
begin
REGetParaAttr( 0 );
Result := fREParaFmtRec.wNumberingTab;
end;
//*
//[procedure TControl.RESetNumTab]
procedure TControl.RESetNumTab(const Value: Integer);
begin
REGetParaAttr( 0 );
fREParaFmtRec.wNumberingTab := Value;
fREParaFmtRec.dwMask := PFM_NUMBERINGTAB;
RE_ParaFmt := fREParaFmtRec;
end;
//*
//[function TControl.REGetNumStart]
function TControl.REGetNumStart: Integer;
begin
REGetParaAttr( 0 );
Result := fREParaFmtRec.wNumberingStart;
end;
//*
//[procedure TControl.RESetNumStart]
procedure TControl.RESetNumStart(const Value: Integer);
begin
REGetParaAttr( 0 );
fREParaFmtRec.wNumberingStart := Value;
fREParaFmtRec.dwMask := PFM_NUMBERINGSTART;
RE_ParaFmt := fREParaFmtRec;
end;
//*
//[function TControl.REGetSpacing]
function TControl.REGetSpacing( const Index: Integer ): Integer;
begin
REGetParaAttr( 0 );
Result := PInteger( cardinal(@fREParaFmtRec.dySpaceBefore) + cardinal(Index and $F) )^;
end;
//*
//[procedure TControl.RESetSpacing]
procedure TControl.RESetSpacing(const Index, Value: Integer);
begin
REGetParaAttr( 0 );
PInteger( cardinal(@fREParaFmtRec.dySpaceBefore) + cardinal(Index and $F) )^ := Value;
fREParaFmtRec.dwMask := Index and not $F;
RE_ParaFmt := fREParaFmtRec;
end;
//*
//[function TControl.REGetSpacingRule]
function TControl.REGetSpacingRule: Integer;
begin
REGetParaAttr( 0 );
Result := fREParaFmtRec.bLineSpacingRule;
end;
//*
//[procedure TControl.RESetSpacingRule]
procedure TControl.RESetSpacingRule(const Value: Integer);
begin
REGetParaAttr( 0 );
fREParaFmtRec.bLineSpacingRule := Value;
fREParaFmtRec.dwMask := PFM_LINESPACING;
RE_ParaFmt := fREParaFmtRec;
end;
//*
//[function TControl.REGetLevel]
function TControl.REGetLevel: Integer;
begin
REGetParaAttr( 0 );
Result := fREParaFmtRec.bCRC;
end;
//*
//[function TControl.REGetBorder]
function TControl.REGetBorder(Side: TBorderEdge; const Index: Integer): Integer;
begin
REGetParaAttr( 0 );
Result := PWORD( cardinal(@fREParaFmtRec.wBorderSpace) + cardinal(Index) )^ shr (Ord(Side) * 4);
end;
//*
//[procedure TControl.RESetBorder]
procedure TControl.RESetBorder(Side: TBorderEdge; const Index: Integer;
const Value: Integer);
var Mask: Word;
pW : PWord;
begin
REGetParaAttr( 0 );
pw := PWORD( cardinal(@fREParaFmtRec.wBorderSpace) + cardinal(Index) );
Mask := $F shl (Ord(Side) * 4);
pw^ := pw^ and not Mask or (Value shl (4 * Ord(Side)) );
fREParaFmtRec.dwMask := PFM_BORDER;
RE_ParaFmt := fREParaFmtRec;
end;
//*
//[function TControl.REGetParaEffect]
function TControl.REGetParaEffect(const Index: Integer): Boolean;
begin
Result := LongBool( HiWord( REGetParaAttr( 8 shl 16 ) ) and Index );
end;
//*
//[procedure TControl.RESetParaEffect]
procedure TControl.RESetParaEffect(const Index: Integer;
const Value: Boolean);
var Idx: Integer;
begin
REGetParaAttr( 0 );
fREParaFmtRec.wReserved := Index;
Idx := Index;
//if Idx >= $4000 then Idx := $4000;
fREParaFmtRec.dwMask := Idx shl 16;
RE_ParaFmt := fREParaFmtRec;
end;
//*
//[function WndProc_REMonitorIns]
function WndProc_REMonitorIns( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := False;
if (Msg.message = WM_KEYDOWN) and (Msg.wParam = VK_INSERT) and
((GetKeyState(VK_CONTROL) or GetKeyState(VK_SHIFT) or GetKeyState(VK_MENU)) >= 0) then
begin
if not Self_.fReOvrDisable then
Self_.fREOvr := not Self_.fREOvr
else
Result := True;
if assigned( Self_.fOnREInsModeChg ) then
Self_.fOnREInsModeChg( Self_ );
end;
end;
//*
//[function TControl.REGetOverwite]
function TControl.REGetOverwite: Boolean;
begin
AttachProc( WndProc_REMonitorIns );
Result := fREOvr;
end;
//*
//[procedure TControl.RESetOverwrite]
procedure TControl.RESetOverwrite(const Value: Boolean);
begin
if REGetOverwite = Value then // do not replace with fREOvr here!
Exit; // calling REGetOverwite installs monitor WndProc_REMonitorIns.
Perform( WM_KEYDOWN, VK_INSERT, 0 );
Perform( WM_KEYUP, VK_INSERT, 0 );
end;
//*
//[procedure TControl.RESetOvrDisable]
procedure TControl.RESetOvrDisable(const Value: Boolean);
begin
REGetOverwite;
fReOvrDisable := Value;
end;
//*
//[function WndProc_RichEdTransp_ParentPaint]
function WndProc_RichEdTransp_ParentPaint( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
C: PControl;
begin
if (Msg.message = WM_PAINT) and (Msg.wParam = 0) then
begin
for I := 0 to Self_.fChildren.fCount - 1 do
begin
C := Self_.fChildren.fItems[ I ];
if C.fIsCommonControl then
begin
Inc( C.fUpdCount );
PostMessage( C.fHandle, CM_NCUPDATE, C.fUpdCount, WM_PAINT );
InvalidateRect( C.fHandle, nil, False );
end;
end;
end;
Result := False;
end;
//*
//[function WndProc_RichEdTransp_Update]
function WndProc_RichEdTransp_Update( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Rgn, Rgn1: HRgn;
R, CR: TRect;
Pt: TPoint;
VW, HH, VH, HW: Integer;
begin
if Self_.fRETransparent then
case Msg.message of
WM_CHAR, WM_KILLFOCUS, WM_SETFOCUS, WM_KEYDOWN:
begin
PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 );
end;
WM_PAINT:
if Msg.wParam = 0 then
begin
Inc( Self_.fUpdCount );
PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
end;
WM_SIZE:
begin
Inc( Self_.fUpdCount );
PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 );
end;
WM_ERASEBKGND:
if Msg.wParam = 0 then
begin
Inc( Self_.fUpdCount );
PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
end;
WM_HSCROLL, WM_VSCROLL:
begin
Self_.fREScrolling := LoWord( Msg.wParam ) <> SB_ENDSCROLL;
Inc( Self_.fUpdCount );
PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
if Self_.fREScrolling then
Self_.Invalidate;
end;
CM_INVALIDATE:
begin
//Self_.Update;
Self_.Parent.Invalidate;
Self_.Invalidate;
//Inc( Self_.fUpdCount );
//PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
end;
CM_NCUPDATE:
if Msg.wParam = Self_.fUpdCount then
begin
//if Msg.lParam = WM_PAINT then
// UpdateWindow( Self_.fHandle );
GetWindowRect( Self_.fHandle, R );
Windows.GetClientRect( Self_.fHandle, CR );
Pt.x := 0; Pt.y := 0;
Pt := Self_.Client2Screen( Pt );
OffsetRect( CR, Pt.x, Pt.y );
Rgn := CreateRectRgn( R.Left, R.Top, R.Right, R.Bottom );
if Self_.fREScrolling then
begin
VW := GetSystemMetrics( SM_CXVSCROLL );
HH := GetSystemMetrics( SM_CYHSCROLL );
VH := GetSystemMetrics( SM_CYVSCROLL );
HW := GetSystemMetrics( SM_CXHSCROLL );
if CR.Right + VW <= R.Right then
begin
Rgn1 := CreateRectRgn( CR.Right, CR.Top + VH, CR.Right + VW, CR.Bottom - VH );
CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF );
DeleteObject( Rgn1 );
end;
if CR.Bottom + HH <= R.Bottom then
begin
Rgn1 := CreateRectRgn( CR.Left + HW, CR.Bottom, CR.Right - HW, CR.Bottom + HH );
CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF );
DeleteObject( Rgn1 );
end;
end;
Self_.Perform( WM_NCPAINT, Rgn, 0 );
DeleteObject( Rgn ); // Unremarked By M.Gerasimov
end;
end;
Result := False;
end;
//*
//[function TControl.REGetTransparent]
function TControl.REGetTransparent: Boolean;
begin
Result := Longbool(ExStyle and WS_EX_TRANSPARENT);
end;
//*
//[procedure TControl.RESetTransparent]
procedure TControl.RESetTransparent(const Value: Boolean);
begin
if Value then
ExStyle := ExStyle or WS_EX_TRANSPARENT
else
ExStyle := ExStyle and not WS_EX_TRANSPARENT;
fRETransparent := Value;
fParent.AttachProc( WndProc_RichEdTransp_ParentPaint );
AttachProc( WndProc_RichEdTransp_Update );
fTransparent := Value;
end;
//*
//[procedure TControl.RESetOnURL]
procedure TControl.RESetOnURL(const Index: Integer; const Value: TOnEvent);
begin
if Index = 0 then
fOnREOverURL := Value
else
fOnREURLClick := Value;
RE_AutoURLDetect := assigned(fOnREOverURL) or assigned(fOnREURLClick);
end;
//[procedure TControl.SetOnRE_URLClick]
procedure TControl.SetOnRE_URLClick(const Value: TOnEvent);
begin
RESetOnURL( 1, Value );
end;
procedure TControl.SetOnRE_OverURL(const Value: TOnEvent);
begin
RESetOnURL( 0, Value );
end;
{$IFDEF F_P}
//[function TControl.REGetOnURL]
function TControl.REGetOnURL(const Index: Integer): TOnEvent;
begin
CASE Index OF
0: Result := fOnREOverURL;
else Result := fOnREURLClick;
END;
end;
{$ENDIF F_P}
//*
//[function TControl.REGetLangOptions]
function TControl.REGetLangOptions(const Index: Integer): Boolean;
begin
Result := LongBool( Perform( EM_GETLANGOPTIONS, 0, 0 ) and Index);
end;
//*
//[procedure TControl.RESetLangOptions]
procedure TControl.RESetLangOptions(const Index: Integer;
const Value: Boolean);
var Mask: Integer;
begin
Mask := -1;
if not Value then Inc( Mask );
Perform( EM_SETLANGOPTIONS, 0, Perform( EM_GETLANGOPTIONS, 0, 0 ) and
not Index or (Mask and Index) );
end;
{$ENDIF NOT_USE_RICHEDIT}
{$ifdef win32}
//[function DoTrackMouseEvent]
function DoTrackMouseEvent(lpEventTrack: PTrackMouseEvent): BOOL;
var FunTrack: function(lpEventTrack: PTrackMouseEvent): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
ComCtlModule: THandle;
begin
Result := FALSE;
ComCtlModule := GetModuleHandle( cctrl );
if ComCtlModule = 0 then Exit;
FunTrack := GetProcAddress( ComCtlModule, '_TrackMouseEvent' );
if not Assigned( FunTrack ) then Exit;
Result := FunTrack( lpEventTrack );
end;
//*
//[function WndProcMouseEnterLeave]
function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var P: TPoint;
MouseWasInControl: Boolean;
Yes: Boolean;
Track: TTrackMouseEvent;
begin
case Msg.message of
WM_MOUSEFIRST..WM_MOUSELAST:
begin
MouseWasInControl := Self_.MouseInControl;
if Assigned( Self_.fOnTestMouseOver ) then
Yes := Self_.fOnTestMouseOver( Self_ )
else
begin
GetCursorPos( P );
P := Self_.Screen2Client( P );
Yes := PointInRect( P, Self_.ClientRect );
end;
if MouseWasInControl <> Yes then
begin
//???
Self_.Invalidate;
if Yes then
begin
Self_.fMouseInControl := TRUE;
if Assigned( Self_.fOnMouseEnter ) then
Self_.fOnMouseEnter( Self_ );
Track.cbSize := Sizeof( Track );
Track.dwFlags := TME_LEAVE;
Track.hwndTrack := Self_.Handle;
//Track.dwHoverTime := 0;
DoTrackMouseEvent( @ Track );
//???
Self_.Invalidate;
end
else
begin
Self_.fMouseInControl := FALSE;
Track.cbSize := Sizeof( Track );
Track.dwFlags := TME_LEAVE or TME_CANCEL;
Track.hwndTrack := Self_.Handle;
//Track.dwHoverTime := 0;
DoTrackMouseEvent( @ Track );
if Assigned( Self_.fOnMouseLeave ) then
Self_.fOnMouseLeave( Self_ );
//???
Self_.Invalidate; //Erase( FALSE );
end;
end;
end;
WM_MOUSELEAVE:
begin
if Self_.fMouseInControl then
begin
Self_.fMouseInControl := FALSE;
{$IFDEF GRAPHCTL_HOTTRACK}
if Assigned( Self_.fMouseLeaveProc ) then
Self_.fMouseLeaveProc( Self_ );
{$ENDIF}
if Assigned( Self_.fOnMouseLeave ) then
Self_.fOnMouseLeave( Self_ );
//???
Self_.Invalidate; //Erase( FALSE );
end;
end;
end;
Result := False;
end;
{$endif win32}
//[procedure ProvideMouseEnterLeave]
procedure ProvideMouseEnterLeave( Self_: PControl );
begin
{$ifdef win32}
InitCommonControls;
Self_.AttachProc( WndProcMouseEnterLeave );
//???Self_.InvalidateErase( FALSE );
{$endif win32}
end;
//[procedure TControl.SetFlat]
procedure TControl.SetFlat(const Value: Boolean);
begin
//if fFlat = Value then Exit;
fFlat := Value;
fMouseInControl := FALSE;
ProvideMouseEnterLeave( @Self );
Invalidate;
end;
//[procedure TControl.SetOnMouseEnter]
procedure TControl.SetOnMouseEnter(const Value: TOnEvent);
begin
fOnMouseEnter := Value;
ProvideMouseEnterLeave( @Self );
end;
//[procedure TControl.SetOnMouseLeave]
procedure TControl.SetOnMouseLeave(const Value: TOnEvent);
begin
fOnMouseLeave := Value;
ProvideMouseEnterLeave( @Self );
end;
//[procedure TControl.SetOnTestMouseOver]
procedure TControl.SetOnTestMouseOver(const Value: TOnTestMouseOver);
begin
fOnTestMouseOver := Value;
ProvideMouseEnterLeave( @Self );
end;
//[function WndProcEdTransparent]
function WndProcEdTransparent( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
if (Msg.message = WM_KEYDOWN) or
(Msg.message = WM_MOUSEMOVE) and (GetKeyState( VK_LBUTTON ) < 0) or
(Msg.message = WM_LBUTTONUP) or (Msg.message = WM_LBUTTONDOWN) then
Self_.Invalidate;
Result := False; // continue handling of a message anyway
end;
//[procedure TControl.EdSetTransparent]
procedure TControl.EdSetTransparent(const Value: Boolean);
begin
Transparent := Value;
AttachProc( WndProcEdTransparent );
end;
//[function WndProcSpeedButton]
var LastHWnd: HWnd; // + Don
function WndProcSpeedButton( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := False;
if Msg.message = WM_SETFOCUS then
begin
Result := TRUE;
Rslt := 0;
LastHWnd := Msg.wParam; // + don
end
else // + Don
if (Msg.message = WM_CAPTURECHANGED) and
(Msg.lParam = 0) and
(LastHwnd <> 0) then
begin
SetFocus(LastHwnd);
LastHwnd := 0;
end;
end;
//[function TControl.LikeSpeedButton]
function TControl.LikeSpeedButton: PControl;
//type TProcObj = procedure of object;
var Form: PControl;
begin
AttachProc( WndProcSpeedButton );
//fSetFocus := TProcObj( MakeMethod( nil, @ DummyObjProc ) );
fTabstop := False;
Style := Style and not WS_TABSTOP;
Form := ParentForm;
if Form <> nil then
if Form.fCurrentControl = @Self then
begin
Form.GotoControl( VK_TAB );
if Form.fCurrentControl = @Self then
Form.fCurrentControl := nil;
end;
Result := @Self;
end;
{ -- Unicode -- }
//[function TControl.SetUnicode]
function TControl.SetUnicode(Unicode: Boolean): PControl;
begin
{$ifdef win32}
Perform( CCM_SETUNICODEFORMAT, Integer( Unicode ), 0 );
{$endif win32}
Result := @ Self;
end;
{ -- TabControl -- }
//[function TControl.GetPages]
function TControl.GetPages(Idx: Integer): PControl;
var Item: TTCItem;
begin
Item.mask := TCIF_PARAM;
if Perform( TCM_GETITEM, Idx, Integer( @Item ) ) = 0 then
Result := nil
else
Result := Pointer( Item.lParam );
end;
//[function TControl.TCGetItemText]
function TControl.TCGetItemText(Idx: Integer): KOLString;
var TI: TTCItem;
Buffer: array[ 0..1023 ] of KOLChar;
begin
TI.mask := TCIF_TEXT;
TI.pszText := @Buffer[ 0 ];
TI.cchTextMax := sizeof( Buffer );
Buffer[ 0 ] := #0;
Perform( TCM_GETITEM, Idx, Integer( @TI ) );
Result := PKOLChar( @ Buffer[ 0 ] );
end;
//[procedure TControl.TCSetItemText]
procedure TControl.TCSetItemText(Idx: Integer; const Value: KOLString);
var TI: TTCItem;
begin
TI.mask := TCIF_TEXT;
TI.pszText := PKOLChar( Value );
Perform( TCM_SETITEM, Idx, Integer( @TI ) );
end;
//[function TControl.TCGetItemImgIDx]
function TControl.TCGetItemImgIDx(Idx: Integer): Integer;
var TI: TTCItem;
begin
TI.mask := TCIF_IMAGE;
if Perform( TCM_GETITEM, Idx, Integer( @TI ) ) = 0 then
Result := -1
else
Result := TI.iImage;
end;
//[procedure TControl.TCSetItemImgIdx]
procedure TControl.TCSetItemImgIdx(Idx: Integer; const Value: Integer);
var TI: TTCItem;
begin
TI.mask := TCIF_IMAGE;
TI.iImage := Value;
Perform( TCM_SETITEM, Idx, Integer( @TI ) );
end;
//[function TControl.TCGetItemRect]
function TControl.TCGetItemRect(Idx: Integer): TRect;
begin
if Perform( TCM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then
begin
Result.Left := 0;
Result.Right := 0;
Result.Top := 0;
Result.Bottom := 0;
end;
end;
//[procedure TControl.TC_SetPadding]
procedure TControl.TC_SetPadding(cx, cy: Integer);
begin
Perform( TCM_SETPADDING, 0, cx or (cy shl 16) );
end;
//[function TControl.TC_TabAtPos]
function TControl.TC_TabAtPos(x, y: Integer): Integer;
type TTCHittestInfo = {$ifndef wince}packed{$endif} record
Pt: TPoint;
Fl: DWORD;
end;
var HTI: TTCHitTestInfo;
begin
HTI.Pt.x := x;
HTI.Pt.y := y;
Result := Perform( TCM_HITTEST, 0, Integer( @HTI ) );
end;
//[function TControl.TC_DisplayRect]
function TControl.TC_DisplayRect: TRect;
begin
Windows.GetClientRect( fHandle, Result );
Perform( TCM_ADJUSTRECT, 0, Integer( @Result ) );
{$ifdef wince}
Dec(Result.Top, 2);
Dec(Result.Left, 2);
Inc(Result.Right, 2);
{$endif wince}
end;
//[function TControl.TC_IndexOf]
function TControl.TC_IndexOf(const S: KOLString): Integer;
begin
Result := TC_SearchFor( S, -1, FALSE );
end;
//[function TControl.TC_SearchFor]
function TControl.TC_SearchFor(const S: KOLString; StartAfter: Integer;
Partial: Boolean): Integer;
var I: Integer;
begin
Result := -1;
for I := StartAfter+1 to Count-1 do
begin
if Partial and ( Copy( TC_Items[ I ], 1, Length( S ) ) = S ) or
( TC_Items[ I ] = S ) then
begin
Result := I;
break;
end;
end;
end;
//[function TControl.TC_Insert]
function TControl.TC_Insert(Idx: Integer; const TabText: KOLString;
TabImgIdx: Integer): PControl;
var TI: TTCItem;
begin
Result := NewPanel( @Self, esNone );
{$IFDEF OLD_ALIGN}
Result.FAlign := caClient; //+ Galkov
Result.fNotUseAlign := True;
Result.fVisibleWoParent := TRUE;
{$ELSE NEW_ALIGN}
Result.Align := caClient; //+ Galkov
{$ENDIF}
Result.Visible := CurIndex<0;
TI.mask := TCIF_TEXT or TCIF_IMAGE or TCIF_PARAM;
TI.iImage := TabImgIdx;
TI.pszText := PKOLChar( TabText );
TI.lParam := Integer( Result );
Perform( TCM_INSERTITEM, Idx, Integer( @TI ) );
{$IFDEF OLD_ALIGN}
Result.BoundsRect := TC_DisplayRect;//+ Galkov
{$ENDIF}
Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
{$IFDEF GRAPHCTL_XPSTYLES}
Result.fClassicTransparent := Result.fTransparent;
Attach_WM_THEMECHANGED(Result);
XP_Themes_For_TabPanel(Result);
{$ENDIF}
end;
//[procedure TControl.TC_Delete]
procedure TControl.TC_Delete(Idx: Integer);
var Page: PControl;
begin
Page := TC_Pages[ Idx ];
if Page = nil then Exit;
Perform( TCM_DELETEITEM, Idx, 0 );
Page.Free;
Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
end;
{$IFNDEF OLD_ALIGN}
//[procedure TControl.TC_InsertControl
procedure TControl.TC_InsertControl( Idx: Integer; const TabText: KOLString;
TabImgIdx: Integer; Page: PControl);
var TI: TTCItem;
begin
Page.Visible := CurIndex<0;
TI.mask := TCIF_TEXT or TCIF_IMAGE or TCIF_PARAM;
TI.iImage := TabImgIdx;
TI.pszText := PKOLChar( TabText );
TI.lParam := Integer( Page );
Perform( TCM_INSERTITEM, Idx, Integer( @TI ) );
Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
end;
//[function TControl.TC_Remove]
function TControl.TC_Remove( Idx: Integer ):PControl;
begin
Result := TC_Pages[ Idx ];
if Result = nil then Exit;
Perform( TCM_DELETEITEM, Idx, 0 );
Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
end;
{$ENDIF}
{ -- TreeView -- }
//[function TControl.TVGetItemIdx]
function TControl.TVGetItemIdx(const Index: Integer): THandle;
begin
Result := Perform( TVM_GETNEXTITEM, Index, 0 );
end;
//[procedure TControl.TVSetItemIdx]
procedure TControl.TVSetItemIdx(const Index: Integer;
const Value: THandle);
begin
Perform( TVM_SELECTITEM, Index, Value );
end;
//[function TControl.TVGetItemNext]
function TControl.TVGetItemNext(Item: THandle; const Index: Integer): THandle;
begin
Result := Perform( TVM_GETNEXTITEM, Index, Item );
end;
//[function TControl.TVGetItemRect]
function TControl.TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect;
begin
Result.Left := Item;
if Perform( TVM_GETITEMRECT, Integer( TextOnly ), Integer( @Result ) ) = 0 then
begin
Result.Left := 0;
Result.Right := 0;
Result.Top := 0;
Result.Bottom := 0;
end;
end;
//[function TControl.TVGetItemVisible]
function TControl.TVGetItemVisible(Item: THandle): Boolean;
var R: TRect;
begin
R := TVItemRect[ Item, False ];
Result := R.Bottom > R.Top;
end;
//[procedure TControl.TVSetItemVisible]
procedure TControl.TVSetItemVisible(Item: THandle; const Value: Boolean);
begin
if Value then
Perform( TVM_ENSUREVISIBLE, 0, Item );
end;
//[function TControl.TVGetItemStateFlg]
function TControl.TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean;
var TVI: TTVItem;
begin
TVI.mask := TVIF_HANDLE or TVIF_STATE;
TVI.hItem := Item;
TVI.stateMask := Index;
Result := False;
if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then
Result := (TVI.state and Index) <> 0;
end;
//[procedure TControl.TVSetItemStateFlg]
procedure TControl.TVSetItemStateFlg(Item: THandle; const Index: Integer;
const Value: Boolean);
var TVI: TTVItem;
begin
TVI.mask := TVIF_HANDLE or TVIF_STATE;
TVI.hItem := Item;
TVI.stateMask := Index;
TVI.state := $FFFFFFFF and Index;
if not Value then
TVI.state := 0;
Perform( TVM_SETITEM, 0, Integer( @TVI ) );
end;
//[function TControl.TVGetItemImage]
function TControl.TVGetItemImage(Item: THandle; const Index: Integer): Integer;
var TVI: TTVItem;
begin
TVI.mask := TVIF_HANDLE or Loword( Index );
TVI.hItem := Item;
if Hiword( Index ) <> 0 then
begin
TVI.mask := TVIF_STATE or TVIF_HANDLE;
TVI.stateMask := Loword( Index );
end;
Result := -1;
if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then
begin
if Hiword( Index ) <> 0 then
Result := (TVI.state shr Hiword( Index )) and $F
else
if Loword( Index ) = TVIF_IMAGE then
Result := TVI.iImage
else
Result := TVI.iSelectedImage;
end;
end;
//[procedure TControl.TVSetItemImage]
procedure TControl.TVSetItemImage(Item: THandle; const Index: Integer;
const Value: Integer);
var TVI: TTVItem;
begin
TVI.mask := TVIF_HANDLE or Loword( Index );
TVI.hItem := Item;
TVI.iImage := Value;
TVI.iSelectedImage := Value;
if Hiword( Index ) <> 0 then
begin
TVI.mask := TVIF_STATE or TVIF_HANDLE;
TVI.stateMask := Loword( Index );
TVI.state := Value shl Hiword( Index );
end;
Perform( TVM_SETITEM, 0, Integer( @TVI ) );
end;
//[function TControl.TVGetItemText]
function TControl.TVGetItemText(Item: THandle): KOLString;
var TVI: TTVItem;
Buffer: array[ 0..4095 ] of KOLChar;
begin
TVI.mask := TVIF_HANDLE or TVIF_TEXT;
TVI.hItem := Item;
TVI.pszText := @Buffer[ 0 ];
Buffer[ 0 ] := #0;
TVI.cchTextMax := Sizeof( Buffer ) {$IFDEF UNICODE_CTRLS} div Sizeof( KOLChar ) {$ENDIF};
Perform( TVM_GETITEM, 0, Integer( @TVI ) );
Result := PKOLChar( @ Buffer[ 0 ] );
end;
//[procedure TControl.TVSetItemText]
procedure TControl.TVSetItemText(Item: THandle; const Value: KOLString);
var TVI: TTVItem;
begin
TVI.mask := TVIF_HANDLE or TVIF_TEXT;
TVI.hItem := Item;
TVI.pszText := PKOLChar( Value );
Perform( TVM_SETITEM, 0, Integer( @TVI ) );
end;
//[function TControl.TVItemPath]
function TControl.TVItemPath(Item: THandle; Delimiter: KOLChar): KOLString;
begin
if Item = 0 then
Item := TVSelected;
Result := '';
while Item <> 0 do
begin
if Result <> '' then
Result := Delimiter + Result;
Result := TVItemText[ Item ] + Result;
Item := TVItemParent[ Item ];
end;
end;
//[function TControl.TV_GetItemHasChildren]
function TControl.TV_GetItemHasChildren(Item: THandle): Boolean;
var TVI: TTVItem;
begin
TVI.mask := TVIF_HANDLE or TVIF_CHILDREN;
TVI.hItem := Item;
Perform( TVM_GETITEM, 0, Integer( @TVI ) );
Result := TVI.cChildren = 1;
end;
//[procedure TControl.TV_GetItemChildCount]
function TControl.TV_GetItemChildCount(Item: THandle): Integer;
var Node: THandle;
begin
Result := 0;
Node := TVItemChild[ Item ];
while Node <> 0 do
begin
Inc( Result );
Node := TVItemNext[ Node ];
end;
end;
//[procedure TControl.TV_SetItemHasChildren]
procedure TControl.TV_SetItemHasChildren(Item: THandle;
const Value: Boolean);
var TVI: TTVItem;
begin
TVI.mask := TVIF_HANDLE or TVIF_CHILDREN;
TVI.hItem := Item;
TVI.cChildren := 1 and Integer( Value );
Perform( TVM_SETITEM, 0, Integer( @TVI ) );
end;
//[function TControl.TVItemAtPos]
function TControl.TVItemAtPos(x, y: Integer; var Where: DWORD): THandle;
var HTI: TTVHitTestInfo;
begin
HTI.pt.x := x;
HTI.pt.y := y;
Result := Perform( TVM_HITTEST, 0, Integer( @HTI ) );
Where := HTI.{$ifdef wince}flags{$else}fl{$endif};
end;
type
TTVInsertStruct = {$ifndef wince}packed{$endif} Record
hParent: THandle;
hAfter : THandle;
item: TTVItem;
end;
{$ifdef win32}
TTVInsertStructEx = {$ifndef wince}packed{$endif} Record
hParent: THandle;
hAfter : THandle;
item: TTVItemEx;
end;
{$endif win32}
//[function TControl.TVInsert]
function TControl.TVInsert(nParent, nAfter: THandle;
const Txt: KOLString): THandle;
var TVIns: TTVInsertStruct;
begin
TVIns.hParent := nParent;
TVIns.hAfter := nAfter;
TVIns.item.mask := TVIF_TEXT;
TVIns.item.pszText := PKOLChar( Txt );
Result := Perform( TVM_INSERTITEM, 0, Integer( @TVIns ) );
Invalidate;
end;
//[procedure TControl.TVExpand]
procedure TControl.TVExpand(Item: THandle; Flags: DWORD);
begin
Perform( TVM_EXPAND, Flags, Item );
end;
//[procedure TControl.TVSort]
procedure TControl.TVSort( N: THandle );
var a: Cardinal;
b: Boolean;
begin
b := N = 0;
if b then
begin
N := TVRoot;
end;
while N <> 0 do
begin
a := TVItemChild[N];
if a > 0 then
TVSort(a);
Perform(TVM_SORTCHILDREN, 0, N);
N := TVItemNext[N];
end;
if b then //moved by Tr"]f
Perform(TVM_SORTCHILDREN, 0, 0); //+ by YS
end;
//[procedure TControl.TVDelete]
procedure TControl.TVDelete(Item: THandle);
begin
Perform( TVM_DELETEITEM, 0, Item );
Invalidate;
end;
//[function TControl.TVGetItemData]
function TControl.TVGetItemData(Item: THandle): Pointer;
var TVI: TTVItem;
begin
TVI.mask := TVIF_HANDLE or TVIF_PARAM;
TVI.hItem := Item;
Result := nil;
if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then
Result := Pointer( TVI.lParam );
end;
//[procedure TControl.TVSetItemData]
procedure TControl.TVSetItemData(Item: THandle; const Value: Pointer);
var TVI: TTVItem;
begin
TVI.mask := TVIF_HANDLE or TVIF_PARAM;
TVI.hItem := Item;
TVI.lParam := Integer( Value );
Perform( TVM_SETITEM, 0, Integer( @TVI ) );
end;
//[procedure TControl.TVEditItem]
procedure TControl.TVEditItem(Item: THandle);
begin
Perform( TVM_EDITLABEL, 0, Item );
end;
//[procedure TControl.TVStopEdit]
procedure TControl.TVStopEdit(Cancel: Boolean);
begin
Perform( TVM_ENDEDITLABELNOW, Integer( Cancel ), 0 );
end;
//[function WndProcTVRightClickSelect]
function WndProcTVRightClickSelect( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean;
var I: Integer;
Where: DWORD;
begin
if Msg.message = WM_RBUTTONDOWN then
begin
I := Sender.TVItemAtPos( SmallInt( Msg.lParam and $FFFF ),
SmallInt( Msg.lParam shr 16 ), Where );
if I <> 0 then
Sender.TVSelected := I;
end;
Result := FALSE;
end;
//[procedure TControl.SetTVRightClickSelect]
procedure TControl.SetTVRightClickSelect(const Value: Boolean);
begin
fTVRightClickSelect := Value;
if Value then
AttachProc( @WndProcTVRightClickSelect );
end;
//[procedure TControl.SetOnTVDelete]
procedure TControl.SetOnTVDelete( const Value: TOnTVDelete );
begin
fOnTVDelete := Value;
if fParent <> nil then
begin
fParent.Add2AutoFreeEx( Clear );
fParent.DetachProc( WndProcNotify );
fParent.AttachProcEx( WndProcNotify, TRUE );
end;
AttachProcEx( ProcTVDeleteItem, TRUE );
end;
//[function ClipboardHasText]
function ClipboardHasText: Boolean;
begin
Result := false;
if OpenClipboard( 0 ) then
begin
if IsClipboardFormatAvailable( CF_TEXT ) then
Result := TRUE;
CloseClipboard;
end;
end;
//[function Clipboard2Text]
{$ifdef wince}
function Clipboard2Text: String;
begin
Result:=Clipboard2WText;
end;
{$else}
function Clipboard2Text: String;
var gbl: THandle;
str: PChar;
begin
Result := '';
if OpenClipboard( 0 ) then
begin
if IsClipboardFormatAvailable( CF_TEXT ) then
begin
gbl := GetClipboardData( CF_TEXT );
if gbl <> 0 then
begin
str := GlobalLock( gbl );
if str <> nil then
begin
Result := str;
GlobalUnlock( gbl );
end;
end;
end;
CloseClipboard;
end;
end;
{$endif wince}
{-}
{$IFNDEF _D2}
//[function Clipboard2WText]
function Clipboard2WText: WideString;
var gbl: THandle;
str: PWideChar;
begin
Result := '';
if OpenClipboard( 0 ) then
begin
if IsClipboardFormatAvailable( CF_UNICODETEXT ) then
begin
gbl := GetClipboardData( CF_UNICODETEXT );
if gbl <> 0 then
begin
str := GlobalLock( gbl );
if str <> nil then
begin
Result := str;
GlobalUnlock( gbl );
end;
end;
end;
CloseClipboard;
end;
end;
{$ENDIF}
{+}
//[function Text2Clipboard]
{$ifdef wince}
function Text2Clipboard( const S: String ): Boolean;
begin
Result:=WText2Clipboard(S);
end;
{$else}
function Text2Clipboard( const S: String ): Boolean;
var gbl: THandle;
str: PChar;
begin
Result := False;
if not OpenClipboard( 0 ) then Exit;
EmptyClipboard;
if S <> '' then
begin
gbl := GlobalAlloc( GMEM_MOVEABLE, Length( S ) + 1 );
if gbl <> 0 then
begin
str := GlobalLock( gbl );
Move( S[ 1 ], str^, Length( S ) + 1 );
GlobalUnlock( gbl );
Result := SetClipboardData( CF_TEXT, gbl ) <> 0;
end;
end
else
Result := True;
CloseClipboard;
end;
{$endif wince}
{-}
{$IFNDEF _D2}
//[function WText2Clipboard]
function WText2Clipboard( const WS: WideString ): Boolean;
var gbl: THandle;
str: PChar;
begin
Result := False;
if not OpenClipboard( 0 ) then Exit;
EmptyClipboard;
if WS <> '' then
begin
gbl := GlobalAlloc( GMEM_MOVEABLE, (Length( WS ) + 1) * 2 );
if gbl <> 0 then
begin
str := GlobalLock( gbl );
Move( WS[ 1 ], str^, (Length( WS ) + 1) * 2 );
GlobalUnlock( gbl );
Result := SetClipboardData( CF_UNICODETEXT, gbl ) <> 0;
end;
end
else
Result := True;
CloseClipboard;
end;
{$ENDIF}
{+}
//[function TControl.Size]
function TControl.Size(W, H: Integer): PControl;
var C, P: PControl;
dW, dH: Integer;
begin
C := @Self;
while True do
begin
dW := 0; dH := 0;
P := C.FParent;
if C.ToBeVisible {or C.fCreateHidden or (P <> nil) and (P.fVisible)} then
begin
if C.fAlign in [caLeft, caRight, caClient] then
begin
if H > 0 then
begin
dH := H - C.Height; H := 0;
end;
end;
if C.fAlign in [caTop, caBottom, caClient] then
begin
if W > 0 then
begin
dW := W - C.Width; W := 0;
end;
end;
end;
if (W > 0) or (H > 0) then
begin
C.SetSize( W, H );
if (P <> nil) // {Ralf Junker}
and not P.IsApplet then
C.ResizeParent;
end;
if (dW = 0) and (dH = 0) then break;
C := P; //C.FParent;
if C = nil then break;
//if not C.fIsControl then break;
if C.IsApplet then break;
W := C.Width + dW;
H := C.Height + dH;
end;
Result := @Self;
end;
{$ENDIF WIN_GDI}
//[procedure AutoSzProc]
{$IFDEF GDI}
procedure AutoSzProc( Self_: PObj );
var DeltaX, DeltaY: Integer;
SZ: TSize; PT: TPoint;
Txt: KOLString;
Chg: Boolean;
R: TRect;
Flags: DWORD;
{+ecm}
OldFont: HFONT;
CtlHavingFont: PControl;
{/+ecm}
OldNotUseAlign: boolean;
begin
Txt := PControl( Self_ ).fCaption;
SZ.cx := 0;
SZ.cy := 0;
if Txt <> '' then
begin
if not PControl( Self_ ).HandleAllocated then begin
PControl( Self_ ).fAutoSize:=DummyObjProc;
PControl( Self_ ).GetWindowHandle; // this line must be here.
//-- otherwise, when handle is not yet allocated,
// it is requested in TCanvas.GetHandle, and in result
// of unpredictable recursion some memory can be currupted.
PControl( Self_ ).fAutoSize:=AutoSzProc;
end;
if Assigned( PControl( Self_ ).fFont ) then
if PControl( Self_ ).fFont.fData.Font.Italic then
Txt := Txt + ' ';
if PControl( Self_ ).fWordWrap and (PControl( Self_ ).fAlign <> caClient) then
begin
R := PControl( Self_ ).ClientRect;
Dec(R.Right, PControl( Self_ ).fCommandActions.aAutoSzX);
if R.Right < R.Left then
R.Right:=R.Left + 1;
Flags := DT_CALCRECT or DT_EXPANDTABS or DT_WORDBREAK;
CASE PControl( Self_ ).fTextAlign OF
taCenter: Flags := Flags or DT_CENTER;
taRight : Flags := Flags or DT_RIGHT;
END;
{-ecm}
// CASE Self_.fVerticalAlign OF
// vaCenter: Flags := Flags or DT_VCENTER;
// vaBottom: Flags := Flags or DT_BOTTOM;
// END;
{/-ecm}
{+ecm}
CtlHavingFont := PControl( Self_ );
while (CtlHavingFont <> nil) and not Assigned( CtlHavingFont.FFont ) do
CtlHavingFont := CtlHavingFont.Parent;
OldFont := 0;
if Assigned( CtlHavingFont ) then
OldFont := SelectObject( PControl( Self_ ).Canvas.Handle, CtlHavingFont.Font.Handle );
{/+ecm}
// DrawText return the height of the text !
SZ.cy := DrawText( PControl( Self_ ).Canvas.Handle, PKOLChar( Txt ), Length( Txt ), R, Flags );
{+ecm}
if Assigned( CtlHavingFont ) then
SelectObject(PControl( Self_ ).Canvas.fHandle,OldFont);
{/+ecm}
SZ.cx := R.Right - R.Left;
{$ifdef wince}
Inc(SZ.cx);
{$endif wince}
//SZ.cy := R.Bottom - R.Top;
end
else
PControl( Self_ ).Canvas.TextArea( Txt, SZ, PT );
end;
Chg := FALSE;
OldNotUseAlign:=PControl( Self_ ).fNotUseAlign;
PControl( Self_ ).fNotUseAlign:=True;
if PControl( Self_ ).FAlign in [ caNone, caLeft, caRight ] then
begin
DeltaX := PControl( Self_ ).fCommandActions.aAutoSzX;
if PControl( Self_ ).Width <> SZ.cx + DeltaX then
begin
PControl( Self_ ).Width := SZ.cx + DeltaX;
Chg := TRUE;
end;
if PControl( Self_ ).fMinWidth > PControl( Self_ ).Width then
begin
PControl( Self_ ).Width := PControl( Self_ ).fMinWidth;
Chg := TRUE;
end;
end;
if PControl( Self_ ).FAlign in [ caNone, caTop, caBottom ] then
begin
DeltaY := PControl( Self_ ).fCommandActions.aAutoSzY;
if PControl( Self_ ).Height <> SZ.cy + DeltaY then
begin
PControl( Self_ ).Height := SZ.cy + DeltaY;
Chg := TRUE;
end;
if PControl( Self_ ).FMinHeight > PControl( Self_ ).Height then
begin
PControl( Self_ ).Height := PControl( Self_ ).FMinHeight;
Chg := TRUE;
end;
end;
PControl( Self_ ).fNotUseAlign:=OldNotUseAlign;
if Chg then
begin
{$IFDEF OLD_ALIGN}
if PControl( Self_ ).fParent <> nil then
Global_Align( PControl( Self_ ).fParent );
{$ENDIF}
Global_Align( Self_ );
end;
end;
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
procedure AutoSzProc( Self_: PObj );
var SZ: TSize;
//Txt: KOLString;
Chg: Boolean;
req_captn, req_evbox: TGtkRequisition;
begin
//Txt := PControl( Self_ ).fCaption;
SZ.cx := 0;
SZ.cy := 0;
//if Txt <> '' then
begin
{if Assigned( PControl( Self_ ).fFont ) then
if PControl( Self_ ).fFont.fData.Font.Italic then
Txt := Txt + ' ';}
gtk_widget_size_request( PControl( Self_ ).fCaptionHandle, @ req_captn );
//gtk_widget_get_size_request( PControl( Self_ ).fCaptionHandle, @ Sz.cx, @ Sz.cy );
//gtk_widget_size_request( PControl( Self_ ).fEventboxHandle, @ requisition2 );
{if Sz.cx < 0 then Sz.cx := PControl( Self_ ).Width;
if Sz.cy < 0 then Sz.cy := PControl( Self_ ).Height;
Sz.cx := max( requisition2.width, requisition1.width + requisition2.width - Sz.cx );
Sz.cy := max( requisition2.height, requisition1.height + requisition2.height - Sz.cy );}
if (PControl( Self_ ).fDeltaX = 0) and
(PControl( Self_ ).fDeltaY = 0) then
begin
gtk_widget_size_request( PControl( Self_ ).fEventboxHandle, @ req_evbox );
PControl( Self_ ).fDeltaX := Max( 0, req_evbox.width - req_captn.width );
PControl( Self_ ).fDeltaY := Max( 0, req_evbox.height - req_captn.height );
end;
Sz.cx := req_captn.width + PControl( Self_ ).fDeltaX;
Sz.cy := req_captn.height + PControl( Self_ ).fDeltaY;
//gtk_widget_get_size_request( PControl( Self_ ).fHandle, @ Sz.cx, @ Sz.cy );
end;
Chg := FALSE;
if PControl( Self_ ).FAlign in [ caNone, caLeft, caRight ] then
begin
//DeltaX := PControl( Self_ ).fCommandActions.aAutoSzX;
if PControl( Self_ ).Width <> SZ.cx {+ DeltaX} then
begin
PControl( Self_ ).Width := SZ.cx {+ DeltaX};
Chg := TRUE;
end;
if PControl( Self_ ).fMinWidth > PControl( Self_ ).Width then
begin
PControl( Self_ ).Width := PControl( Self_ ).fMinWidth;
Chg := TRUE;
end;
end;
if PControl( Self_ ).FAlign in [ caNone, caTop, caBottom ] then
begin
//DeltaY := PControl( Self_ ).fCommandActions.aAutoSzY;
if PControl( Self_ ).Height <> SZ.cy {+ DeltaY} then
begin
PControl( Self_ ).Height := SZ.cy {+ DeltaY};
Chg := TRUE;
end;
if PControl( Self_ ).FMinHeight > PControl( Self_ ).Height then
begin
PControl( Self_ ).Height := PControl( Self_ ).FMinHeight;
Chg := TRUE;
end;
end;
if Chg then
begin
{$IFDEF OLD_ALIGN}
if PControl( Self_ ).fParent <> nil then
Global_Align( PControl( Self_ ).fParent );
{$ENDIF}
Global_Align( Self_ );
end;
end;
{$ENDIF GTK}
{$ENDIF _X_}
//[function TControl.AutoSize]
function TControl.AutoSize(AutoSzOn: Boolean): PControl;
begin
if AutoSzOn then
begin
fAutoSize := AutoSzProc;
DoAutoSize;
end
else
fAutoSize := DummyObjProc;
Result := @Self;
end;
{$IFDEF WIN_GDI}
//[function TControl.IsAutoSize]
function TControl.IsAutoSize: Boolean;
begin
Result := Assigned( fAutoSize );
end;
//*
//[function TControl.GetToBeVisible]
function TControl.GetToBeVisible: Boolean;
begin
Result := fVisible or fCreateHidden or fVisibleWoParent;
if fIsControl then
if Parent <> nil then
begin
if fVisibleWoParent then
Result := fVisible
else
begin
Parent.Visible; // needed to provide correct fVisible for a form!
Result := Result and Parent.ToBeVisible;
end;
end;
end;
///////////////////////////////////////////////////////////////////////
// W I N D O W S
///////////////////////////////////////////////////////////////////////
{ -- Set of window-related utility functions. -- }
type
PGUIThreadInfo = ^TGUIThreadInfo;
tagGUITHREADINFO = {$ifndef wince}packed{$endif} record
cbSize: DWORD;
flags: DWORD;
hwndActive: HWND;
hwndFocus: HWND;
hwndCapture: HWND;
hwndMenuOwner: HWND;
hwndMoveSize: HWND;
hwndCaret: HWND;
rcCaret: TRect;
end;
TGUIThreadInfo = tagGUITHREADINFO;
const
GUI_CARETBLINKING = $00000001;
GUI_INMOVESIZE = $00000002;
GUI_INMENUMODE = $00000004;
GUI_SYSTEMMENUMODE = $00000008;
GUI_POPUPMENUMODE = $00000010;
type TGUIThreadInfo_Proc = function( ThreadID: THandle; var GTI: TGUIThreadInfo )
: Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
var Proc_GetGUIThreadInfo: TGuiThreadInfo_Proc;
//[function GetWindowChild]
function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd;
var GTI: TGuiThreadInfo;
ThreadID: THandle;
Module: THandle;
begin
if not Assigned( Proc_GetGUIThreadInfo ) then
begin
Module := GetModuleHandle( 'User32' );
Proc_GetGUIThreadInfo := GetProcAddress( Module, 'GetGUIThreadInfoA' );
if not Assigned( Proc_GetGUIThreadInfo ) then
Proc_GetGUIThreadInfo := Pointer( -1 );
end;
Result := Wnd;
if @Proc_GetGUIThreadInfo = Pointer( -1 ) then
Exit;
Result := 0;
if Wnd = 0 then
ThreadID := GetCurrentThreadID
else
ThreadID := GetWindowThreadProcessID( Wnd, nil );
if ThreadID = 0 then Exit;
GTI.cbSize := Sizeof( GTI );
if Proc_GetGUIThreadInfo( ThreadId, GTI ) then
begin
case Kind of
wcActive: Result := GTI.hwndActive;
wcFocus: Result := GTI.hwndFocus;
wcCapture: Result := GTI.hwndCapture;
wcMenuOwner: Result := GTI.hwndMenuOwner;
wcMoveSize: Result := GTI.hwndMoveSize;
wcCaret: Result := GTI.hwndCaret;
end;
end;
end;
{$ifdef win32}
//[function GetFocusedChild]
function GetFocusedChild( Wnd: HWnd ): HWnd;
var Tr1, Tr2: THandle;
begin
Result := 0;
Tr1 := GetCurrentThreadId;
Tr2 := GetWindowThreadProcessId( Wnd, nil );
if Tr1 = Tr2 then
Result := GetFocus
else
if AttachThreadInput( Tr2, Tr1, True ) then
begin
Result := GetFocus;
AttachThreadInput( Tr2, Tr1, False );
end;
end;
//[function WaitFocusedWndChild]
function WaitFocusedWndChild( Wnd: HWnd ): HWnd;
var T1, T2: Integer;
W: HWnd;
begin
Sleep( 50 );
T1 := GetTickCount;
while True do
begin
W := GetTopWindow( Wnd );
if W = 0 then W := Wnd;
W := GetFocusedChild( W );
if W <> 0 then
begin
Wnd := W;
break;
end;
T2 := GetTickCount;
if Abs( T1 - T2 ) > 100 then break;
end;
Result := Wnd;
end;
//[function Stroke2Window]
function Stroke2Window( Wnd: HWnd; const S: String ): Boolean;
var P: PChar;
begin
Result := False;
//Wnd := GetTopWindow( Wnd );
Wnd := WaitFocusedWndChild( Wnd );
if Wnd = 0 then Exit;
P := PChar( S );
while P^ <> #0 do
begin
PostMessage( Wnd, WM_CHAR, Integer( P^ ), 1 );
Inc( P );
end;
Result := True;
end;
//[function Stroke2WindowEx]
function Stroke2WindowEx( Wnd: HWnd; const S: String; Wait: Boolean ): Boolean;
var P: PChar;
EndChar: Char;
MsgDn, MsgUp, SCA: Integer;
function Compare( Pattern: PChar ): Boolean;
var Pos: PChar;
C1, C2: Char;
begin
Pos := P;
while Pattern^ <> #0 do
begin
C1 := Pattern^;
C2 := Pos^;
if C1 in [ 'a'..'z' ] then
C1 := Char( Ord( C1 ) - $20 );
if C2 in [ 'a'..'z' ] then
C2 := Char( Ord( C2 ) - $20 );
if C1 <> C2 then
begin
Result := False;
Exit;
end;
Inc( Pos );
Inc( Pattern );
end;
while Pos^ = ' ' do Inc( Pos );
P := Pos;
Result := True;
end;
procedure Send( Msg, KeyCode: Integer );
var lParam: Integer;
begin
Wnd := WaitFocusedWndChild( Wnd );
if Wnd = 0 then Exit;
lParam := 1;
if longBool( SCA and 4 ) then
lParam := $20000001;
if Msg = MsgUp then
lParam := lParam or Integer($D0000000);
PostMessage( Wnd, Msg, KeyCode, lParam );
Applet.ProcessMessages;
if Wait then
Sleep( 50 );
end;
function CompareSend( Pattern: PChar; Value2Send: Integer ): Boolean;
begin
if Compare( Pattern ) then
begin
Send( MsgDn, Value2Send );
Send( MsgUp, Value2Send );
Result := True;
end
else
Result := False;
end;
function ParseKeys( EndChar: Char ): PChar;
var FN: Integer;
begin
SCA := 0;
while not (P^ in [ #0, EndChar ]) do
begin
if Compare( 'Shift' ) then SCA := SCA or 1
else
if Compare( 'Ctrl' ) then SCA := SCA or 2
else
if Compare( 'Alt' ) then SCA := SCA or 4
else
break;
end;
MsgDn := WM_KEYDOWN;
MsgUp := WM_KEYUP;
if LongBool( SCA and 4 ) then
begin
MsgDn := WM_SYSKEYDOWN;
MsgUp := WM_SYSKEYUP;
keybd_event( VK_MENU, 0, 0, 0 );
Send( WM_SYSKEYDOWN, VK_MENU );
end;
if LongBool( SCA and 2 ) then
begin
keybd_event( VK_CONTROL, 0, 0, 0 );
Send( WM_KEYDOWN, VK_CONTROL );
end;
if Longbool( SCA and 1 ) then
begin
keybd_event( VK_SHIFT, 0, 0, 0 );
Send( WM_KEYDOWN, VK_SHIFT );
end;
while not (P^ in [ #0, EndChar ]) do
begin
if (P^ = 'F') and (P[ 1 ] in [ '1'..'9' ]) then
begin
Inc( P );
FN := Ord( P^ ) - Ord( '0' );
if (FN = 1) and (P[ 1 ] in [ '0'..'2' ]) then
begin
Inc( P );
FN := 10 + Ord( P^ ) - Ord( '0' );
end;
repeat Inc( P ) until P^ <> ' ';
FN := FN + $6F;
Send( MsgDn, FN );
Send( MsgUp, FN );
end
else
if Compare( 'Numpad' ) then
begin
if P^ in [ '0'..'9' ] then
begin
FN := Ord( P^ ) - Ord( '0' ) + $60;
repeat Inc( P^ ) until P^ <> ' ';
Send( MsgDn, FN );
Send( MsgUp, FN );
end;
end
else
if not (CompareSend( 'Add', $6B ) or
CompareSend( 'Gray+', $6B ) or
CompareSend( 'Apps', $5D ) or
CompareSend( 'BackSpace', $08 ) or
CompareSend( 'BkSp', $08 ) or
CompareSend( 'BS', $08 ) or
CompareSend( 'Break', $13 ) or
CompareSend( 'CapsLock', $14 ) or
CompareSend( 'Clear', $0C ) or
CompareSend( 'Decimal', $6E ) or
CompareSend( 'Del', $2E ) or
CompareSend( 'Delete', $2E ) or
CompareSend( 'Divide', $6F ) or
CompareSend( 'Gray/', $6F ) or
CompareSend( 'Down', $28 ) or
CompareSend( 'End', $23 ) or
CompareSend( 'Enter', $0D ) or
CompareSend( 'Return', $0D ) or
CompareSend( 'CR', $0D ) or
CompareSend( 'Esc', $1B ) or
CompareSend( 'Escape', $1B ) or
CompareSend( 'Help', $2F ) or
CompareSend( 'Home', $24 ) or
CompareSend( 'Ins', $2D ) or
CompareSend( 'Insert', $2D ) or
CompareSend( 'Left', $25 ) or
CompareSend( 'LWin', $5B ) or
CompareSend( 'Multiply', $6A ) or
CompareSend( 'Gray*', $6A ) or
CompareSend( 'NumLock', $90 ) or
CompareSend( 'PgDn', $22 ) or
CompareSend( 'PgUp', $21 ) or
CompareSend( 'PrintScrn', $2C ) or
CompareSend( 'Right', $27 ) or
CompareSend( 'RWin', $5C ) or
CompareSend( 'Separator', $6C ) or
CompareSend( 'ScrollLock', $91 ) or
CompareSend( 'Subtract', $6D ) or
CompareSend( 'Tab', $09 ) or
CompareSend( 'Gray-', $6D ) or
CompareSend( 'Up', $26 )) then break;
end;
while not (P^ in [ #0, EndChar ]) do
begin
if P^ in [ 'A'..'Z', '0'..'9' ] then
begin
Send( MsgDn, Integer( P^ ) );
Send( MsgUp, Integer( P^ ) );
end
else
if P^ in [ #1..#255 ] then
Stroke2Window( Wnd, '' + P^ );
repeat Inc( P ) until (P^ <> ' ');
end;
if P^ = EndChar then
Inc( P );
if Longbool( SCA and 1 ) then
begin
Send( WM_KEYUP, VK_SHIFT );
keybd_event( VK_SHIFT, 0, KEYEVENTF_KEYUP, 0 );
end;
if LongBool( SCA and 2 ) then
begin
Send( WM_KEYUP, VK_CONTROL );
keybd_event( VK_CONTROL, 0, KEYEVENTF_KEYUP, 0 );
end;
if LongBool( SCA and 4 ) then
begin
Send( WM_SYSKEYUP, VK_MENU );
keybd_event( VK_MENU, 0, KEYEVENTF_KEYUP, 0 );
end;
Result := P;
end;
begin
Result := False;
Wnd := GetTopWindow( Wnd );
Wnd := GetFocusedChild( Wnd );
if Wnd = 0 then Exit;
P := PChar( S );
while P^ <> #0 do
begin
if not (P^ in [ '[', '{' ]) then
begin
Stroke2Window( Wnd, '' + P^ );
Inc( P );
end
else
begin
if P^ = '[' then
EndChar := ']'
else
EndChar := '}';
Inc( P );
P := ParseKeys( EndChar );
end;
end;
Result := True;
end;
{$endif win32}
type
PHWnd = ^HWnd;
TFindWndRec = {$ifndef wince}packed{$endif} Record
ThreadID : DWord;
WndFound : HWnd;
end;
PFindWndRec = ^TFindWndRec;
//[function EnumWindowsProc]
function EnumWindowsProc( Wnd : HWnd; Find : PFindWndRec ) : Boolean;
{$ifdef wince}cdecl{$else}stdcall{$endif};
var Id : DWord;
begin
Result := True;
Id := GetWindowThreadProcessId( Wnd, @Id );
if Id = Find.ThreadID then
begin
Find.WndFound := Wnd;
Result := False;
end;
end;
//[function FindWindowByThreadID]
function FindWindowByThreadID( ThreadID : DWORD ) : HWnd;
var Find : TFindWndRec;
begin
Find.ThreadID := ThreadID;
Find.WndFound := 0;
EnumWindows( @EnumWindowsProc, Integer( @Find ) );
Result := Find.WndFound;
end;
//[function DesktopPixelFormat]
function DesktopPixelFormat: TPixelFormat;
var DC: HDC;
Nbits_per_pixel, Nplanes: Integer;
begin
DC := GetDC( 0 );
Nbits_per_pixel := GetDeviceCaps( DC, BITSPIXEL );
Nplanes := GetDeviceCaps( DC, PLANES );
ReleaseDC( 0, DC );
CASE Nplanes * Nbits_per_pixel OF
1: Result := pf1bit;
4: Result := pf4bit;
8: Result := pf8bit;
16: Result := pf16bit;
24, 32: Result := pf32bit;
else Result := pfDevice;
END;
end;
//[function GetDesktopRect]
function GetDesktopRect : TRect;
{$ifdef win32}
var W1, W2 : HWnd;
{$endif win32}
begin
Result := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) );
{$ifdef win32}
W2 := findwindow(nil,'Program Manager');
W1 := findwindowex(W2,0,'SHELLDLL_DefView',nil);
if W1 = 0 then Exit;
GetWindowRect( W1, Result );
{$endif win32}
end;
//[function GetWorkArea]
function GetWorkArea: TRect;
begin
SystemParametersInfo( SPI_GETWORKAREA, 0, @ Result, 0 );
end;
//[function ExecuteWait]
function ExecuteWait( const AppPath, CmdLine, DfltDirectory: KOLString;
Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean;
var Flags: DWORD;
Startup: TStartupInfo;
ProcInf: TProcessInformation;
DfltDir, pAppPath: PKOLChar;
Cmd: KOLString;
begin
Result := FALSE;
{$ifdef wince}
Flags := 0;
{$else}
Flags := CREATE_NEW_CONSOLE;
if Show = SW_HIDE then
Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF};
{$endif wince}
FillChar( Startup, SizeOf( Startup ), #0 );
Startup.cb := Sizeof( Startup );
Startup.wShowWindow := Show;
Startup.dwFlags := STARTF_USESHOWWINDOW;
if ProcID <> nil then
ProcID^ := 0;
DfltDir := nil;
if DfltDirectory <> '' then
DfltDir := PKOLChar( DfltDirectory );
if AppPath <> '' then
pAppPath:=PKOLChar(AppPath)
else
pAppPath:=nil;
Cmd:=CmdLine; // CmdLine parameter must not be const
if CreateProcess( pAppPath, PKOLChar(Cmd), nil,
nil, FALSE, Flags, nil, DfltDir, Startup,
ProcInf ) then
begin
if WaitForSingleObject( ProcInf.hProcess, TimeOut ) = WAIT_OBJECT_0 then
begin
CloseHandle( ProcInf.hProcess );
Result := TRUE;
end
else
begin
if ProcID <> nil then
ProcID^ := ProcInf.hProcess;
end;
CloseHandle( ProcInf.hThread );
end;
end;
{$ifdef win32}
//[function ExecuteIORedirect]
function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString;
Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean;
var Flags: DWORD;
Startup: TStartupInfo;
ProcInf: TProcessInformation;
DfltDir: PKOLChar;
SecurityAttributes: TSecurityAttributes;
SaveStdOut, SaveStdIn: THandle;
ChildStdOutRd, ChildStdOutWr: THandle;
ChildStdInRd, ChildStdInWr: THandle;
ChildStdOutRdDup: THandle;
ChildStdInWrDup: THandle;
procedure Do_CloseHandle( var Handle: THandle );
begin
if Handle <> 0 then
begin
CloseHandle( Handle );
Handle := 0;
end;
end;
procedure Close_Handles;
begin
Do_CloseHandle( ChildStdOutRd );
Do_CloseHandle( ChildStdOutWr );
Do_CloseHandle( ChildStdInRd );
Do_CloseHandle( ChildStdInWr );
end;
function RedirectInputOutput: Boolean;
begin
Result := FALSE;
if (OutPipeRd <> nil) or (OutPipeWr <> nil) then
begin
// redirect output
SaveStdOut := GetStdHandle(STD_OUTPUT_HANDLE);
if not CreatePipe( ChildStdOutRd, ChildStdOutWr, @ SecurityAttributes, 0 ) then
Exit;
if not SetStdHandle( STD_OUTPUT_HANDLE, ChildStdOutWr ) then
Exit;
if not DuplicateHandle( GetCurrentProcess, ChildStdOutRd,
GetCurrentProcess, @ ChildStdOutRdDup, 0, FALSE,
2 {DUPLICATE_SAME_ACCESS} ) then
Exit;
Do_CloseHandle( ChildStdOutRd );
if OutPipeRd <> nil then
OutPipeRd^ := ChildStdOutRdDup;
if OutPipeWr <> nil then
OutPipeWr^ := ChildStdOutWr;
end;
if InPipe <> nil then
begin
// redirect input
SaveStdIn := GetStdHandle(STD_INPUT_HANDLE);
if not CreatePipe( ChildStdInRd, ChildStdInWr, @ SecurityAttributes, 0 ) then
Exit;
if not SetStdHandle( STD_INPUT_HANDLE, ChildStdInRd ) then
Exit;
if not DuplicateHandle( GetCurrentProcess, ChildStdInWr,
GetCurrentProcess, @ ChildStdInWrDup, 0, FALSE,
2 {DUPLICATE_SAME_ACCESS} ) then
Exit;
Do_CloseHandle( ChildStdInWr );
if InPipe <> nil then
InPipe^ := ChildStdInWrDup;
Do_CloseHandle( ChildStdInRd );
end;
Result := TRUE;
end;
procedure Restore_Saved_StdInOut;
begin
SetStdHandle( STD_OUTPUT_HANDLE, SaveStdOut );
SetStdHandle( STD_INPUT_HANDLE, SaveStdIn );
end;
begin
Result := FALSE;
Flags := 0;
if Show = SW_HIDE then
Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF};
FillChar( Startup, SizeOf( Startup ), #0 );
Startup.cb := Sizeof( Startup );
if ProcID <> nil then
ProcID^ := 0;
DfltDir := nil;
SecurityAttributes.nLength := Sizeof( SecurityAttributes );
SecurityAttributes.lpSecurityDescriptor := nil;
SecurityAttributes.bInheritHandle := TRUE;
SaveStdOut := 0;
SaveStdIn := 0;
ChildStdOutRd := 0;
ChildStdOutWr := 0;
ChildStdInRd := 0;
ChildStdInWr := 0;
if not RedirectInputOutput then
begin
Close_Handles;
Exit;
end;;
if DfltDirectory <> '' then
DfltDir := PKOLChar( DfltDirectory );
if CreateProcess( nil, PKOLChar( '"' + AppPath + '" ' + CmdLine ),
nil, nil, TRUE, Flags, nil, DfltDir, Startup,
ProcInf ) then
begin
if ProcID <> nil then
ProcID^ := ProcInf.hProcess
else
CloseHandle( ProcInf.hProcess );
CloseHandle( ProcInf.hThread );
Restore_Saved_StdInOut;
Result := TRUE;
end
else
begin
Restore_Saved_StdInOut;
Close_Handles;
Exit;
end;
end;
//[function ExecuteConsoleAppIORedirect]
function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: String;
Show: DWORD; const InStr: String; var OutStr: String; WaitTimeout: DWORD ): Boolean;
var PipeIn, PipeOutRd, PipeOutWr: THandle;
ProcID: DWORD;
BytesCount: DWORD;
Buffer: array[ 0..4096 ] of Char;
BufStr: String;
PPipeIn: PHandle;
begin
Result := FALSE;
PPipeIn := @ PipeIn;
if InStr = '' then
PPipeIn := nil;
PipeOutRd := 0;
PipeOutWr := 0;
if not ExecuteIORedirect( AppPath, CmdLine, DfltDirectory, Show, @ ProcID,
PPipeIn, @ PipeOutWr, @ PipeOutRd ) then Exit;
if PPipeIn <> nil then
begin
if InStr <> '' then
WriteFile( PipeIn, InStr[ 1 ], Length( InStr ), BytesCount, nil );
CloseHandle( PipeIn );
end;
OutStr := '';
if WaitForSingleObject( ProcID, WaitTimeOut ) = WAIT_OBJECT_0 then
begin
CloseHandle( ProcID );
CloseHandle( PipeOutWr );
while ReadFile( PipeOutRd, Buffer, Sizeof( Buffer ), BytesCount, nil ) do
begin
SetLength( BufStr, BytesCount );
Move( Buffer[ 0 ], BufStr[ 1 ], BytesCount );
OutStr := OutStr + BufStr;
end;
end
else
CloseHandle( PipeOutWr );
CloseHandle( PipeOutRd );
Result := TRUE;
end;
{$IFDEF _D2}
//[API OpenProcessToken]
function OpenProcessToken(ProcessHandle: THandle; DesiredAccess: DWORD;
var TokenHandle: THandle): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
external advapi32 name 'OpenProcessToken';
{$ENDIF}
//[function WindowsShutdown]
function WindowsShutdown( const Machine : KOLString; Force, Reboot : Boolean ) : Boolean;
var
hToken: THandle;
tkp, tkp_prev: TTokenPrivileges;
dwRetLen :DWORD;
Flags: Integer;
begin
Result := False;
if Integer( GetVersion ) < 0 then // Windows95/98/Me
begin
if Machine <> '' then Exit;
Flags := EWX_SHUTDOWN;
if Reboot then
Flags := Flags or EWX_REBOOT;
if Force then
Flags := Flags or EWX_FORCE;
Result := ExitWindowsEx( Flags, 0 );
Exit;
end;
OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
hToken);
if not LookupPrivilegeValue(PKOLChar(Machine), 'SeShutdownPrivilege',
tkp.Privileges[0].Luid) then Exit;
tkp_prev:=tkp;
tkp.PrivilegeCount:=1;
tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev,
dwRetLen);
if not LookupPrivilegeValue(PKOLChar(Machine),
'SeRemoteShutdownPrivilege',
tkp.Privileges[0].Luid)
then
Exit;
tkp.PrivilegeCount:=1;
tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev,
dwRetLen);
Result := InitiateSystemShutdown(PKOLChar(Machine),nil, 0, Force, Reboot);
end;
var SaveWinVer: Byte = $FF;
//[function WinVer]
{$IFDEF ASM_VERSION}
{$ELSE ASM_VERSION}
function WinVer : TWindowsVersion;
var MajorVersion, MinorVersion: Byte;
dwVersion: Integer;
begin
if SaveWinVer <> $FF then Result := TWindowsVersion( SaveWinVer )
else
begin
dwVersion := GetVersion;
MajorVersion := LoByte( dwVersion );
MinorVersion := HiByte( LoWord( dwVersion ) );
if dwVersion >= 0 then
begin
Result := wvNT;
if MajorVersion >= 6 then
Result := wvVista
else begin
if MajorVersion >= 5 then
if MinorVersion >= 1 then
begin
Result := wvXP;
if MinorVersion >= 2 then
Result := wvServer2003;
end
else Result := wvY2K;
end;
end
else
begin
Result := wv95;
if (MajorVersion > 4) or
(MajorVersion = 4) and (MinorVersion >= 10) then
begin
Result := wv98;
if (MajorVersion = 4) and (MinorVersion >= $5A) then
Result := wvME;
end
else
if MajorVersion <= 3 then
Result := wv31;
end;
SaveWinVer := Ord( Result );
end;
end;
{$ENDIF ASM_VERSION}
{$else}
function WinVer : TWindowsVersion;
begin
Result:=wvCE;
end;
{$endif win32}
//[function IsWinVer]
function IsWinVer( Ver : TWindowsVersions ) : Boolean;
{* Returns True if Windows version is in given range of values. }
begin
Result := WinVer in Ver;
end;
//[procedure TControl.SetAlphaBlend]
procedure TControl.SetAlphaBlend(const Value: Integer);
const
LWA_COLORKEY=$00000001;
LWA_ALPHA=$00000002;
ULW_COLORKEY=$00000001;
ULW_ALPHA=$00000002;
ULW_OPAQUE=$00000004;
WS_EX_LAYERED=$00080000;
type
TSetLayeredWindowAttributes=
function( hwnd: Integer; crKey: TColor; bAlpha: Byte; dwFlags: DWORD )
: Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
var
SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
User32: THandle;
dw: DWORD;
begin
if Value = fAlphaBlend then Exit;
fAlphaBlend := Value;
User32 := GetModuleHandle( 'User32' );
SetLayeredWindowAttributes := GetProcAddress( User32,
'SetLayeredWindowAttributes' );
if Assigned( SetLayeredWindowAttributes ) then
begin
dw := GetWindowLong( GetWindowHandle, GWL_EXSTYLE );
if Byte( Value ) < 255 then
begin
SetWindowLong( fHandle, GWL_EXSTYLE, dw or WS_EX_LAYERED );
SetLayeredWindowAttributes( fHandle, 0, Value and $FF, LWA_ALPHA);
end
else
SetWindowLong( fHandle, GWL_EXSTYLE, dw and not WS_EX_LAYERED );
end;
end;
{$ENDIF WIN_GDI}
//[function TControl.SetPosition]
function TControl.SetPosition( X, Y: Integer ): PControl;
begin
Left := X;
Top := Y;
Result := @Self;
end;
{$IFDEF WIN_GDI}
//[function NewColorDialog]
function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog;
var I: Integer;
begin
{-}
New( Result, Create );
{+}{++}(*Result := PColorDialog.Create;*){--}
Result.ColorCustomOption := FullOpen;
for I := 1 to 16 do
Result.CustomColors[ I ] := clWhite;
end;
//[END NewColorDialog]
{ TColorDialog }
//[function TColorDialog.Execute]
function TColorDialog.Execute: Boolean;
var CD: TChooseColor;
begin
CD.lStructSize := Sizeof( CD );
CD.hWndOwner := OwnerWindow;
//CD.hInstance := 0;
CD.rgbResult := Color2RGB( Color );
CD.lpCustColors := @CustomColors[ 1 ];
CD.Flags := CC_RGBINIT;
case ColorCustomOption of
ccoFullOpen: CD.Flags := CD.Flags or CC_FULLOPEN;
ccoPreventFullOpen: CD.Flags := CD.Flags or CC_PREVENTFULLOPEN;
end;
Result := ChooseColor( {$ifdef wince}@{$endif}CD );
if Result then
Color := CD.rgbResult;
end;
//[procedure TControl.SetMaxProgress]
procedure TControl.SetMaxProgress(const Index, Value: Integer);
begin
// ignore index, and set Value via PBM_SETRANGE32: ()
Perform( PBM_SETRANGE32, 0, Value );
end;
//[procedure TControl.SetDroppedWidth]
procedure TControl.SetDroppedWidth(const Value: Integer);
begin
FDroppedWidth := Value;
Perform( CB_SETDROPPEDWIDTH, Value, 0 );
end;
//[function TControl.LVGetItemState]
function TControl.LVGetItemState(Idx: Integer): TListViewItemState;
type
PListViewItemState = ^TListViewItemState;
var I: integer;
begin
I := Perform( LVM_GETITEMSTATE, Idx,
LVIS_CUT or LVIS_DROPHILITED or LVIS_FOCUSED or LVIS_SELECTED );
Result := PListViewItemState( @ I )^;
end;
//[procedure TControl.LVSetItemState]
procedure TControl.LVSetItemState(Idx: Integer; const Value: TListViewItemState);
var Data: TLVItem;
begin
Data.stateMask := LVIS_FOCUSED or LVIS_SELECTED or LVIS_CUT or LVIS_DROPHILITED;
Data.state := PByte( @ Value )^;
Perform( LVM_SETITEMSTATE, Idx, Integer( @Data ) );
end;
//[procedure TControl.LVSelectAll]
procedure TControl.LVSelectAll;
begin
LVSetItemState( -1, [ lvisSelect ] );
end;
//[function TControl.LVItemInsert]
function TControl.LVItemInsert(Idx: Integer; const aText: KOLString): Integer;
var LVI: TLVItem;
begin
LVI.mask := LVIF_TEXT;
LVI.iItem := Idx;
LVI.iSubItem := 0;
LVI.pszText := PKOL_Char( aText );
Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) );
end;
//[function TControl.LVItemAdd]
function TControl.LVItemAdd(const aText: KOLString): Integer;
begin
Result := LVItemInsert( Count, aText );
end;
//[function TControl.LVGetSttImgIdx]
function TControl.LVGetSttImgIdx(Idx: Integer): Integer;
begin
Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_STATEIMAGEMASK ) shr 12;
end;
//[procedure TControl.LVSetSttImgIdx]
procedure TControl.LVSetSttImgIdx(Idx: Integer; const Value: Integer);
var LVI: TLVItem;
begin
LVI.stateMask := LVIS_STATEIMAGEMASK;
LVI.state := Value shl 12;
Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) );
end;
//[function TControl.LVGetOvlImgIdx]
function TControl.LVGetOvlImgIdx(Idx: Integer): Integer;
begin
Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_OVERLAYMASK ) shr 8;
end;
//[procedure TControl.LVSetOvlImgIdx]
procedure TControl.LVSetOvlImgIdx(Idx: Integer; const Value: Integer);
var LVI: TLVItem;
begin
LVI.stateMask := LVIS_OVERLAYMASK;
LVI.state := Value shl 8;
Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) );
end;
//[function TControl.LVGetItemData]
function TControl.LVGetItemData(Idx: Integer): DWORD;
var LVI: TLVItem;
begin
LVI.mask := LVIF_PARAM;
LVI.iItem := Idx;
LVI.iSubItem := 0;
Perform( LVM_GETITEM, 0, Integer( @LVI ) );
Result := LVI.lParam;
end;
//[procedure TControl.LVSetItemData]
procedure TControl.LVSetItemData(Idx: Integer; const Value: DWORD);
var LVI: TLVItem;
begin
LVI.mask := LVIF_PARAM;
LVI.iItem := Idx;
LVI.iSubItem := 0;
LVI.lParam := Value;
Perform( LVM_SETITEM, 0, Integer( @LVI ) );
end;
//[function TControl.LVGetItemIndent]
function TControl.LVGetItemIndent(Idx: Integer): Integer;
var LI: TLVItem;
begin
LI.mask := LVIF_INDENT;
LI.iItem := Idx;
LI.iSubItem := 0;
Perform( LVM_GETITEM, 0, Integer( @LI ) );
Result := LI.iIndent;
end;
//[procedure TControl.LVSetItemIndent]
procedure TControl.LVSetItemIndent(Idx: Integer; const Value: Integer);
var LI: TLVItem;
begin
LI.mask := LVIF_INDENT;
LI.iItem := Idx;
LI.iSubItem := 0;
LI.iIndent := Value;
Perform( LVM_SETITEM, 0, Integer( @LI ) );
end;
type
TNMLISTVIEW = {$ifndef wince}packed{$endif} Record
hdr: TNMHDR;
iItem: Integer;
iSubItem: Integer;
uNewState: Integer;
uOldState: Integer;
uChanged: Integer;
ptAction: Integer;
lParam: DWORD;
end;
PNMLISTVIEW = ^TNMLISTVIEW;
//[function WndProc_LVDeleteItem]
function WndProc_LVDeleteItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
var Hdr: PNMHDR;
LV: PNMListView;
begin
Result := FALSE;
if Msg.message = WM_NOTIFY then
begin
Hdr := Pointer(Msg.lParam);
if Hdr.hwndFrom = Sender.Handle then
begin
LV := Pointer( Hdr );
if LongInt(Hdr.code) = LVN_DELETEITEM then
begin
if Assigned( Sender.OnDeleteLVItem ) then
Sender.OnDeleteLVItem( Sender, LV.iItem );
Result := TRUE;
end
else
if LongInt(Hdr.code) = LVN_DELETEALLITEMS then
begin
if Assigned( Sender.OnDeleteAllLVItems ) then
begin
Sender.OnDeleteAllLVItems( Sender );
Rslt := 0;
if Assigned( Sender.OnDeleteLVItem ) then
Rslt := 1;
end;
Result := TRUE;
end;
end;
end;
end;
//[procedure TControl.SetOnDeleteAllLVItems]
procedure TControl.SetOnDeleteAllLVItems(const Value: TOnEvent);
begin
fOnDeleteAllLVItems := Value;
AttachProc( @WndProc_LVDeleteItem );
end;
//[procedure TControl.SetOnDeleteLVItem]
procedure TControl.SetOnDeleteLVItem(const Value: TOnDeleteLVItem);
begin
fOnDeleteLVItem := Value;
AttachProc( @WndProc_LVDeleteItem );
end;
//[function WndProc_LVData]
function WndProc_LVData( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
var Hdr: PNMHDR;
DI: PLVDispInfo;
Store: Boolean;
Txt: KOL_String;
LV: PControl;
begin
Result := FALSE;
if Msg.message = WM_NOTIFY then
begin
Hdr := Pointer(Msg.lParam);
if Hdr.hwndFrom = Sender.Handle then
begin
if (LongInt(Hdr.code) = LVN_GETDISPINFO)
{$IFDEF UNICODE_CTRLS}
or (LongInt(Hdr.code) = LVN_GETDISPINFOW)
{$ENDIF UNICODE_CTRLS}
then
begin
DI := Pointer( Hdr );
LV := Sender;
if LV <> nil then
begin
DI.item.iImage := -1;
DI.item.state := 0;
Store := FALSE;
if Assigned( LV.OnLVData ) and (DI.item.iItem >= 0) then
begin
LV.OnLVData( LV, DI.item.iItem, DI.item.iSubItem, Txt,
DI.item.iImage, DWORD( DI.item.state ), Store );
if LongBool(DI.item.mask and LVIF_TEXT) then begin
LV.fCaption := Txt;
DI.item.pszText := PKOL_Char( PKOLChar( LV.fCaption ) );
end;
DI.item.stateMask := 0;
if DI.item.state and LVIS_STATEIMAGEMASK <> 0 then
DI.item.stateMask := LVIS_STATEIMAGEMASK;
if DI.item.state and LVIS_OVERLAYMASK <> 0 then
DI.item.stateMask := DI.item.stateMask or LVIS_OVERLAYMASK;
if DI.item.state and $7F <> 0 then
DI.item.stateMask := DI.item.stateMask or $7F;
if Store then
DI.item.mask := DI.item.mask or LVIF_DI_SETITEM;
end;
Result := TRUE;
end;
end;
end;
end;
end;
//[procedure TControl.SetOnLVData]
procedure TControl.SetOnLVData(const Value: TOnLVData);
begin
fOnLVData := Value;
AttachProc( @WndProc_LVData );
Perform( LVM_SETCALLBACKMASK, LVIS_OVERLAYMASK or LVIS_STATEIMAGEMASK, 0 );
end;
{$IFDEF ENABLE_DEPRECATED}
{$DEFINE implementation} {$I KOL_deprecated.inc} {$UNDEF implementation}
{$ENDIF DISABLE_DEPRECATED}
//[function WndProc_LVCustomDraw]
function WndProc_LVCustomDraw( Sender: PControl; var Msg: TMsg;
var Rslt: Integer ): Boolean;
var NMCustDraw: PNMLVCustomDraw;
NMHdr: PNMHdr;
ItemIdx, SubItemIdx: Integer;
S: TListViewItemState;
ItemState: TDrawState;
begin
Result := FALSE;
if Msg.message = WM_NOTIFY then
begin
NMHdr := Pointer( Msg.lParam );
if (LongInt(NMHdr.code) = NM_CUSTOMDRAW) and Assigned( Sender.fOnLVCustomDraw ) then
begin
NMCustDraw := Pointer( Msg.lParam );
ItemIdx := -1;
SubItemIdx := -1;
if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_ITEM ) then
ItemIdx := NMCustDraw.nmcd.dwItemSpec;
if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_SUBITEM ) then
SubItemIdx := NMCustDraw.iSubItem;
ItemState := [ ];
if ItemIdx >= 0 then
begin
S := Sender.LVItemState[ ItemIdx ];
if lvisFocus in S then
ItemState := ItemState + [ odsFocused ];
if lvisSelect in S then
ItemState := ItemState + [ odsSelected ];
if lvisBlend in S then
ItemState := ItemState + [ odsGrayed ];
if lvisHighlight in S then
ItemState := ItemState + [ odsMarked ];
end;
Sender.Canvas;
Rslt := Sender.FOnLVCustomDraw( Sender, {Sender.fPaintDC} NMCustDraw.nmcd.hdc,
NMCustDraw.nmcd.dwDrawStage, ItemIdx, SubItemIdx, NMCustDraw.nmcd.rc,
ItemState, TColor( NMCustDraw.clrText ), TColor( NMCustDraw.clrTextBk ) );
Result := TRUE;
end;
end;
end;
//[procedure TControl.SetOnLVCustomDraw]
procedure TControl.SetOnLVCustomDraw(const Value: TOnLVCustomDraw);
begin
fOnLVCustomDraw := Value;
AttachProc( @WndProc_LVCustomDraw );
end;
//[function CompareLVItems]
function CompareLVItems( Idx1, Idx2: Integer; ListView: PControl ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
if Assigned( ListView.fOnCompareLVItems ) then
Result := ListView.fOnCompareLVItems( ListView, Idx1, Idx2 )
else
Result := 0;
end;
//[procedure TControl.LVSort]
procedure TControl.LVSort;
begin
{$ifdef wince}
MsgOk('TControl.LVSort must be fixed!');
Halt(6); // FIXME
{$else}
Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVItems) );
{$endif wince}
end;
//[function CompareLVItemsData]
function CompareLVItemsData( D1, D2: DWORD; ListView: PControl ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
begin
if Assigned( ListView.fOnCompareLVItems ) then
Result := ListView.fOnCompareLVItems( ListView, D1, D2 )
else
Result := 0;
end;
//[procedure TControl.LVSortData]
procedure TControl.LVSortData;
begin
Perform( LVM_SORTITEMS, Integer( @Self ), Integer( @CompareLVItemsData ) );
end;
//[function WndProc_LVColumnClick]
function WndProc_LVColumnClick( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
var Hdr: PNMHDR;
LV: PNMListView;
begin
Result := FALSE;
if Msg.message = WM_NOTIFY then
begin
Hdr := Pointer(Msg.lParam);
if Hdr.hwndFrom = Sender.Handle then
begin
LV := Pointer( Hdr );
if LongInt(Hdr.code) = LVN_COLUMNCLICK then
begin
if Assigned( Sender.OnColumnClick ) then
Sender.OnColumnClick( Sender, LV.iSubItem );
Result := TRUE;
end;
end;
end;
end;
//[procedure TControl.SetOnColumnClick]
procedure TControl.SetOnColumnClick(const Value: TOnLVColumnClick);
begin
fOnColumnClick := Value;
AttachProc( @WndProc_LVColumnClick );
end;
//[function WndProc_LVStateChange]
function WndProc_LVStateChange( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean;
var NMOD: PNMLVODStateChange;
NMLV: PNMLISTVIEW;
begin
if Msg.message = WM_NOTIFY then
begin
NMOD := Pointer( Msg.lParam );
NMLV := Pointer( Msg.lParam );
if LongInt(NMOD.hdr.code) = LVN_ODSTATECHANGED then
begin
if Assigned( Sender.OnLVStateChange ) then
Sender.OnLVStateChange( Sender, NMOD.iFrom, NMOD.iTo,
NMOD.uOldState, NMOD.uNewState );
end
else
if LongInt(NMLV.hdr.code) = LVN_ITEMCHANGED then
begin
if Assigned( Sender.OnLVStateChange ) then
Sender.OnLVStateChange( Sender, NMLV.iItem, NMLV.iItem,
NMLV.uOldState, NMLV.uNewState );
end;
end;
Result := FALSE;
end;
//[procedure TControl.SetOnLVStateChange]
procedure TControl.SetOnLVStateChange(const Value: TOnLVStateChange);
begin
FOnLVStateChange := Value;
AttachProc( WndProc_LVStateChange );
end;
//[function CompareLVColumns]
function CompareLVColumns( Idx1, Idx2: Integer; Sender: PControl ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
var S1, S2: String;
begin
//--- changed by Mike Gerasimov:
S1 := Sender.LVItems[ Idx1, Sender.fColumn ];
S2 := Sender.LVItems[ Idx2, Sender.fColumn ];
If lvoSortAscending in Sender.fLVOptions Then
Result := AnsiCompareStrNoCase( S1, S2 )
Else
If lvoSortDescending in Sender.fLVOptions Then
Result := AnsiCompareStrNoCase( S2, S1 )
Else
Result:=0;
end;
//[procedure TControl.LVSortColumn]
procedure TControl.LVSortColumn(Idx: Integer);
begin
fColumn := Idx;
{$ifdef wince}
MsgOk('TControl.LVSortColumn must be fixed!');
Halt(6); // FIXME
{$else}
Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVColumns) );
{$endif wince}
end;
//[function TControl.LVIndexOf]
function TControl.LVIndexOf(const S: KOLString): Integer;
begin
Result := LVSearchFor( S, -1, FALSE );
end;
//[function TControl.LVSearchFor]
function TControl.LVSearchFor(const S: KOLString; StartAfter: Integer;
Partial: Boolean): Integer;
var f: TLVFindInfo;
begin
f.lParam := 0;
f.flags := LVFI_STRING;
if Partial then
f.flags := LVFI_STRING or LVFI_PARTIAL;
f.psz := @s[1];
result := Perform(LVM_FINDITEM,StartAfter,integer(@f));
end;
function WndProcLVMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var
pMI: PMeasureItemStruct;
P: PControl;
H: Integer;
wId: DWORD;
i: Integer;
begin
Result := FALSE;
if Msg.message = WM_MEASUREITEM then begin
pMI := Pointer(Msg.lParam);
with pMI^ do begin
for i:=0 to Sender.ChildCount-1 do begin
P := Sender.Children[i];
if P <> nil then begin
wId := GetWindowLong(P.Handle,GWL_ID);
if CtlID = wId then begin
H := P.fLVItemHeight;
if H > 0 then begin
itemHeight := H;
Rslt:=1;
Result := TRUE;
end;
break;
end;
end;
end;
end;
end;
end;
function TControl.SetLVItemHeight(Value: Integer): PControl;
begin
Set_LVItemHeight( Value );
Result := @ Self;
end;
procedure TControl.Set_LVItemHeight(Value: Integer);
begin
if fLVItemHeight <> Value then begin
if fLVItemHeight = 0 then
Parent.AttachProc(WndProcLVMeasureItem);
fLVItemHeight := Value;
end;
end;
//[function TControl.IndexOf]
function TControl.IndexOf(const S: KOLString): Integer;
begin
Result := SearchFor( S, -1, FALSE );
end;
//[function TControl.SearchFor]
function TControl.SearchFor(const S: KOLString; StartAfter: Integer;
Partial: Boolean): Integer;
var Cmd: Integer;
I: Integer;
begin
Cmd := fCommandActions.aFindItem;
if Partial then
Cmd := fCommandActions.aFindPartial;
if Cmd <> 0 then
Result := Perform( Cmd, StartAfter, Integer( PKOLChar( S ) ) )
else
begin
Result := -1;
for I := StartAfter+1 to Count-1 do
begin
if Partial and ( Copy( Items[ I ], 1, Length( S ) ) = S ) or
( Items[ I ] = S ) then
begin
Result := I;
break;
end;
end;
end;
end;
//[function TControl.DefaultBtnProc]
function TControl.DefaultBtnProc(var Msg: TMsg;
var Rslt: Integer): Boolean;
var Btn: PControl;
F: PControl;
begin
if Assigned( fOldOnMessage ) then
begin
Result := fOldOnMessage( Msg, Rslt );
if Result then Exit;
end;
Result := FALSE;
if AppletTerminated then Exit;
F := Applet;
if not F.fIsForm then
begin
F := F.fCurrentControl;
if F = nil then Exit;
end;
Btn := nil;
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
((Msg.wParam = VK_RETURN) or (Msg.wParam = VK_ESCAPE)) then
begin
if (Msg.wParam = VK_RETURN) and
(F.fDefaultBtnCtl <> nil) and
F.fDefaultBtnCtl.ToBeVisible and
F.fDefaultBtnCtl.Enabled and
((F.fCurrentControl=nil) or (not F.fCurrentControl.fCancelBtn and
not F.fCurrentControl.fIgnoreDefault)
or (F.fCurrentControl = F.fDefaultBtnCtl)
) then
Btn := F.fDefaultBtnCtl
else
if (Msg.wParam = VK_ESCAPE) and
(F.fCancelBtnCtl <> nil) and
F.fCancelBtnCtl.ToBeVisible and
F.fCancelBtnCtl.Enabled then
Btn := F.fCancelBtnCtl
else
if (Msg.wParam = VK_RETURN) and
(F.fAllBtnReturnClick or fAllBtnReturnClick) and
(F.ActiveControl <> nil) and
(F.ActiveControl.ToBeVisible) and
(F.ActiveControl.IsButton) and
(F.ActiveControl.Count = 0) then
Btn := F.ActiveControl;
if Btn <> nil then
begin
if Msg.message = WM_KEYDOWN then
begin
{$IFDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY}
//Btn.Click;
if Assigned( Btn.OnClick ) then
Btn.OnClick( Btn );
{$ELSE}
Btn.Focused := TRUE;
{$ENDIF}
end;
{$IFDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY}
{$ELSE}
Btn.Perform( Msg.message, DWORD( ' ' ), Msg.lParam );
{$ENDIF}
Msg.wParam := 0;
Result := TRUE;
Rslt := 0;
Exit;
end
end;
Result := FALSE;
end;
//[procedure TControl.SetDefaultBtn]
procedure TControl.SetDefaultBtn(const Index: Integer;
const Value: Boolean);
var F, C: PControl;
begin
if Index = 13 then
begin
fDefaultBtn := Value;
{$IFDEF DEFAULT_CANCEL_BTN_EXCLUSIVE}
fCancelBtn := FALSE;
{$ENDIF}
end
else
if Index = 27 then
begin
fCancelBtn := Value;
{$IFDEF DEFAULT_CANCEL_BTN_EXCLUSIVE}
fDefaultBtn := FALSE;
{$ENDIF}
end;
if Applet = nil then Exit;
F := ParentForm;
if F <> nil then
begin
if Value then
begin
if @ Applet.fOnMessage <> @ TControl.DefaultBtnProc then
Applet.fOldOnMessage := Applet.fOnMessage; // fixed by YS
Applet.fOnMessage := Applet.DefaultBtnProc;
end
else
begin
Applet.fOnMessage := Applet.fOldOnMessage;
Applet.fOldOnMessage := nil;
end;
C := nil;
if Value then C := @ Self;
if Index = 13 then
begin
F.fDefaultBtnCtl := C;
{$ifndef wince}
{$IFDEF NO_DEFAULT_BUTTON_BOLD}
{$ELSE}
if Value then
Style := Style or BS_DEFPUSHBUTTON
else
Style := Style and not BS_DEFPUSHBUTTON;
{$ENDIF}
{$endif wince}
end
else
if Index = 27 then
F.fCancelBtnCtl := C;
end;
end;
{$IFDEF F_P}
//[function TControl.GetDefaultBtn]
function TControl.GetDefaultBtn(const Index: Integer): Boolean;
begin
CASE Index OF
13: Result := fDefaultBtn;
27: Result := fCancelBtn;
END;
end;
{$ENDIF F_P}
//[function TControl.AllBtnReturnClick]
function TControl.AllBtnReturnClick: PControl;
{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
begin
// nothing: already implemented in WndProcBtnReturnClick
Result := @ Self;
end;
{$ELSE}
var F: PControl;
begin
SetDefaultBtn( 0, TRUE );
F := ParentForm;
if F <> nil then
F.fAllBtnReturnClick := TRUE;
Result := @ Self;
end;
{$ENDIF}
//[function WndProc_CNDrawItem]
function WndProc_CNDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
type PDrawAction = ^TDrawAction;
PDrawState = ^TDrawState;
var DI: PDrawItemStruct;
begin
Result := FALSE;
if Msg.message = CN_DRAWITEM then
begin
DI := Pointer( Msg.lParam );
if Assigned( Sender.OnDrawItem ) then
begin
if Sender.OnDrawItem( Sender, DI.hDC, DI.rcItem, DI.itemID,
PDrawAction( @ DI.itemAction )^,
PDrawState( @ DI.itemState )^ )
then Rslt := 1
else Rslt := 0;
Result := TRUE;
end
else Rslt := 0;
end;
end;
//[procedure TControl.SetOnDrawItem]
procedure TControl.SetOnDrawItem(const Value: TOnDrawItem);
begin
fOnDrawItem := Value;
if Parent <> nil then
Parent.AttachProc( @WndProc_DrawItem );
AttachProc( @WndProc_CNDrawItem );
end;
//[function WndProc_MeasureItem]
function WndProc_MeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
var MI: PMeasureItemStruct;
Control: PControl;
I: Integer;
begin
Result := FALSE;
if Msg.message = WM_MEASUREITEM then
begin
MI := Pointer( Msg.lParam );
for I := 0 to Sender.ChildCount - 1 do
begin
Control := Sender.Children[ I ];
if Control.Menu = MI.CtlID then
begin
if Assigned( Control.OnMeasureItem ) then
begin
MI.itemHeight := Control.OnMeasureItem( Control, MI.itemID );
if MI.itemHeight > 0 then
begin
Rslt := 1;
Result := TRUE;
end;
end;
break;
end;
end;
end;
end;
//[procedure TControl.SetOnMeasureItem]
procedure TControl.SetOnMeasureItem(const Value: TOnMeasureItem);
begin
fOnMeasureItem := Value;
if Parent <> nil then
Parent.AttachProc( @WndProc_MeasureItem );
end;
//[function TControl.GetItemData]
function TControl.GetItemData(Idx: Integer): DWORD;
begin
Result := 0;
if fCommandActions.aGetItemData <> 0 then
Result := Perform( fCommandActions.aGetItemData, Idx, 0 );
end;
//[procedure TControl.SetItemData]
procedure TControl.SetItemData(Idx: Integer; const Value: DWORD);
begin
if fCommandActions.aSetItemData <> 0 then
Perform( fCommandActions.aSetItemData, Idx, Value );
end;
//[function TControl.GetLVCurItem]
function TControl.GetLVCurItem: Integer;
begin
Result := Perform( LVM_GETNEXTITEM, -1, LVNI_SELECTED );
end;
//[procedure TControl.SetLVCurItem]
procedure TControl.SetLVCurItem(const Value: Integer);
begin
if (lvoMultiselect in LVOptions) or (Value <> LVCurItem ) then
LVItemState[ -1 ] := [ ];
if Value >= 0 then
LVItemState[ Value ] := [ lvisSelect, lvisFocus ];
end;
//[function TControl.LVNextItem]
function TControl.LVNextItem(IdxPrev: Integer; Attrs: DWORD): Integer;
begin
Result := Perform( LVM_GETNEXTITEM, IdxPrev, Attrs );
end;
//[function TControl.LVNextSelected]
function TControl.LVNextSelected(IdxPrev: Integer): Integer;
begin
Result := Perform( LVM_GETNEXTITEM, IdxPrev, LVNI_SELECTED );
end;
//[function TControl.GetLVFocusItem]
function TControl.GetLVFocusItem: Integer;
begin
Result := Perform( LVM_GETNEXTITEM, -1, LVNI_FOCUSED );
end;
//[procedure TControl.Close]
procedure TControl.Close;
begin
PostMessage( Handle, WM_CLOSE, 0, 0 );
end;
//[function WndProcMinimize]
function WndProcMinimize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Wnd: PControl;
begin
Result := FALSE;
if (Msg.message = WM_SYSCOMMAND) and ((Msg.wParam and $FFF0) = SC_MINIMIZE)then
begin
if Applet <> nil then
begin
Wnd := Applet.FMinimizeWnd;
if Wnd <> nil then
SetWindowPos( Applet.Handle, 0, Wnd.Left, Wnd.Top, Wnd.Width, 0,
SWP_NOZORDER or SWP_NOREDRAW);
end;
end;
end;
function WndProcRestore( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
CASE Msg.message OF
WM_SHOWWINDOW:
begin
case Msg.lParam of
SW_PARENTCLOSING:
begin
{$ifdef win32}
if IsIconic( Self_.fHandle ) then
Self_.fShowAction := SW_SHOWMINNOACTIVE
else
if IsZoomed( Self_.fHandle ) then
Self_.fShowAction := SW_SHOWMAXIMIZED
else
Self_.fShowAction := SW_SHOWNOACTIVATE;
{$endif win32}
end;
SW_PARENTOPENING:
begin
if Self_.fShowAction <> 0 then
begin
ShowWindow( Self_.fHandle, Self_.fShowAction );
Self_.fShowAction := 0;
end;
Rslt := 0;
end;
end;
end;
END;
end;
//[procedure TControl.MinimizeNormalAnimated]
procedure TControl.MinimizeNormalAnimated;
var App: PControl;
begin
App := Applet;
if App = nil then
App := @Self;
App.FMinimizeWnd := @Self;
App.AttachProc( @WndProcMinimize );
AttachProc( @WndProcRestore );
end;
//[procedure TCotrol.RestoreNormalMaximized]
procedure TControl.RestoreNormalMaximized;
begin
AttachProc( @WndProcRestore );
end;
{$ifndef wince}
//[function WndProcDropFiles]
function WndProcDropFiles( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var hDrop: THandle;
Pt: TPoint;
FList: KOLString;
I, N: Integer;
Buf: array[ 0..MAX_PATH ] of KOLChar;
begin
if Msg.message = WM_DROPFILES then
if Assigned( Sender.FOnDropFiles ) then
begin
hDrop := Msg.wParam;
DragQueryPoint( hDrop, Pt );
N := DragQueryFile( hDrop, $FFFFffff, nil, 0 );
FList := '';
for I := 0 to N-1 do
begin
if FList <> '' then
FList := FList + #13;
DragQueryFile( hDrop, I, Buf, Sizeof( Buf ) );
FList := FList + Buf;
end;
DragFinish( hDrop );
Sender.FOnDropFiles( Sender, FList, Pt );
Rslt := 0;
Result := TRUE;
Exit;
end;
Result := FALSE;
end;
{$endif wince}
//[procedure TControl.SetOnDropFiles]
procedure TControl.SetOnDropFiles(const Value: TOnDropFiles);
begin
FOnDropFiles := Value;
{$ifndef wince}
AttachProc( @WndProcDropFiles );
DragAcceptFiles( GetWindowHandle, Assigned( Value ) );
{$endif wince}
end;
//[function WndProcShowHide]
function WndProcShowHide( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var IsVisible: Boolean;
begin
if Msg.message = WM_SHOWWINDOW then
if Msg.hwnd = Sender.Handle then
begin
IsVisible := IsWindowVisible( Sender.Handle );
if LongBool( Msg.wParam ) then
begin
Sender.fVisible := TRUE;
if not IsVisible then
if Assigned( Sender.FOnShow ) then
Sender.FOnShow( Sender );
end
else
begin
Sender.fVisible := FALSE;
if IsVisible then
if Assigned( Sender.FOnHide ) then
Sender.FOnHide( Sender );
end;
end;
Result := FALSE;
end;
//[procedure TControl.SetOnHide]
procedure TControl.SetOnHide(const Value: TOnEvent);
begin
FOnHide := Value;
AttachProc( WndProcShowHide );
end;
//[procedure TControl.SetOnShow]
procedure TControl.SetOnShow(const Value: TOnEvent);
begin
FOnShow := Value;
AttachProc( WndProcShowHide );
end;
//[function TControl.BringToFront]
function TControl.BringToFront: PControl;
begin
SetWindowPos( GetWindowHandle, HWND_TOP, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or
SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_SHOWWINDOW );
Result := @Self;
end;
//[function TControl.SendToBack]
function TControl.SendToBack: PControl;
begin
SetWindowPos( GetWindowHandle, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or
SWP_NOACTIVATE or SWP_NOOWNERZORDER );
Result := @Self;
end;
//[procedure TControl.DragStart]
procedure TControl.DragStart;
begin
PostMessage( GetWindowHandle, WM_SYSCOMMAND, $F012, 0 );
end;
//[function WndProcDragWindow]
function WndProcDragWindow( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var P: TPoint;
begin
if Msg.message = WM_MOUSEMOVE then
begin
if Sender.FDragging then
begin
GetCursorPos( P );
P.x := P.x - Sender.fMouseStartPos.x + Sender.fDragStartPos.x;
P.y := P.y - Sender.fMouseStartPos.y + Sender.fDragStartPos.y;
Sender.Position := P;
end;
end;
Result := FALSE;
end;
//[procedure TControl.DragStartEx]
procedure TControl.DragStartEx;
var StartBounds: TRect;
begin
{$IFNDEF SMALLEST_CODE}
if fDragging then Exit;
{$ENDIF}
GetCursorPos( fMouseStartPos );
StartBounds := BoundsRect;
fDragStartPos.x := StartBounds.Left;
fDragStartPos.y := StartBounds.Top;
SetCapture( GetWindowHandle );
fDragging := TRUE;
AttachProc( WndProcDragWindow );
end;
//[procedure TControl.DragStopEx]
procedure TControl.DragStopEx;
begin
if FDragging then
begin
ReleaseCapture;
FDragging := FALSE;
end;
end;
//[function CallDragCallBack]
function CallDragCallBack( Sender: PControl; var Stop: Boolean ): Boolean;
var P: TPoint;
Shape, ShapeWas: Integer;
begin
Sender.AttachProc( WndProcSetCursor );
GetCursorPos( P );
Shape := LoadCursor( 0, IDC_HAND );
ShapeWas := Shape;
Result := Sender.fDragCallback( Sender, P.x, P.y, Shape, Stop );
if not Stop then
begin
if not Result then
if Shape = ShapeWas then
Shape := LoadCursor( 0, IDC_NO );
ScreenCursor := Shape;
end
else
begin
ScreenCursor := 0;
Shape := Sender.fCursor;
end;
Windows.SetCursor( Shape );
end;
//[function WndProcDrag]
function WndProcDrag( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Stop: Boolean;
begin
if Sender.fDragging then
begin
Stop := FALSE;
case Msg.message of
WM_MOUSEMOVE:
CallDragCallBack( Sender, Stop );
WM_LBUTTONUP, WM_RBUTTONUP:
begin
Stop := TRUE;
CallDragCallBack( Sender, Stop );
end;
else
begin
Result := FALSE;
Exit;
end;
end;
if Stop then
begin
ReleaseCapture;
Sender.fDragging := FALSE;
end
else
begin
Result := TRUE;
exit;
end;
end;
Result := FALSE;
end;
//[procedure TControl.DragItem]
procedure TControl.DragItem(OnDrag: TOnDrag);
begin
fDragCallback := OnDrag;
fDragging := TRUE;
SetCapture( GetWindowHandle );
AttachProc( WndProcDrag );
end;
{-}
{$IFDEF USE_CONSTRUCTORS} //****************************************************//
//
//[constructor TControl.CreateWindowed]
constructor TControl.CreateWindowed(AParent: PControl; AClassName: PKOLChar; //
ACtl3D: Boolean); //
begin //
CreateParented( AParent ); //
fOnDynHandlers := WndProcDummy; //
fWndProcKeybd := WndProcDummy; //
fWndProcResizeFlicks := WndProcDummy; //
fCommandActions.aClear := ClearText; //
//fWindowed := True; // is set in TControl.Init
fControlClassName := AClassName; //
//
fControlClick := DummyObjProc; //
//
fColor := clBtnFace; //
fTextColor := clWindowText; //
fMargin := 2; //
fCtl3D := True; //
fCtl3Dchild := True; //
if AParent <> nil then //
begin //
fWndProcResizeFlicks := AParent.fWndProcResizeFlicks; //
fGotoControl := AParent.fGotoControl; //
fDoubleBuffered := AParent.fDoubleBuffered; //
fTransparent := AParent.fTransparent; //
fCtl3Dchild := AParent.fCtl3Dchild; //
if AParent.fCtl3Dchild then //
fCtl3D := ACtl3D //
else //
fCtl3D := False; //
fMargin := AParent.fMargin; //
with fBoundsRect do //
begin //
Left := AParent.fMargin + AParent.fClientLeft; //
Top := AParent.fMargin + AParent.fClientTop; //
Right := Left + 64; //
Bottom := Top + 64; //
end; //
fTextColor := AParent.fTextColor; //
fFont := fFont.Assign( AParent.fFont ); //
if fFont <> nil then //
begin //
fFont.fOnChange := FontChanged; //
FontChanged( fFont ); //
end; //
fColor := AParent.fColor; //
fBrush := fBrush.Assign( AParent.fBrush ); //
if fBrush <> nil then //
begin //
fBrush.fOnChange := BrushChanged; //
BrushChanged( fBrush ); //
end; //
end; //
end; //
//
//[constructor TControl.CreateApplet]
constructor TControl.CreateApplet(const ACaption: String); //
begin //
AppButtonUsed := True; //
CreateWindowed( nil, 'App', TRUE ); //
FIsApplet := TRUE; //
fStyle := WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX //
or WS_CAPTION; //
fExStyle := WS_EX_APPWINDOW; //
FCreateWndExt := CreateAppButton; //
AttachProc( WndProcApp ); //
Caption := ACaption; //
end; //
//
//[constructor TControl.CreateForm]
constructor TControl.CreateForm(AParent: PControl; const ACaption: String); //
begin //
CreateWindowed( AParent, 'Form', TRUE ); //
AttachProc( WndProcForm ); //
AttachProc( WndProcDoEraseBkgnd ); //
Caption := ACaption; //
end; //
//
//[constructor TControl.CreateControl]
constructor TControl.CreateControl(AParent: PControl; AClassName: PChar; //
AStyle: DWORD; ACtl3D: Boolean; Actions: PCommandActions); //
var Form: PControl; //
begin //
CreateWindowed( AParent, AClassName, ACtl3D ); //
if Actions <> nil then //
fCommandActions := Actions^; //
fIsControl := True; //
fStyle := AStyle or WS_CLIPSIBLINGS or WS_CLIPCHILDREN; //
fVisible := (Style and WS_VISIBLE) <> 0; //
fTabstop := (Style and WS_TABSTOP) <> 0; //
if (AParent <> nil) then //
begin //
Inc( AParent.ParentForm.fTabOrder ); //
fTabOrder := AParent.ParentForm.fTabOrder; //
end; //
fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ]; //
if fCtl3D then //
begin //
fStyle := fStyle and not WS_BORDER; //
fExStyle := fExStyle or WS_EX_CLIENTEDGE; //
end; //
if (Style and WS_TABSTOP) <> 0 then //
begin //
Form := ParentForm; //
if Form <> nil then //
if Form.FCurrentControl = nil then //
Form.FCurrentControl := @Self; //
end; //
//fCreateParamsExt := CreateParams2; //
fMenu := CtlIdCount; //
Inc( CtlIdCount ); //
AttachProc( WndProcCtrl ); //
end; //
//
//[constructor TControl.CreateButton]
constructor TControl.CreateButton(AParent: PControl; //
const ACaption: String); //
begin //
CreateControl( AParent, 'BUTTON', //
WS_VISIBLE or WS_CHILD or //
BS_PUSHLIKE or WS_TABSTOP, False, @ButtonActions ); //
with fBoundsRect do //
Bottom := Top + 22; //
fTextAlign := taCenter; //
Caption := ACaption; //
end; //
//
//[constructor TControl.CreateBitBtn]
constructor TControl.CreateBitBtn(AParent: PControl; //
const ACaption: String; AOptions: TBitBtnOptions; ALayout: TGlyphLayout; //
AGlyphBitmap: HBitmap; AGlyphCount: Integer); //
var //
B: TBitmapInfo; //
W, H: Integer; //
begin //
CreateControl( AParent, 'BUTTON', WS_VISIBLE or WS_CHILD or //
WS_TABSTOP or BS_OWNERDRAW, False, @ButtonActions ); //
fBitBtnOptions := AOptions; //
fGlyphLayout := ALayout; //
fGlyphBitmap := AGlyphBitmap; //
with fBoundsRect do //
begin //
Bottom := Top + 22; //
W := 0; H := 0; //
if AGlyphBitmap <> 0 then //
begin //
if bboImageList in AOptions then //
ImageList_GetIconSize( AGlyphBitmap, W, H ) //
else //
begin //
if GetObject( AGlyphBitmap, Sizeof(B), @B ) > 0 then //
begin //
W := B.bmiHeader.biWidth; //
H := B.bmiHeader.biHeight; //
if AGlyphCount = 0 then //
AGlyphCount := W div H; //
if AGlyphCount > 1 then //
W := W div AGlyphCount; //
end; //
end; //
if W > 0 then //
if ACaption = '' then //
Right := Left + W //
else //
Right := Right + W; //
if H > 0 then //
Bottom := Top + H; //
if not ( bboNoBorder in AOptions ) then //
begin //
if W > 0 then //
Inc( Right, 2 ); //
if H > 0 then //
Inc( Bottom, 2 ); //
end; //
end; //
fGlyphWidth := W; //
fGlyphHeight := H; //
end; //
fGlyphCount := AGlyphCount; //
if AParent <> nil then //
AParent.AttachProc( WndProc_DrawItem ); //
AttachProc( WndProcBitBtn ); //
fTextAlign := taCenter; //
Caption := ACaption; //
end; //
//
//[constructor TControl.CreateLabel]
constructor TControl.CreateLabel(AParent: PControl; //
const ACaption: String); //
begin //
CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or //
SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, //
False, @LabelActions ); //
fIsStaticControl := 1; //
fSizeRedraw := True; //
fBoundsRect.Bottom := fBoundsRect.Top + 22; //
Caption := ACaption; //
end; //
//
//[constructor TControl.CreateWordWrapLabel]
constructor TControl.CreateWordWrapLabel(AParent: PControl; //
const ACaption: String); //
begin //
CreateLabel( AParent, ACaption ); //
fBoundsRect.Bottom := fBoundsRect.Top + 44; //
fStyle := fStyle and not SS_LEFTNOWORDWRAP; //
end; //
//
//[constructor TControl.CreateLabelEffect]
constructor TControl.CreateLabelEffect(AParent: PControl; ACaption: String; //
AShadowDeep: Integer); //
begin //
CreateLabel( AParent, ACaption ); //
fIsStaticControl := 0; //
AttachProc( WndProcLabelEffect ); //
fTextAlign := taCenter; //
fTextColor := clBtnShadow; //
fShadowDeep := AShadowDeep; //
fIgnoreWndCaption := True; //
with fBoundsRect do //
begin //
Bottom := Top + 40; //
end; //
end; //
//
//[constructor TControl.CreatePaintBox]
constructor TControl.CreatePaintBox(AParent: PControl); //
begin //
CreateLabel( AParent, '' ); //
with fBoundsRect do //
begin //
Right := Left + 40; //
Bottom := Top + 40; //
end; //
end; //
//
{$IFDEF ASM_VERSION} //
//[constructor TControl.CreateGradientPanel]
constructor TControl.CreateGradientPanel(AParent: PControl; AColor1, //
AColor2: TColor); //
asm //cmd //opd //
XOR EDX, EDX //
PUSH EDX //
CALL CreateLabel //
MOV ECX, AColor1 //
MOV [EAX].fColor1, ECX //
MOV ECX, AColor2 //
MOV [EAX].fColor2, ECX //
MOV EDX, [EAX].fBoundsRect.Left //
ADD EDX, 40 //
MOV [EAX].fBoundsRect.Right, EDX //
MOV EDX, [EAX].fBoundsRect.Top //
ADD EDX, 40 //
MOV [EAX].fBoundsRect.Bottom, EDX //
PUSH EAX //
MOV EDX, offset[ WndProcGradient ] //
CALL AttachProc //
POP EAX //
end; //
{$ELSE ASM_VERSION} //Pascal //
constructor TControl.CreateGradientPanel(AParent: PControl; AColor1, //
AColor2: TColor); //
begin //
CreateLabel( AParent, '' ); //
AttachProc( WndProcGradient ); //
fColor2 := AColor2; //
fColor1 := AColor1; //
with fBoundsRect do //
begin //
Right := Left + 40; //
Bottom := Top + 40; //
end; //
end; //
{$ENDIF ASM_VERSION} //
//
//[constructor TControl.CreateGradientPanelEx]
constructor TControl.CreateGradientPanelEx(AParent: PControl; AColor1, //
AColor2: TColor; AStyle: TGradientStyle; ALayout: TGradientLayout); //
begin //
CreateLabel( AParent, '' ); //
AttachProc( WndProcGradientEx ); //
fColor2 := AColor2; //
fColor1 := AColor1; //
fGradientStyle := AStyle; //
fGradientLayout := ALayout; //
with fBoundsRect do //
begin //
Right := Left + 40; //
Bottom := Top + 40; //
end; //
end; //
//
//[constructor TControl.CreateGroupbox]
constructor TControl.CreateGroupbox(AParent: PControl; //
const ACaption: String); //
begin //
CreateButton( AParent, ACaption ); //
with fBoundsRect do //
begin //
Right := Left + 100; //
Bottom := Top + 100; //
end; //
fStyle := WS_VISIBLE or WS_CHILD or BS_GROUPBOX or WS_TABSTOP; //
fClientTop := 22; //
fClientLeft := 2; //
fClientBottom := 2; //
fClientRight := 2; //
fTabstop := False; //
end; //
//
//[constructor TControl.CreateCheckbox]
constructor TControl.CreateCheckbox(AParent: PControl; //
const ACaption: String); //
begin //
CreateButton( AParent, ACaption ); //
with fBoundsRect do //
begin //
Right := Left + 72; //
end; //
fStyle := WS_VISIBLE or WS_CHILD or //
BS_AUTOCHECKBOX or WS_TABSTOP; //
end; //
//
//[constructor TControl.CreateRadiobox]
constructor TControl.CreateRadiobox(AParent: PControl; //
const ACaption: String); //
begin //
CreateCheckbox( AParent, ACaption ); //
fStyle := WS_VISIBLE or WS_CHILD or //
BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP; //
fControlClick := ClickRadio; //
if AParent <> nil then //
begin //
AParent.fRadioLast := fMenu; //
if AParent.fRadio1st = 0 then //
begin //
AParent.fRadio1st := fMenu; //
SetRadioChecked; //
end; //
end; //
end; //
//
//[constructor TControl.CreateEditbox]
constructor TControl.CreateEditbox(AParent: PControl; //
AOptions: TEditOptions); //
var Flags: Integer; //
begin //
Flags := MakeFlags( @AOptions, EditFlags ); //
if not(eoMultiline in AOptions) then //
Flags := Flags and not(WS_HSCROLL or WS_VSCROLL); //
CreateControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP //
or WS_BORDER or Flags, True, @EditActions ); //
//YS fCursor := LoadCursor( 0, IDC_IBEAM ); // //YS
with fBoundsRect do //
begin //
Right := Left + 100; //
Bottom := Top + 22; //
if eoMultiline in AOptions then //
begin //
Right := Right + 100; //
Bottom := Top + 200; //
end; //
end; //
fColor := clWindow; //
fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ]; //
if eoMultiline in AOptions then //
fLookTabKeys := [ tkTab ]; //
if eoWantTab in AOptions then //
fLookTabKeys := fLookTabKeys - [ tkTab ]; //
end; //
//
//[constructor TControl.CreatePanel]
constructor TControl.CreatePanel(AParent: PControl; AStyle: TEdgeStyle); //
const Edgestyles: array[ TEdgeStyle ] of DWORD = ( WS_DLGFRAME, SS_SUNKEN, 0 ); //
begin //
CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or //
SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, False, //
@LabelActions ); //
with fBoundsRect do //
begin //
Right := Left + 100; //
Bottom := Top + 100; //
end; //
Style := Style or Edgestyles[ AStyle ]; //
ExStyle := ExStyle or WS_EX_CONTROLPARENT; //
end; //
//
//[constructor TControl.CreateSplitter]
constructor TControl.CreateSplitter(AParent: PControl; AMinSizePrev, //
AMinSizeNext: Integer; EdgeStyle: TEdgeStyle); //
var PrevCtrl: PControl; //
Sz0: Integer; //
begin //
CreatePanel( AParent, EdgeStyle ); //
fSplitMinSize1 := AMinSizePrev; //
fSplitMinSize2 := AMinSizeNext; //
Sz0 := 4; //
with fBoundsRect do //
begin //
Right := Left + Sz0; //
Bottom := Top + Sz0; //
end; //
if AParent <> nil then //
begin //
if AParent.fChildren.fCount > 1 then //
begin //
PrevCtrl := AParent.fChildren.fItems[ AParent.fChildren.fCount - 2 ]; //
case PrevCtrl.FAlign of //
caLeft, caRight: //
begin //
fCursor := LoadCursor( 0, IDC_SIZEWE ); //
end; //
caTop, caBottom: //
begin //
fCursor := LoadCursor( 0, IDC_SIZENS ); //
end; //
end; //
Align := PrevCtrl.FAlign; //
end; //
end; //
AttachProc( WndProcSplitter ); //
end; //
//
//[constructor TControl.CreateListbox]
constructor TControl.CreateListbox(AParent: PControl; //
AOptions: TListOptions); //
var Flags: Integer; //
begin //
Flags := MakeFlags( @AOptions, ListFlags ); //
CreateControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP //
or WS_BORDER or WS_VSCROLL //
or LBS_NOTIFY or Flags, True, @ListActions ); //
with fBoundsRect do //
begin //
Right := Right + 100; //
Bottom := Top + 200; //
end; //
fColor := clWindow; //
fLookTabKeys := [ tkTab, tkLeftRight ]; //
end; //
//
//[constructor TControl.CreateCombobox]
constructor TControl.CreateCombobox(AParent: PControl; //
AOptions: TComboOptions); //
var Flags: Integer; //
begin //
Flags := MakeFlags( @AOptions, ComboFlags ); //
CreateControl( AParent, 'COMBOBOX', //
WS_VISIBLE or WS_CHILD or WS_VSCROLL or //
CBS_DROPDOWN or CBS_HASSTRINGS or WS_TABSTOP or Flags, //
True, @ComboActions ); //
fCreateWndExt := CreateComboboxWnd; //
fDropDownProc := ComboboxDropDown; //
fClsStyle := fClsStyle or CS_DBLCLKS; //
with fBoundsRect do //
begin //
Right := Left + 100; //
Bottom := Top + 22; //
end; //
fColor := clWindow; //
fLookTabKeys := [ tkTab ]; //
if coReadOnly in AOptions then //
fLookTabKeys := [ tkTab, tkLeftRight ]; //
end; //
//
//[constructor TControl.CreateCommonControl]
constructor TControl.CreateCommonControl(AParent: PControl; //
AClassName: PChar; AStyle: DWORD; ACtl3D: Boolean; //
Actions: PCommandActions); //
begin //
{*************} DoInitCommonControls( ICC_WIN95_CLASSES ); //
CreateControl( AParent, AClassName, AStyle, ACtl3D, Actions ); //
fIsCommonControl := True; //
if AParent <> nil then //
begin //
AttachProc( WndProcParentResize ); //
AParent.AttachProc( WndProcResize ); //
AttachProc( WndProcCommonNotify ); //
AParent.AttachProc( WndProcNotify ); //
end; //
end; //
//
//[constructor TControl.CreateRichEdit1]
constructor TControl.CreateRichEdit1(AParent: PControl; //
AOptions: TEditOptions); //
var Flags, I: Integer; //
begin //
if FRichEditModule = 0 then //
begin //
for I := 0 to High( RichEditLibnames ) do //
begin //
FRichEditModule := LoadLibrary( RichEditLibnames[ I ] ); //
if FRichEditModule > HINSTANCE_ERROR then break; //
RichEditClass := RichEditClasses[ I ]; //
end; //
if FRichEditModule <= HINSTANCE_ERROR then //
FRichEditModule := 0; //
end; //
Flags := MakeFlags( @AOptions, RichEditFlags ); //
CreateCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD //
or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags, //
True, @RichEditActions ); //
//
AttachProc( WndProcRichEditNotify ); //
fDoubleBuffered := False; //
fCannotDoubleBuf := True; //
with fBoundsRect do //
begin //
Right := Right + 100; //
Bottom := Top + 200; //
end; //
fColor := clWindow; //
fLookTabKeys := [ tkTab ]; //
if eoWantTab in AOptions then //
fLookTabKeys := [ ]; //
Perform( EM_SETEVENTMASK, 0, //
ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or //
ENM_PROTECTED or $04000000 {ENM_LINK} ); //
Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(fColor)); //
end; //
//
//
//[constructor TControl.CreateRichEdit]
constructor TControl.CreateRichEdit(AParent: PControl; //
AOptions: TEditOptions); //
var OldRichEditClass, OldRichEditLib: PChar; //
begin //
if OleInit then //
begin //
OldRichEditClass := RichEditClass; //
OldRichEditLib := RichEditLib; //
CreateRichEdit1( AParent, AOptions ); //
fCharFmtDeltaSz := 24; //
fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat ); //
RichEditClass := OldRichEditClass; //
RichEditLib := OldRichEditLib; //
end //
else //
CreateRichEdit1( AParent, AOptions ); //
end; //
//
//[constructor TControl.CreateProgressbar]
constructor TControl.CreateProgressbar(AParent: PControl); //
const ProgressBarFlags: array[ TProgressbarOption ] of Integer = //
(PBS_VERTICAL, PBS_SMOOTH ); //
begin //
CreateCommonControl( AParent, PROGRESS_CLASS, //
WS_CHILD or WS_VISIBLE, True, nil ); //
with fBoundsRect do //
begin //
Right := Left + 300; //
Bottom := Top + 20; //
end; //
fMenu := 0; //
fTextColor := clHighlight; //
end; //
//
//[constructor TControl.CreateProgressbarEx]
constructor TControl.CreateProgressbarEx(AParent: PControl; //
AOptions: TProgressbarOptions); //
const ProgressBarFlags: array[ TProgressbarOption ] of Integer = //
(PBS_VERTICAL, PBS_SMOOTH ); //
begin //
CreateProgressbar( AParent ); //
fStyle := fStyle or DWORD( MakeFlags( @AOptions, ProgressBarFlags ) ); //
end; //
//
//[constructor TControl.CreateListView]
constructor TControl.CreateListView(AParent: PControl; //
AStyle: TListViewStyle; AOptions: TListViewOptions; AImageListSmall, //
AImageListNormal, AImageListState: PImageList); //
begin //
CreateCommonControl( AParent, WC_LISTVIEW, ListViewStyles[ AStyle ] or //
LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP, //
True, @ListViewActions ); //
fLVOptions := AOptions; //
fLVStyle := AStyle; //
fCreateWndExt := ApplyImageLists2ListView; //
with fBoundsRect do //
begin //
Right := Left + 200; //
Bottom := Top + 150; //
end; //
ImageListSmall := AImageListSmall; //
ImageListNormal := AImageListNormal; //
ImageListState := AImageListState; //
fLVTextBkColor := clWindow; //
fLookTabKeys := [ tkTab ]; //
end; //
//
//[constructor TControl.CreateTreeView]
constructor TControl.CreateTreeView(AParent: PControl; //
AOptions: TTreeViewOptions; AImgListNormal, AImgListState: PImageList); //
var Flags: Integer; //
begin //
Flags := MakeFlags( @AOptions, TreeViewFlags ); //
CreateCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or //
WS_CHILD or WS_TABSTOP, True, @TreeViewActions ); //
fCreateWndExt := ApplyImageLists2Control; //
fColor := clWindow; //
AttachProc( WndProcTreeView ); //
with fBoundsRect do //
begin //
Right := Left + 150; //
Bottom := Top + 200; //
end; //
ImageListNormal := AImgListNormal; //
ImageListState := AImgListState; //
fLookTabKeys := [ tkTab ]; //
end; //
//
//[constructor TControl.CreateTabControl]
constructor TControl.CreateTabControl(AParent: PControl; ATabs: array of String;//
AOptions: TTabControlOptions; //
AImgList: PImageList; AImgList1stIdx: Integer); //
var I, II : Integer; //
Flags: Integer; //
begin //
Flags := MakeFlags( @AOptions, TabControlFlags ); //
if tcoFocusTabs in AOptions then //
Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN); //
CreateCommonControl( AParent, WC_TABCONTROL, //
Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or //
WS_VISIBLE), True, @TabControlActions ); //
if not( tcoBorder in AOptions ) then //
fExStyle := fExStyle and not WS_EX_CLIENTEDGE; //
AttachProc( WndProcTabControl ); //
with fBoundsRect do //
begin //
Right := Left + 100; //
Bottom := Top + 100; //
end; //
if AImgList <> nil then //
Perform( TCM_SETIMAGELIST, 0, AImgList.Handle ); //
II := AImgList1stIdx; //
for I := 0 to High( ATabs ) do //
begin //
TC_Insert( I, ATabs[ I ], II ); //
Inc( II ); //
end; //
fLookTabKeys := [ tkTab ]; //
end; //
//
//[constructor TControl.CreateToolbar]
constructor TControl.CreateToolbar(AParent: PControl; //
AAlign: TControlAlign; AOptions: TToolbarOptions; ABitmap: HBitmap; //
AButtons: array of PChar; ABtnImgIdxArray: array of Integer); //
var Flags: DWORD; //
begin //
if not( tboTextBottom in AOptions ) then //
AOptions := AOptions + [ tboTextRight ]; //
if tboTextRight in AOptions then //
AOptions := AOptions - [ tboTextBottom ]; //
Flags := MakeFlags( @AOptions, ToolbarOptions ); //
CreateCommonControl( AParent, TOOLBARCLASSNAME, ToolbarAligns[ Align ] or //
WS_CHILD or WS_VISIBLE {or WS_TABSTOP} //
or TBSTYLE_TOOLTIPS or Flags, //
(not (Align in [caNone])) and //
not (tboNoDivider in AOptions), nil ); //
fCommandActions.aClear := ClearToolbar; //
fCommandActions.aGetCount := TB_BUTTONCOUNT; //
with fBoundsRect do //
begin //
if AAlign in [ caNone ] then //
begin //
Bottom := Top + 26; //
Right := Left + 1000; //
end //
else //
begin //
Left := 0; Right := 0; //
Top := 0; Bottom := 0; //
end; //
end; //
Perform(TB_SETEXTENDEDSTYLE, 0, Perform(TB_GETEXTENDEDSTYLE, 0, 0) or //
TBSTYLE_EX_DRAWDDARROWS); //
//
AttachProc( WndProcToolbarCtrl ); //
Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 ); //
Perform( TB_SETINDENT, fMargin, 0 ); //
with fBoundsRect do //
begin //
if AAlign in [ caLeft, caRight ] then //
Right := Left + 24 //
else if not (AAlign in [caNone]) then //
Bottom := Top + 22; //
end; //
if ABitmap <> 0 then //
TBAddBitmap( ABitmap ); //
TBAddButtons( AButtons, ABtnImgIdxArray ); //
Perform( WM_SIZE, 0, 0 ); //
end; //
//
//[constructor TImageList.CreateImageList]
constructor TImageList.CreateImageList(POwner: Pointer); //
var AOwner: PControl; //
begin //
{*************} DoInitCommonControls( ICC_WIN95_CLASSES ); //
Create; //
FAllocBy := 1; //
FMasked := True; //
if POwner = nil then exit; //
FBkColor := TColor( CLR_NONE );
//ImageList_SetBkColor( FHandle, CLR_NONE );
//
AOwner := POwner; //
FControl := AOwner; //
fNext := PImageList( AOwner.fImageList ); //
if AOwner.fImageList <> nil then //
PImageList( AOwner.fImageList ).fPrev := @Self; //
AOwner.fImageList := @Self; //
end; //
//
//[constructor TThread.ThreadCreate]
constructor TThread.ThreadCreate; //
begin //
IsMultiThread := True; //
Create; //
FSuspended := True; //
FHandle := CreateThread( nil, // no security //
0, // the same stack size //
@ThreadFunc, // thread entry point //
@Self, // parameter to pass to ThreadFunc //
CREATE_SUSPENDED, // always SUSPENDED //
FThreadID ); // receive thread ID //
end; //
//
//[constructor TThread.ThreadCreateEx]
constructor TThread.ThreadCreateEx( const Proc: TOnThreadExecute ); //
begin //
ThreadCreate; //
OnExecute := Proc; //
Resume; //
end; //
//
{$ENDIF USE_CONSTRUCTORS} //****************************************************//
{+}
//[procedure InvalidateExW]
procedure InvalidateExW( Wnd: HWnd );
begin
InvalidateRect( Wnd, nil, TRUE );
Wnd := GetWindow( Wnd, GW_CHILD );
while Wnd <> 0 do
begin
InvalidateExW( Wnd );
Wnd := GetWindow( Wnd, GW_HWNDNEXT );
end;
end;
//[procedure TControl.InvalidateEx]
procedure TControl.InvalidateEx;
begin
if fHandle = 0 then Exit;
InvalidateExW( fHandle );
end;
//[procedure InvalidateNCW]
procedure InvalidateNCW( Wnd: HWnd; Recursive: Boolean );
begin
SendMessage( Wnd, WM_NCPAINT, 1, 0 );
if not Recursive then Exit;
Wnd := GetWindow( Wnd, GW_CHILD );
while Wnd <> 0 do
begin
InvalidateNCW( Wnd, Recursive );
Wnd := GetWindow( Wnd, GW_HWNDNEXT );
end;
end;
//[procedure TControl.InvalidateNC]
procedure TControl.InvalidateNC(Recursive: Boolean);
begin
if fHandle = 0 then Exit;
InvalidateNCW( fHandle, Recursive );
end;
//[procedure TControl.SetClientMargin]
procedure TControl.SetClientMargin(const Index, Value: Integer);
begin
case Index of
1: fClientTop := Value;
2: fClientBottom := Value;
3: fClientLeft := Value;
4: fClientRight := Value;
end;
{$IFNDEF OLD_ALIGN}include(fAligning,oaFromSelf);{$ENDIF}//???
Global_Align( @Self );
end;
{$IFDEF F_P}
//[function TControl.GetClientMargin]
function TControl.GetClientMargin(const Index: Integer): Integer;
begin
CASE Index OF
1: Result := fClientTop;
2: Result := fClientBottom;
3: Result := fClientLeft;
4: Result := fClientRight;
END;
end;
{$ENDIF F_P}
{------------------------------------------------------------------------------}
{ G R A P H C O N T R O L S }
{------------------------------------------------------------------------------}
type TGrayTextData = {$ifndef wince}packed{$endif} record
Ctl: PControl;
W, H: Integer;
Flags: DWORD;
end;
PGrayTextData = ^TGrayTextData;
function DrawTextGrayed( DC: HDC; lData, wData, cX, cY: Integer ): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
var GDT: PGrayTextData;
R: TRect;
begin
GDT := Pointer( lData );
R := MakeRect( 0, 0, cX, cY );
DrawFormattedText( GDT.Ctl, DC, R, GDT.Flags or $80000000 );
Result := TRUE;
end;
procedure DrawFormattedText( Ctl: PControl; DC: HDC; var R: TRect; Flags: DWORD {EditCtl: Boolean} );
var Fmt: DWORD;
OldFont: Integer;
OldBrush: Integer;
OldBk: Integer;
ParentHavingFont: PControl;
{$ifdef win32}
GTD: TGrayTextData;
{$endif win32}
dX, dY: Integer;
R1: TRect;
begin
Fmt := DT_EXPANDTABS or Flags and $7FFFFFFF;
if Ctl.WordWrap then
Fmt := Fmt or DT_WORDBREAK;
if Flags and DT_EDITCONTROL <> 0 then
Inc( R.Left, 4 );
ParentHavingFont := Ctl;
while (ParentHavingFont <> nil) and not Assigned( ParentHavingFont.FFont )
and not ParentHavingFont.IsForm do
ParentHavingFont := ParentHavingFont.Parent;
OldFont := 0;
if Assigned( ParentHavingFont ) then
begin
OldFont := SelectObject( DC, ParentHavingFont.Font.Handle );
SetTextColor( DC, ParentHavingFont.Font.FColorRGB );
end;
R1 := R;
Windows.{$IFDEF UNICODE_CTRLS}DrawTextW{$ELSE}DrawTextA{$ENDIF}( DC, PKOLChar( Ctl.Caption ), Length( Ctl.Caption ), R,
Fmt or DT_CALCRECT );
CASE Ctl.fTextAlign OF
taCenter:
dX := (R1.Right - R1.Left - (R.Right - R.Left)) div 2;
taRight:
dX := R1.Right - R.Right;
else
dX := 0;
END;
CASE Ctl.fVerticalAlign OF
vaCenter:
dY := (R1.Bottom - R1.Top - (R.Bottom - R.Top)) div 2;
vaBottom:
dY := R1.Bottom - R.Bottom;
else
dY := 0;
END;
OffsetRect( R, dX, dY );
if Ctl.fEnabled or (Flags and $80000000 <> 0) then
begin
OldBk := SetBkMode( DC, TRANSPARENT );
OldBrush := SelectObject( DC, GetStockObject( NULL_BRUSH ) );
Windows.{$IFDEF UNICODE_CTRLS}DrawTextW{$ELSE}DrawTextA{$ENDIF}( DC, PKOLChar( Ctl.Caption ), Length( Ctl.Caption ), R, Fmt );
SelectObject( DC, OldBrush );
SetBkMode( DC, OldBk );
end
else
begin
{$ifdef wince}
MsgOk('DrawFormattedText must be fixed!');
Halt(4); // FIXME
{$else}
GTD.Ctl := Ctl;
GTD.W := R.Right - R.Left;
GTD.H := R.Bottom - R.Top;
GTD.Flags := Flags;
Windows.DrawState( DC, GetStockObject( NULL_BRUSH ), @ DrawTextGrayed,
Integer( @ GTD ), Length( Ctl.fCaption ), R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
DST_COMPLEX or DSS_DISABLED );
{$endif wince}
end;
if Assigned( ParentHavingFont ) then
SelectObject( DC, OldFont );
end;
{$IFDEF USE_GRAPHCTLS}
{$IFDEF GRAPHCTL_XPSTYLES}
type TOpenThemeDataProc = function( Wnd: HWnd; pszClassList: PWideChar ): THandle;
{$ifdef wince}cdecl{$else}stdcall{$endif};
TDrawThemeBackground = function( Theme: THandle; DC: HDC; iPartId: Integer;
iStateId: Integer; Rect, ClipRect: PRect ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif};
TGetThemeBackgroundContentRect = function( Theme: THandle; DC: HDC;
iPartId, iStateId: Integer; Rect, ContentRect: PRect ):
Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
TDrawThemeText = function( Theme: THandle; DC: HDC; iPartId, iStateId: Integer;
pszText: PWideChar; iCharCount: Integer;
dwTextFlags, dwTextFlags2: DWORD; Rect: PRect ): Integer;
{$ifdef wince}cdecl{$else}stdcall{$endif};
TCloseThemeData = function( Theme: THandle ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
var fOpenThemeDataProc: TOpenThemeDataProc;
fDrawthemeBackground: TDrawThemeBackground;
fGetThemeBackgroundcontentRect: TGetThemeBackgroundContentRect;
fDrawThemeText: TDrawThemeText;
fCloseThemeData: TCloseThemeData;
uxtheme_lib: THandle;
function OpenThemeDataProc: TOpenThemeDataProc;
begin
Result := nil;
if Integer(uxtheme_lib) = -1 then Exit;
if uxtheme_lib = 0 then
uxtheme_lib := LoadLibrary( 'uxtheme' );
if uxtheme_lib = 0 then
begin
uxtheme_lib := DWORD( -1 );
Exit;
end;
fOpenThemeDataProc := GetProcAddress( uxtheme_lib, 'OpenThemeData' );
fDrawthemeBackground := GetProcAddress( uxtheme_lib, 'DrawThemeBackground' );
fGetThemeBackgroundcontentRect := GetProcAddress( uxtheme_lib, 'GetThemeBackgroundContentRect' );
fDrawThemeText := GetProcAddress( uxtheme_lib, 'DrawThemeText' );
fCloseThemeData := GetProcAddress( uxtheme_lib, 'CloseThemeData' );
if not Assigned( fOpenThemeDataProc ) or
not Assigned( fDrawThemeBackground ) or
not Assigned( fGetThemeBackgroundcontentRect ) or
not Assigned( fDrawThemeText ) or
not Assigned( fCloseThemeData ) then
begin
FreeLibrary( uxtheme_lib );
uxtheme_lib := DWORD( -1 );
fOpenThemeDataProc := nil;
fDrawThemeBackground := nil;
fGetThemeBackgroundcontentRect := nil;
fDrawThemeText := nil;
fCloseThemeData := nil;
end;
Result := fOpenThemeDataProc;
end;
procedure DrawFormattedTextXP( Theme: THandle; Ctl: PControl; DC: HDC;
var R: TRect; CtlType, CtlStates, Flags1, Flags2: Integer );
var OldFont: Integer;
OldBrush: Integer;
ParentHavingFont: PControl;
begin
ParentHavingFont := Ctl;
while (ParentHavingFont <> nil) and not Assigned( ParentHavingFont.FFont )
and not ParentHavingFont.IsForm do
ParentHavingFont := ParentHavingFont.Parent;
OldFont := 0;
if Assigned( ParentHavingFont ) then
OldFont := SelectObject( DC, ParentHavingFont.Font.Handle );
OldBrush := SelectObject( DC, GetStockObject( NULL_BRUSH ) );
fDrawThemeText( Theme, DC, CtlType, CtlStates, @ WideString( Ctl.fCaption )[ 1 ],
Length( Ctl.fCaption ), Flags1, Flags2, @ R );
SelectObject( DC, OldBrush );
if Assigned( ParentHavingFont ) then
SelectObject( DC, OldFont );
end;
{$ENDIF}
procedure PaintGraphicChildren( Self_, Sender: PControl; DC: HDC );
var i, sav: Integer;
C: PControl;
R: TRect;
rgn: HRgn;
begin
for i := Self_.ChildCount-1 downto 0 do
begin
C := Self_.Children[ i ];
if not C.Visible then continue;
R := C.BoundsRect;
if (C.Handle = 0) and not C.fWindowed and
Assigned( C.fPaintProc ) then
begin
sav := SaveDC( DC );
rgn := CreateRectRgnIndirect( R );
ExtSelectClipRgn( DC, rgn, RGN_AND );
SelectClipRgn( DC, rgn );
DeleteObject( rgn );
Free_And_Nil( C.fCanvas );
C.fCanvas := Self_.Canvas;
Self_.Canvas.Brush.Assign( Self_.Brush );
Self_.Canvas.Font.Assign( Self_.Font ); // не присваивается?
Self_.fCanvas.DeselectHandles; // не помогает???
if Assigned( C.OnPrepaint ) then
C.OnPrePaint( C, DC );
if Assigned( C.OnPaint ) then
C.OnPaint( C, DC )
else
C.fPaintProc( DC );
if Assigned( C.OnPostPaint ) then
C.OnPostPaint( C, DC );
C.fCanvas := nil;
Self_.Canvas.Brush.Assign( Self_.Brush );
Self_.Canvas.Font.Assign( Self_.Font );
RestoreDC( DC, sav );
ExcludeClipRect( DC, R.Left, R.Top, R.Right, R.Bottom );
end;
end;
if Self_.fIsGroupBox then
begin
Self_.fErasingBkgnd := TRUE;
R := Self_.BoundsRect;
OffsetRect( R, -R.Left, -R.Top );
Self_.Canvas.FillRect( R );
Self_.GroupBoxPaint( DC );
Self_.fErasingBkgnd := FALSE;
end
else
if Assigned( Self_.fOnPaint2 ) then
Self_.fOnPaint2( Self_, DC )
else
Self_.Canvas.FillRect( Self_.ClientRect );
end;
function WndProc_ParentOfGraphicCtl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var WasOnPaint: TOnPaint;
i: Integer;
C: PControl;
Pt: TPoint;
PF: PControl;
save_Paint2: TOnPaint;
begin
Result := FALSE;
if (Msg.message = WM_PAINT) {or (Msg.message = WM_PRINT)} then
begin
//if not Result then
begin
WasOnPaint := Self_.fOnPaint;
Self_.fOnPaint2 := Self_.fOnPaint;
Self_.fPaintMsg := Msg;
TMethod( Self_.fOnPaint ) := MakeMethod( Self_, @ PaintGraphicChildren );
save_Paint2 := Self_.fOnPaint2;
if not Assigned( Self_.fOnPaint2 ) then
Self_.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintClear ) );
i := Self_.fDynHandlers.fCount;
Self_.fDynHandlers.fCount := Self_.fDynHandlers.IndexOf( @ WndProc_ParentOfGraphicCtl );
Result := EnumDynHandlers( Self_, Msg, Rslt );
Self_.fDynHandlers.fCount := i;
//Self_.fOnPaint2 := save_Paint2;
if not Result then
{Result :=} WndProcPaint( Self_, Msg, Rslt );
Self_.fOnPaint := WasOnPaint;
end;
Result := TRUE;
end
else
if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= WM_MOUSELAST) then
begin
Pt.X := SmallInt( LoWord( Msg.lParam ) );
Pt.Y := SmallInt( HiWord( Msg.lParam ) );
for i := 0 to Self_.ChildCount-1 do
begin
if (i = 0) and (Self_.fPushedBtn <> nil) then
C := Self_.fPushedBtn
else
C := Self_.Children[ i ];
if (C = Self_.fPushedBtn) OR
C.fVisible and C.fEnabled and PtInRect( C.BoundsRect, Pt ) then
begin
if not C.fWindowed and
(C.fCursor <> 0) and (C.fCursor <> Self_.fCursor) and
(ScreenCursor = 0) then
begin
if Self_.fSaveCursor = 0 then
begin
Self_.fSaveCursor := Self_.fCursor;
if Self_.fCursor = 0 then
Self_.fSaveCursor := LoadCursor( 0, IDC_ARROW );
end;
Self_.Cursor := C.fCursor;
Windows.SetCursor( C.fCursor );
end;
{$IFDEF GRAPHCTL_HOTTRACK}
if not C.fWindowed and (Applet.fHotCtl <> C) then
begin
if Applet.fHotCtl <> nil then
begin
Applet.fHotCtl.fHot := FALSE;
if not Applet.fHotCtl.fWindowed then
begin
Applet.fHotCtl.Invalidate;
if Assigned( Applet.fHotCtl.OnMouseLeave ) then
Applet.fHotCtl.OnMouseLeave( Applet.fHotCtl );
end;
Applet.fHotCtl.RefDec;
end;
C.RefInc;
Applet.fHotCtl := C;
C.fHot := TRUE;
C.Invalidate;
Self_.fMouseLeaveProc := Self_.MouseLeaveFromParentOfGraphCtl;
ProvideMouseEnterLeave( Self_ );
if Assigned( C.OnMouseEnter ) then
C.OnMouseEnter( C );
end;
{$ENDIF GRAPHCTL_HOTTRACK}
if C.fWindowed then
begin
Msg.hwnd := C.fHandle;
Pt := Self_.Client2Screen( Pt );
Pt := C.Screen2Client( Pt );
Msg.lParam := Pt.Y shl 16 or (Pt.X and $FFFF);
end;
Rslt := C.WndProc( Msg );
if not C.fWindowed then
if Assigned( C.fGraphCtlMouseEvent ) then
C.fGraphCtlMouseEvent( Msg )
else
if (Msg.message = WM_LBUTTONDOWN) or
(Msg.message = WM_RBUTTONDOWN) or
(Msg.message = WM_MBUTTONDOWN) then
C.DoClick;
Result := TRUE;
Exit;
end;
end;
{$IFDEF GRAPHCTL_HOTTRACK}
Self_.MouseLeaveFromParentOfGraphCtl( Self_ );
{$ENDIF GRAPHCTL_HOTTRACK}
if Self_.fIsGroupBox and (
(Msg.message = WM_LBUTTONDOWN) or
(Msg.message = WM_LBUTTONDBLCLK) or
(Msg.message = WM_LBUTTONUP)
) then
begin
Self_.Invalidate;
end;
if Self_.fSaveCursor <> 0 then
begin
Self_.Cursor := Self_.fSaveCursor;
Self_.fSaveCursor := 0;
if ScreenCursor = 0 then
Windows.SetCursor( Self_.fCursor );
end;
end
else
if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
begin
if Self_.IsControl then
PF := Self_.ParentForm
else
PF := Self_;
if (PF.fCurrentControl <> nil) and not PF.fCurrentControl.fWindowed then
begin
if Assigned( PF.fCurrentControl.fKeyboardProcess ) and
PF.fCurrentControl.fKeyboardProcess( Msg, Rslt ) then
else
Rslt := PF.fCurrentControl.WndProc( Msg );
Result := TRUE;
end
else
begin
if Self_.fIsGroupBox and (Msg.wParam = WORD( ' ' )) and
(
(Msg.message = WM_KEYDOWN) or
(Msg.message = WM_SYSKEYDOWN) or
(Msg.message = WM_KEYUP) or
(Msg.message = WM_SYSKEYUP) or
(Msg.message = WM_CHAR) or
(Msg.message = WM_SYSCHAR)
) then
begin
Self_.Invalidate;
end;
end;
end
else
if Msg.message = CM_QUIT then
begin
C := Pointer( Msg.wParam );
C.Free;
end
else
if Msg.message = CM_FOCUSGRAPHCTL then
begin
C := Pointer( Msg.wParam );
PF := C.ParentForm;
if (PF.fCurrentControl <> nil) and (PF.fCurrentControl <> C) then
begin
PF.fCurrentControl.fFocused := FALSE;
PF.fCurrentControl.Invalidate;
end;
PF.fCurrentControl := C;
C.Parent.fCurrentControl := C;
C.Parent.fFocusHandle := C.Parent.fHandle;
C.fFocused := TRUE;
if Assigned( C.fOnEnter ) then
C.fOnEnter( C );
C.Invalidate;
C.fLeave := C.LeaveGraphButton;
C.RefDec;
end;
end;
function WndProc_FormHavingGraphCtl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Msg2: TMsg;
begin
Result := FALSE;
if Msg.message = WM_ACTIVATE then
begin
if Self_.fCurrentControl <> nil then
Self_.fCurrentControl.Invalidate;
end
else
if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
begin
if (Self_.fCurrentControl <> nil) and not Self_.fCurrentControl.fWindowed then
begin
if (Msg.message = WM_KEYDOWN) and ((Msg.wParam = 32) or (Msg.wParam = 13)) then
begin
if not PeekMessage( Msg2, Msg.hwnd, WM_CHAR, WM_CHAR, pm_noRemove ) or
(Msg2.wParam <> Msg.wParam) then
Msg.message := WM_CHAR;
end
else
if (Msg.message = WM_SYSKEYDOWN) and ((Msg.wParam = 32) or (Msg.wParam = 13)) then
begin
if not PeekMessage( Msg2, Msg.hwnd, WM_SYSCHAR, WM_SYSCHAR, pm_noRemove ) or
(Msg2.wParam <> Msg.wParam) then
Msg.message := WM_SYSCHAR;
end;
if Assigned( Self_.fCurrentControl.fKeyboardProcess ) and
Self_.fCurrentControl.fKeyboardProcess( Msg, Rslt ) then
else
Rslt := Self_.fCurrentControl.WndProc( Msg );
Result := TRUE;
end;
end;
end;
{$IFDEF GRAPHCTL_HOTTRACK}
procedure TControl.MouseLeaveFromParentOfGraphCtl(Sender: PObj);
var C: PControl;
Pt: TPoint;
begin
if AppletTerminated then Exit;
GetCursorPos( Pt );
Pt := Screen2Client( Pt );
if (Applet.fHotCtl <> nil) and (fChildren.IndexOf( Applet.fHotCtl ) >= 0) then
begin
C := Applet.fHotCtl;
if PtInRect( C.BoundsRect, Pt ) then Exit;
Applet.fHotCtl := nil;
C.fHot := FALSE;
if not C.fWindowed then
C.Invalidate;
if Assigned( C.OnMouseLeave ) then
C.OnMouseLeave( C );
C.RefDec;
end;
end;
{$ENDIF GRAPHCTL_HOTTRACK}
procedure NotifyGraphCtlAboutNewParent(Prnt, Chld: PControl);
begin
if (Chld <> nil) and (Prnt <> nil) then
begin
Prnt.AttachProc( WndProc_ParentOfGraphicCtl );
{if not Prnt.IsProcAttached( WndProc_ParentOfGraphicCtl ) then
begin
Prnt.fDynHandlers.Insert( 0, nil );
Prnt.fDynHandlers.Insert( 0, @ WndProc_ParentOfGraphicCtl );
end;}
end;
end;
function _NewGraphCtl( AParent: PControl; ATabStop: Boolean ): PControl;
begin
{-}
new( Result, Create );
{+}{++}(*Result := PControl.CreateParented( AParent );*){--}
Result.fDoInvalidate := Result.InvalidateNonWindowed;
Result.fWindowed := FALSE;
Result.fVisible := TRUE;
Result.fCreateVisible := TRUE;
Result.fIsControl := TRUE;
Result.fMenu := CtlIdCount;
Inc( CtlIdCount );
Result.fBitBtnOptions := [ bboFixed ]; // to return Checked = fChecked w/o window handle
Result.fIgnoreWndCaption := TRUE;
Result.fNotifyChild := @ NotifyGraphCtlAboutNewParent;
Result.fSizeRedraw := TRUE;
Result.fTabstop := ATabStop;
if ATabStop then
Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];
if AParent <> nil then
begin
Result.Parent := AParent;
Result.Border := AParent.Border;
//if not AParent.IsProcAttached( WndProc_ParentOfGraphicCtl ) then
begin
AParent.AttachProc( WndProc_ParentOfGraphicCtl );
//AParent.fDynHandlers.Insert( 0, nil );
//AParent.fDynHandlers.Insert( 0, @ WndProc_ParentOfGraphicCtl );
end;
if ATabStop then
begin
Inc( AParent.ParentForm.fTabOrder );
Result.fTabOrder := AParent.ParentForm.fTabOrder;
end;
if AParent.IsControl then
AParent.ParentForm.AttachProc( WndProc_FormHavingGraphCtl );
if AParent.fIsGroupBox then
begin
AParent.Style := AParent.Style and
not BS_GROUPBOX; // otherwise the groupbox is flickering A LOT!
AParent.Parent.AttachProc( WndProc_ParentOfGraphicCtl );
end;
Result.fFont := Result.fFont.Assign( AParent.fFont );
if Result.fFont <> nil then
begin
Result.fFont.fParentGDITool := AParent.fFont;
Result.fFont.fOnChange := Result.FontChanged;
Result.FontChanged( Result.fFont );
end;
end;
Result.fBoundsRect.Right := Result.fBoundsRect.Left + 64;
Result.fBoundsRect.Bottom := Result.fBoundsRect.Top + 22;
{$IFDEF GRAPHCTL_XPSTYLES}
if WinVer < wvXP then
DoNotDrawGraphCtlsUsingXPStyles := TRUE;
{$ENDIF}
end;
function NewGraphLabel( AParent: PControl; const ACaption: String ): PControl;
begin
{$IFDEF INPACKAGE}
Result := NewLabel( AParent, ACaption );
{$ELSE}
Result := _NewGraphCtl( AParent, FALSE );
Result.fCommandActions := LabelActions;
Result.fPaintProc := Result.GraphicLabelPaint;
Result.Caption := ACaption;
{$ENDIF}
end;
function NewWordWrapGraphLabel( AParent: PControl; const ACaption: KOLString ): PControl;
begin
{$IFDEF INPACKAGE}
Result := NewWordWrapLabel( AParent, ACaption );
{$ELSE}
Result := NewGraphLabel( AParent, ACaption );
Result.fWordWrap := TRUE;
{$ENDIF}
end;
function NewGraphPaintBox( AParent: PControl ): PControl;
begin
{$IFDEF INPACKAGE}
Result := NewPaintbox( AParent );
{$ELSE}
Result := NewGraphLabel( AParent, '' );
{$ENDIF}
end;
procedure ClickGraphCheck(Sender: PObj);
var Ctl: PControl;
begin
Ctl := Pointer( Sender );
if not Ctl.Enabled then Exit;
Ctl.Focused := TRUE;
if Assigned( Ctl.OnEnter ) then
Ctl.OnEnter( Ctl );
Ctl.fChecked := not Ctl.fChecked;
Ctl.Invalidate;
if Assigned( Ctl.OnClick ) then
Ctl.OnClick( Ctl );
end;
function NewGraphCheckBox( AParent: PControl; const ACaption: KOLString ): PControl;
begin
{$IFDEF INPACKAGE}
Result := NewCheckbox( AParent, ACaption );
{$ELSE}
Result := NewGraphButton( AParent, ACaption );
Result.TextAlign := taLeft;
Result.fCommandActions.aAutoSzX := GetSystemMetrics( SM_CXMENUCHECK ) + 4;
Result.fPaintProc := Result.GraphicCheckBoxPaint;
Result.fGraphCtlMouseEvent := Result.GraphicCheckBoxMouse;
Result.fControlClick := @ ClickGraphCheck;
{$ENDIF}
end;
procedure ClickGraphRadio(Sender: PObj);
var Ctl, C: PControl;
i: Integer;
begin
Ctl := Pointer( Sender );
if not Ctl.Enabled then Exit;
Ctl.Focused := TRUE;
Ctl.Checked := TRUE;
if Ctl.Parent <> nil then
for i := 0 to Ctl.Parent.ChildCount-1 do
begin
C := Ctl.Parent.Children[ i ];
if (C <> Ctl) and (@ C.fControlClick = @ ClickGraphRadio) then
C.Checked := FALSE;
end;
end;
function NewGraphRadioBox( AParent: PControl; const ACaption: KOLString ): PControl;
begin
{$IFDEF INPACKAGE}
Result := NewRadiobox( AParent, ACaption );
if (@ ClickGraphRadio) <> nil then;
{$ELSE}
Result := NewGraphButton( AParent, ACaption );
Result.TextAlign := taLeft;
Result.fCommandActions.aAutoSzX := GetSystemMetrics( SM_CXMENUCHECK ) + 4;
Result.fPaintProc := Result.GraphicRadioBoxPaint;
Result.fControlClick := @ ClickGraphRadio;
if AParent <> nil then
begin
AParent.fRadioLast := Result.fMenu;
if AParent.fRadio1st = 0 then
begin
AParent.fRadio1st := Result.fMenu;
Result.SetRadioChecked;
end;
end;
{$ENDIF}
end;
function NewGraphButton( AParent: PControl; const ACaption: KOLString ): PControl;
begin
{$IFDEF INPACKAGE}
Result := NewButton( AParent, ACaption );
{$ELSE}
Result := _NewGraphCtl( AParent, TRUE );
Result.fCommandActions := ButtonActions;
Result.fPaintProc := Result.GraphicButtonPaint;
Result.Caption := ACaption;
Result.TextAlign := taCenter;
Result.VerticalAlign := vaCenter;
Result.fGraphCtlMouseEvent := Result.GraphicButtonMouse;
Result.fSetFocus := Result.GraphButtonSetFocus;
Result.fKeyboardProcess := Result.GraphButtonKeyboardProcess;
{$ENDIF}
end;
function NewGraphEditbox( AParent: PControl; Options: TEditOptions ): PControl;
begin
{$IFDEF INPACKAGE}
Result := NewEditbox( AParent, Options );
{$ELSE}
Result := _NewGraphCtl( AParent, TRUE );
Result.fCommandActions := EditActions;
Result.fPaintProc := Result.GraphicEditPaint;
Result.fEditOptions := Options;
Result.VerticalAlign := vaCenter;
Result.fColor := clWindow;
Result.fGraphCtlMouseEvent := Result.GraphicEditMouse;
Result.fSetFocus := Result.GraphEditBoxSetFocus;
Result.fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ];
Result.fLeave := Result.LeaveGraphEdit;
{$ENDIF}
end;
{ TGraphicControl }
function TControl.DoGraphCtlPrepaint: TRect;
begin
Result := ClientRect;
if not Assigned( OnPrepaint ) and not Transparent then
begin
if Assigned( fBrush ) then
Canvas.Brush.Assign( fBrush )
else
Canvas.Brush.Color := Color;
Canvas.FillRect( Result );
end;
end;
procedure TControl.GraphicLabelPaint(DC: HDC);
var R: TRect;
begin
R := DoGraphCtlPrepaint;
if Text <> '' then
DrawFormattedText( @ Self, DC, R, 0 );
//SaveImg( Canvas, R, 'bm09.bmp' );
//sv1 := FALSE;
end;
procedure TControl.GraphicCheckBoxPaint(DC: HDC);
var R, R1: TRect;
Flag: DWORD;
W, H: Integer;
{$IFDEF GRAPHCTL_XPSTYLES}
Theme: THandle;
{$ENDIF}
begin
R := DoGraphCtlPrepaint;
{
R := ClientRect;
if not Assigned( OnPrepaint ) and not Transparent then
begin
if Assigned( fBrush ) then
Canvas.Brush.Assign( fBrush )
else
Canvas.Brush.Color := Color;
Canvas.FillRect( R );
end;
}
{$IFDEF GRAPHCTL_XPSTYLES}
OpenThemeDataProc;
Theme := 0;
if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
Theme := fOpenThemeDataProc( 0, 'Button' );
if Theme <> 0 then
begin
W := GetSystemMetrics( SM_CXMENUCHECK );
H := GetSystemMetrics( SM_CYMENUCHECK );
R1 := R;
R1.Right := R1.Left + W;
if fWordWrap then
R1.Top := R1.Top + Border
else
R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
R1.Bottom := R1.Top + H;
Flag := 1; {CBS_UNCHECKEDNORMAL}
if not Enabled then
Flag := 4 {CBS_UNCHECKEDDISABLED}
else
if fHot then
Flag := 2; {CBS_UNCHECKEDHOT}
if fChecked then
Inc( Flag, 4 );
fDrawThemeBackground( Theme, DC, 3 {BP_CHECKBOX}, Flag, @R1, @R );
R.Left := R1.Left + W + Border;
if fCaption <> '' then
begin
DrawFormattedText( @ Self, DC, R, DT_CALCRECT );
if fWordWrap then
begin
DrawFormattedText( @ Self, DC, R, 0 );
GraphCtlDrawFocusRect( DC, R );
end
else
begin
GraphCtlDrawFocusRect( DC, R );
DrawFormattedTextXP( Theme, @ Self, DC, R, 3 {BP_CHECKBOX}, Flag, 0, 0 );
end;
end;
fCloseThemeData( Theme );
end
else
{$ENDIF}
begin
W := GetSystemMetrics( SM_CXMENUCHECK );
H := GetSystemMetrics( SM_CYMENUCHECK );
R1 := R;
R1.Right := R1.Left + W;
if fWordWrap then
R1.Top := R1.Top + Border
else
R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
R1.Bottom := R1.Top + H;
//if not Transparent then
begin
Flag := 0;
if fChecked then
Flag := DFCS_CHECKED;
DrawFrameControl( DC, R1, DFC_BUTTON, DFCS_BUTTONCHECK or
$800 {DFCS_TRANSPARENT} or Flag );
end;
R.Left := R1.Left + W + Border;
DrawFormattedText( @ Self, DC, R, 0 );
GraphCtlDrawFocusRect( DC, R );
end;
end;
procedure TControl.GraphicCheckBoxMouse(var Msg: TMsg);
begin
if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_LBUTTONDBLCLK) then
ClickGraphCheck( @ Self );
end;
procedure TControl.GraphicRadioBoxPaint(DC: HDC);
var R, R1: TRect;
Flag: DWORD;
W, H: Integer;
{$IFDEF GRAPHCTL_XPSTYLES}
Theme: THandle;
{$ENDIF}
begin
R := DoGraphCtlPrepaint;
{R := ClientRect;
if not Assigned( OnPrepaint ) and not Transparent then
Canvas.FillRect( R );}
{$IFDEF GRAPHCTL_XPSTYLES}
OpenThemeDataProc;
Theme := 0;
if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
Theme := fOpenThemeDataProc( 0, 'Button' );
if Theme <> 0 then
begin
W := GetSystemMetrics( SM_CXMENUCHECK );
H := GetSystemMetrics( SM_CYMENUCHECK );
R1 := R;
R1.Right := R1.Left + W;
if fWordWrap then
R1.Top := R1.Top + Border
else
R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
R1.Bottom := R1.Top + H;
Flag := 1; {CBS_UNCHECKEDNORMAL}
if not Enabled then
Flag := 4 {CBS_UNCHECKEDDISABLED}
else
if fHot then
Flag := 2; {CBS_UNCHECKEDHOT}
if fChecked then
Inc( Flag, 4 );
fDrawThemeBackground( Theme, DC, 2 {BP_RADIOBOX}, Flag, @R1, @R );
R.Left := R1.Left + W + Border;
if fCaption <> '' then
begin
DrawFormattedText( @ Self, DC, R, DT_CALCRECT );
if fWordWrap then
begin
DrawFormattedText( @ Self, DC, R, 0 );
GraphCtlDrawFocusRect( DC, R );
end
else
begin
GraphCtlDrawFocusRect( DC, R );
DrawFormattedTextXP( Theme, @ Self, DC, R, 2 {BP_RADIOBOX}, Flag, 0, 0 );
end;
end;
fCloseThemeData( Theme );
end
else
{$ENDIF}
begin
W := GetSystemMetrics( SM_CXMENUCHECK );
H := GetSystemMetrics( SM_CYMENUCHECK );
R1 := R;
R1.Right := R1.Left + W;
if fWordWrap then
R1.Top := R1.Top + Border
else
R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
R1.Bottom := R1.Top + H;
//if not Transparent then
begin
Flag := 0;
if fChecked then
Flag := DFCS_CHECKED;
DrawFrameControl( DC, R1, DFC_BUTTON, DFCS_BUTTONRADIO
or $800 {DFCS_TRANSPARENT} {or DFCS_ADJUSTRECT} or Flag );
end;
R.Left := R1.Right + 2;
DrawFormattedText( @ Self, DC, R, 0 );
GraphCtlDrawFocusRect( DC, R );
end;
end;
procedure TControl.GraphicButtonPaint(DC: HDC);
var R: TRect;
Flag: DWORD;
{$IFDEF GRAPHCTL_XPSTYLES}
Flag1: DWORD;
Theme: THandle;
{$ENDIF}
II: TIconInfo;
BI: TagBitmap;
Y: Integer;
R1: TRect;
begin
R := DoGraphCtlPrepaint;
{$IFDEF GRAPHCTL_XPSTYLES}
OpenThemeDataProc;
Theme := 0;
if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
Theme := fOpenThemeDataProc( 0, 'Button' );
if Theme <> 0 then
begin
Flag := 1; {PBS_UNCHECKEDNORMAL}
if not Enabled then
Flag := 4 {PBS_UNCHECKEDDISABLED}
else
if fPushed then
Flag := 3 {PBS_UNCHECKEDPRESSED}
else
if fHot then
Flag := 2; {PBS_UNCHECKEDHOT}
if fChecked then
Inc( Flag, 4 );
fDrawThemeBackground( Theme, DC, 1 {BP_PUSHBUTTON}, Flag, @R, @R );
fGetThemeBackgroundContentRect( Theme, DC, 1 {BS_PUSHBUTTON}, Flag, @R, @R1 );
GraphCtlDrawFocusRect( DC, R1 );
if (fButtonIcon <> 0) and GetIconInfo( fButtonIcon, II ) then
begin
if GetObject( II.hbmColor, Sizeof( BI ), @ BI ) <> 0 then
begin
CASE fVerticalAlign OF
vaTop:
Y := R.Top + Border;
vaBottom:
Y := R.Bottom - Border - BI.bmHeight;
else //vaCenter:
Y := R.Top + (R.Bottom - R.Top - BI.bmHeight) div 2;
END;
DrawIcon( DC, R.Left + Border, Y, fButtonIcon );
Inc( R1.Left, BI.bmWidth + Border * 2 );
end;
DeleteObject( II.hbmColor );
if II.hbmMask <> 0 then
DeleteObject( II.hbmMask );
end;
if fCaption <> '' then
begin
Flag1 := DT_SINGLELINE;
if WordWrap then
Flag1 := DT_WORDBREAK;
DrawFormattedText( @ Self, DC, R1, DT_CALCRECT );
DrawFormattedTextXP( Theme, @ Self, DC, R1, 1 {BP_PUSHBUTTON}, Flag,
Flag1, 0 );
end;
fCloseThemeData( Theme );
end
else
{$ENDIF}
begin
Flag := 0;
if fChecked then
Flag := DFCS_CHECKED
else
if fPushed then
Flag := DFCS_PUSHED;
if fFlat then
Flag := Flag or DFCS_FLAT;
DrawFrameControl( DC, R, DFC_BUTTON, DFCS_BUTTONPUSH or
$800 {DFCS_TRANSPARENT} or DFCS_ADJUSTRECT or Flag );
//{$IFNDEF GRAPHCTL_XPSTYLES}
R1 := R;
//{$ENDIF}
if (fButtonIcon <> 0) and GetIconInfo( fButtonIcon, II ) then
begin
if GetObject( II.hbmColor, Sizeof( BI ), @ BI ) <> 0 then
begin
CASE fVerticalAlign OF
vaTop:
Y := R.Top + Border;
vaBottom:
Y := R.Bottom - Border - BI.bmHeight;
else //vaCenter:
Y := R.Top + (R.Bottom - R.Top - BI.bmHeight) div 2;
END;
DrawIcon( DC, R.Left + Border, Y, fButtonIcon );
Inc( R1.Left, BI.bmWidth + Border * 2 );
end;
DeleteObject( II.hbmColor );
if II.hbmMask <> 0 then
DeleteObject( II.hbmMask );
end;
DrawFormattedText( @ Self, DC, R1, 0 );
GraphCtlDrawFocusRect( DC, R );
end;
end;
procedure TControl.GraphicButtonMouse(var Msg: TMsg);
var Pt: TPoint;
begin
CASE Msg.message OF
WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
begin
GraphButtonSetFocus;
RefInc;
SetCapture( Parent.Handle );
Parent.fPushedBtn := @ Self;
fPushed := TRUE;
Invalidate;
end;
WM_LBUTTONUP:
begin
ReleaseCapture;
Invalidate;
if fPushed then
begin
Pt.X := SmallInt( LoWord( Msg.lParam ) );
Pt.Y := SmallInt( HiWord( Msg.lParam ) );
if PtInRect( ClientRect, Pt ) then
DoClick;
fPushed := FALSE;
Parent.fPushedBtn := nil;
RefDec;
end;
end;
END;
end;
procedure TControl.GraphButtonSetFocus;
var PF: PControl;
CC: PControl;
W: HWnd;
begin
if not fTabStop then Exit;
PF := ParentForm;
if (PF.fCurrentControl <> nil) and (PF.fCurrentControl <> @ Self) and
(PF.fCurrentControl <> Parent) then
begin
CC := PF.fCurrentControl;
CC.RefInc;
Parent.Focused := TRUE;
if Assigned( CC.fLeave ) then
CC.fLeave( PF.fCurrentControl )
else
Windows.SetFocus( 0 );
CC.RefDec;
end
else
begin
W := GetFocus;
if (W <> Parent.fHandle) and (W <> 0) then
begin
Windows.SetFocus( 0 );
Parent.Focused := TRUE;
end;
end;
if Parent.fHandle <> 0 then
begin
fFocused := TRUE;
Parent.Postmsg( CM_FOCUSGRAPHCTL, Integer( @ Self ), 0 );
RefInc;
end;
if Assigned( fOnEnter ) then
fOnEnter( @ Self );
end;
procedure TControl.LeaveGraphButton( Sender: PObj );
begin
fFocused := FALSE;
if Parent.fCurrentControl = @ Self then
Parent.fCurrentControl := nil;
if ParentForm.fCurrentControl = @ Self then
ParentForm.fCurrentControl := nil;
Invalidate;
if Assigned( fOnLeave ) then
fOnLeave( @ Self );
end;
function TControl.GraphButtonKeyboardProcess(var Msg: TMsg;
var Rslt: Integer): Boolean;
var SpacePressed: Boolean;
begin
Result := FALSE;
SpacePressed := Msg.wParam = Word( ' ' );
{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
SpacePressed := SpacePressed or (Msg.wParam = 13);
{$ENDIF}
if not SpacePressed then Exit;
if (Msg.message = WM_KEYDOWN) or (Msg.message = WM_SYSKEYDOWN) then
begin
Parent.fPushedBtn := @ Self;
fPushed := TRUE;
Invalidate;
Result := TRUE; /////
end
else
if (Msg.message = WM_KEYUP) or (Msg.message = WM_SYSKEYUP) then
begin
fPushed := FALSE;
Parent.fPushedBtn := nil;
Invalidate;
Result := TRUE; /////
end
else
if (Msg.message = WM_CHAR) or (Msg.message = WM_SYSCHAR) then
begin
DoClick;
Result := TRUE;
end;
end;
procedure TControl.GraphicEditPaint(DC: HDC);
var R: TRect;
{$IFDEF GRAPHCTL_XPSTYLES}
R1: TRect;
Flag, Flag1: DWORD;
Theme: THandle;
{$ENDIF}
begin
R := ClientRect;
{$IFDEF GRAPHCTL_XPSTYLES}
OpenThemeDataProc;
Theme := 0;
if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
Theme := fOpenThemeDataProc( 0, 'Edit' );
if Theme <> 0 then
begin
Flag := 1; {ETS_NORMAL}
if not Enabled then
Flag := 4 {ETS_DISABLED}
else
if eoReadonly in fEditOptions then
Flag := 6 {ETS_READONLY}
else
if fFocused then
Flag := 5 {ETS_FOCUSED}
else
if fHot then
Flag := 2; {ETS_HOT}
fDrawThemeBackground( Theme, DC, 1 {EP_EDITTEXT}, Flag, @R, @R );
Inc( R.Left, 2 );
Dec( R.Right, 2 );
fGetThemeBackgroundContentRect( Theme, DC, 1 {EP_EDITTEXT}, Flag, @R, @R1 );
if fCaption <> '' then
begin
Flag1 := DT_SINGLELINE;
if eoMultiline in fEditOptions then
Flag1 := DT_WORDBREAK;
CASE fTextAlign OF
taCenter: Flag1 := Flag1 or DT_CENTER;
taRight: Flag1 := Flag1 or DT_RIGHT;
//else Flag1 := Flag1 or DT_LEFT;
END;
CASE fVerticalAlign OF
vaCenter: Flag1 := Flag1 or DT_VCENTER;
vaBottom: Flag1 := Flag1 or DT_BOTTOM;
//else Flag1 := Flag1 or DT_TOP;
END;
DrawFormattedTextXP( Theme, @ Self, DC, R1, 1 {EP_EDITTEXT}, Flag,
Flag1, 0 );
end;
fCloseThemeData( Theme );
end
else
{$ENDIF}
begin
if not Assigned( OnPrepaint ) and not Transparent then
begin
Canvas.Brush.Color := fColor;
Canvas.FillRect( R );
end;
DrawEdge( DC, R, BDR_SUNKENINNER or BDR_SUNKENOUTER, BF_ADJUST or BF_RECT );
DrawFormattedText( @ Self, DC, R, DT_EDITCONTROL );
end;
end;
procedure TControl.GraphicEditMouse(var Msg: TMsg);
var E: PControl;
Pt: TPoint;
begin
CASE Msg.message OF
WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
if not ( eoReadOnly in fEditOptions ) then
begin
E := EditGraphEdit;
Pt.X := Smallint( LoWord( Msg.lParam ) ) - Left;
Pt.Y := Smallint( HiWord( Msg.lParam ) ) - Top;
PostMessage( E.Handle, Msg.message, Msg.wParam,
Pt.Y shl 16 or Pt.X and $FFFF );
end;
END;
end;
function TControl.EditGraphEdit: PControl;
var E: PControl;
begin
E := NewEditBox( Parent, fEditOptions )
.SetPosition( Left, Top )
.SetSize( Width, Height )
.SetAlign( Align );
E.fTabOrder := fTabOrder;
E.Text := Text;
E.OnChange := ChangeGraphEdit;
E.Color := Color;
E.fCursor := fCursor;
E.CreateWindow;
E.OnLeave := LeaveGraphEdit;
E.fLeave := LeaveGraphEdit;
E.Focused := TRUE;
E.OnChar := OnChar;
E.OnKeyDown := OnKeyDown;
E.OnKeyUp := OnKeyUp;
E.OnDestroy := DestroyGraphEdit;
//E.Font.Assign( Font );
Result := E;
Visible := FALSE;
fEditCtl := E;
if Assigned( fOnEnter ) then
fOnEnter( @ Self );
end;
procedure TControl.LeaveGraphEdit(Sender: PObj);
begin
if PControl( Sender ).fWindowed and Assigned( fEditCtl ) then
begin
Text := PControl( Sender ).Text;
fEditCtl := nil;
Visible := TRUE;
ParentForm.fCurrentControl := @ Self;
Parent.fCurrentControl := @ Self;
Parent.Postmsg( CM_QUIT, DWORD( Sender ), 0 );
end
else
if Assigned( fEditCtl ) then
begin
fEditCtl.fLeave( fEditCtl );
end;
end;
procedure TControl.ChangeGraphEdit(Sender: PObj);
begin
Text := PControl( Sender ).Text;
end;
procedure TControl.GraphEditboxSetFocus;
begin
EditGraphEdit;
end;
procedure TControl.DestroyGraphEdit(Sender: PObj);
begin
fEditCtl := nil;
end;
procedure TControl.GraphCtlDrawFocusRect(DC: HDC; const R: TRect);
var rgn: HRgn;
begin
if fFocused and (GetActiveWindow = ParentForm.Handle) then
begin
BeginPath( DC );
Canvas.FrameRect( R );
EndPath( DC );
Canvas.FrameRect( R );
DrawFocusRect( DC, R );
rgn := PathToRegion( DC );
ExtSelectClipRgn( DC, rgn, RGN_DIFF );
DeleteObject( rgn );
end;
end;
procedure TControl.GroupBoxPaint(DC: HDC);
var bk_erased: Boolean;
procedure DoEraseBkgnd;
var R: TRect;
begin
bk_erased := TRUE;
if Assigned( OnEraseBkgnd ) then
OnEraseBkgnd( @ Self, DC )
else
begin
R := BoundsRect;
OffsetRect( R, -R.Left, -R.Top );
SetBkMode( DC, OPAQUE );
SetBkColor( DC, Color2RGB( fColor ) );
SetBrushOrgEx( DC, 0, 0, nil );
Windows.FillRect( DC, R, Global_GetCtlBrushHandle( @ Self ) );
end;
end;
var R, R1, R0: TRect;
rgn, rgn2, rgntxt, rgnsav, rgnsavall: HRgn;
i: Integer;
C: PControl;
{$IFDEF GRAPHCTL_XPSTYLES}
Theme: THandle;
Flag: DWORD;
{$ENDIF}
begin
if not fErasingBkgnd then
Exit;
R := ClientRect;
Dec( R.Top, 14 { Self_.fClientTop div 2 } );
Dec( R.Left, fClientLeft );
Inc( R.Right, fClientRight );
Inc( R.Bottom, fClientBottom );
rgnsavall := CreateRectRgn( 0, 0, 0, 0 );
GetClipRgn( DC, rgnsavall );
TRY
for i := 0 to ChildCount-1 do
begin
C := Children[ i ];
if not C.fWindowed and C.fVisible then
begin
rgn := CreateRectRgnIndirect( C.BoundsRect );
ExtSelectClipRgn( DC, rgn, RGN_DIFF );
DeleteObject( rgn );
end;
end;
{$IFDEF GRAPHCTL_XPSTYLES}
OpenThemeDataProc;
Theme := 0;
if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
Theme := fOpenThemeDataProc( 0, 'Button' );
if Theme <> 0 then
begin
DoEraseBkgnd;
Flag := 1; {GBS_NORMAL}
if not Enabled then
Flag := 2; {GBS_DISABLED}
R1 := R;
rgnsav := 0;
if fCaption <> '' then
begin
R1.Top := 0;
Inc( R1.Left, 8 );
Dec( R1.Right, 8 );
BeginPath( DC );
DrawFormattedTextXP( Theme, @ Self, DC, R1, 4 {BP_GROUPBOX}, Flag, 0, 0 );
EndPath( DC );
rgntxt := PathToRegion( DC );
if rgntxt = 0 then
begin
R1.Right := R1.Left + Canvas.TextWidth( fCaption );
R1.Bottom := R1.Top + Canvas.TextHeight( fCaption );
rgntxt := CreateRectRgnIndirect( R1 );
end;
DrawFormattedTextXP( Theme, @ Self, DC, R1, 4 {BP_GROUPBOX}, Flag, 0, 0 );
GetRgnBox( rgntxt, R0 );
Dec( R0.Left, 3 );
Inc( R0.Right, 3 );
DeleteObject( rgntxt );
rgn := CreateRectRgnIndirect( R0 );
end
else
begin
rgn := 0;
end;
if rgn <> 0 then
begin
rgnsav := CreateRectRgn( 0, 0, 0, 0 );
GetClipRgn( DC, rgnsav );
ExtSelectClipRgn( DC, rgn, RGN_DIFF );
DeleteObject( rgn );
end;
fDrawThemeBackground( Theme, DC, 4 {BP_GROUPBOX}, Flag, @R, @R );
if rgnsav <> 0 then
begin
SelectClipRgn( DC, rgnsav );
DeleteObject( rgnsav );
end;
fCloseThemeData( Theme );
end
else
{$ENDIF}
begin
bk_erased := FALSE;
R1 := R;
R1.Top := 0;
R1.Bottom := ClientRect.Top;
Inc( R1.Left, 16 );
Dec( R1.Right, 16 );
fVerticalAlign := vaCenter;
BeginPath( DC );
Canvas.TextOut( R1.Left, R1.Top, fCaption );
EndPath( DC );
Canvas.TextOut( R1.Left, R1.Top, fCaption );
rgntxt := PathToRegion( DC );
if rgntxt = 0 then // такое - в случае шрифта по умолчаниі!
begin
R1.Right := R1.Left + Canvas.TextWidth( fCaption );
R1.Bottom := R1.Top + Canvas.TextHeight( fCaption );
rgntxt := CreateRectRgnIndirect( R1 );
end;
GetRgnBox( rgntxt, R0 );
rgn2 := CreateRectRgnIndirect( R0 );
rgnsav := CreateRectRgn( 0, 0, 0, 0 );
GetClipRgn( DC, rgnsav );
ExtSelectClipRgn( DC, rgn2, RGN_DIFF );
DeleteObject( rgn2 );
BeginPath( DC );
DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT );
EndPath( DC );
rgn := PathToRegion( DC );
if rgn = 0 then DoEraseBkgnd;
DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT );
SelectClipRgn( DC, rgnsav );
DeleteObject( rgnsav );
if rgn <> 0 then
begin
ExtSelectClipRgn( DC, rgn, RGN_DIFF );
DeleteObject( rgn );
end;
ExtSelectClipRgn( DC, rgntxt, RGN_DIFF );
DeleteObject( rgntxt );
if not bk_erased then DoEraseBkgnd;
end;
FINALLY
SelectClipRgn( DC, rgnsavall );
DeleteObject( rgnsavall );
END;
end;
{$ENDIF USE_GRAPHCTLS}
function TControl.MakeWordWrap: PControl;
begin
fWordWrap := TRUE;
Style := (fStyle and not SS_LEFTNOWORDWRAP) or BS_MULTILINE;
Result := @ Self;
end;
function ParentAnchorChildren( Sender: PControl; var Msg: TMsg;
var Rslt: Integer ): Boolean;
var NewW, NewH: Integer;
dW, dH: Integer;
i: Integer;
C: PControl;
{$IFNDEF ANCHORS_WM_SIZE}
CR: TRect;
{$ENDIF}
begin
Result := FALSE;
if (Msg.message = {$IFDEF ANCHORS_WM_SIZE} WM_SIZE {$ELSE} WM_WINDOWPOSCHANGED {$ENDIF} )
{$ifndef wince} and not IsIconic(Sender.Handle) {$endif} then
begin
{$IFDEF ANCHORS_WM_SIZE}
NewW := LoWord( Msg.lParam ) - Sender.fClientLeft - Sender.fClientRight;
NewH := HiWord( Msg.lParam ) - Sender.fClientTop - Sender.fClientBottom;
{$ELSE}
CR := Sender.ClientRect;
NewW := CR.Right;
NewH := CR.Bottom;
{$ENDIF}
dW := NewW - Sender.fOldWidth;
dH := NewH - Sender.fOldHeight;
for i := 0 to Sender.ChildCount - 1 do
begin
C := Sender.Children[ i ];
if dW <> 0 then
begin
if C.AnchorRight and C.AnchorLeft then
C.Width := C.Width + dW
else if C.AnchorRight then
C.Left := C.Left + dW;
end;
if dH <> 0 then
begin
if C.AnchorBottom and C.AnchorTop then
C.Height := C.Height + dH
else if C.AnchorBottom then
C.Top := C.Top + dH;
end;
end;
Sender.fOldWidth := NewW;
Sender.fOldHeight := NewH;
end;
end;
function TControl.Anchor(aLeft, aTop, aRight, aBottom: Boolean): PControl;
begin
if (not aLeft) and aRight then
SetAnchorLeft( FALSE )
else
SetAnchorLeft( aLeft );
if (not aTop) and aBottom then
SetAnchorTop( FALSE )
else
SetAnchorTop( aTop );
SetAnchorRight( aRight );
SetAnchorBottom( aBottom );
Result := @ Self;
end;
procedure TControl.SetAnchorLeft(const Value: Boolean);
begin
fAnchorLeft := Value;
if Parent <> nil then
begin
fParent.AttachProc( ParentAnchorChildren );
Parent.fOldWidth := Parent.ClientWidth;
end;
end;
procedure TControl.SetAnchorTop(const Value: Boolean);
begin
fAnchorTop := Value;
if Parent <> nil then
begin
fParent.AttachProc( ParentAnchorChildren );
fParent.fOldHeight := Parent.ClientHeight;
end;
end;
procedure TControl.SetAnchorBottom(Value: Boolean);
begin
fAnchorBottom := Value;
if Parent <> nil then
begin
fParent.AttachProc( ParentAnchorChildren );
fParent.fOldHeight := Parent.ClientHeight;
end;
end;
procedure TControl.SetAnchorRight(Value: Boolean);
begin
fAnchorRight := Value;
if Parent <> nil then
begin
Parent.AttachProc( ParentAnchorChildren );
Parent.fOldWidth := Parent.ClientWidth;
end;
end;
function TControl.GetLBTopIndex: Integer;
begin
Result := Perform(LB_GETTOPINDEX,0,0);
end;
function TControl.LBItemAtPos(X, Y: Integer): Integer;
var
R: TRect;
P: TPoint;
i: Integer;
begin
P := MakePoint(X,Y);
for i := LBTopIndex to Count -1 do begin
Perform(LB_GETITEMRECT, i , Integer(@R));
if PointInRect(P,R) then begin
Result := i;
Exit;
end;
end;
Result := -1;
end;
procedure TControl.SetLBTopIndex(const Value: Integer);
begin
Perform(LB_SETTOPINDEX,Value,0);
end;
//--------
procedure ScrollToChild(C, SB: PControl);
function DoScroll(msg, bar, d1, d2, client: integer): boolean;
var
i: integer;
begin
i:=GetScrollPos(SB.Handle, bar);
if d1 < SB.Border then
Dec(i, SB.Border - d1)
else
if d2 > client - SB.Border then
Inc(i, d2 - client + SB.Border)
else begin
Result:=False;
exit;
end;
SetScrollPos(SB.Handle, bar, i, True);
Result:=True;
end;
var
R: TRect;
begin
if C = nil then exit;
R:=C.BoundsRect;
R.TopLeft:=SB.Screen2Client(C.Parent.Client2Screen(R.TopLeft));
R.BottomRight:=SB.Screen2Client(C.Parent.Client2Screen(R.BottomRight));
if DoScroll(WM_VSCROLL, SB_VERT, R.Top, R.Bottom, SB.ClientHeight) or
DoScroll(WM_HSCROLL, SB_HORZ, R.Left, R.Right, SB.ClientWidth)
then
ScrollChildren(SB);
end;
function WndProcScrollable( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
procedure ProcessScroll;
begin
NotifyScrollBox(Sender, nil);
ScrollToChild(Sender.ParentForm.ActiveControl, Sender);
end;
begin
Result:=False;
case Msg.message of
WM_SIZE:
PostMessage(Sender.fHandle, CM_SHOW, 0, 0);
WM_SHOWWINDOW:
if WordBool(Msg.wParam) then
PostMessage(Sender.fHandle, CM_SHOW, 0, 0);
CM_SHOW:
begin
ProcessScroll;
Result:=True;
end;
end;
end;
function WndProcScrollToChild( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var
P: PControl;
begin
Result:=False;
if Msg.message = WM_SETFOCUS then begin
P:=Sender.Parent;
while (P <> nil) and not Assigned(P.fScrollChildren) do
P:=P.Parent;
if P <> nil then
ScrollToChild(Sender, P);
end;
end;
procedure NotifyScroller( Self_, Child: PControl );
begin
if Assigned(Child) then begin
Child.AttachProc(@WndProcScrollToChild);
if not Assigned(Child.fNotifyChild) then
Child.fNotifyChild:=@NotifyScroller;
end;
end;
procedure TControl.MakeScrollable;
procedure AttachProcToChildren(P: PControl);
var
i: integer;
C: PControl;
begin
for i:=0 to P.ChildCount - 1 do begin
C:=P.Children[i];
NotifyScroller(P, C);
AttachProcToChildren(C);
end;
end;
begin
if not IsProcAttached( WndProcScrollBox ) then begin
fDynHandlers.Insert(0, nil);
fDynHandlers.Insert(0, @WndProcScrollBox);
end;
AttachProc( WndProcScrollable );
fScrollChildren := ScrollChildren;
FScrollLineDist[ 0 ] := 16;
FScrollLineDist[ 1 ] := 16;
fNotifyChild:=@NotifyScroller;
AttachProcToChildren(@Self);
end;
{$ENDIF WIN_GDI}
procedure TControl.DisableAlign;
begin
Include(fAligning, oaAligning);
end;
procedure TControl.EnableAlign;
begin
fAligning:=[];
Global_Align(@Self);
end;
{$IFNDEF PAS_VERSION}
// {$DEFINE ASM_VERSION}
// {$DEFINE ASM_UNICODE}
{$I KOL_ASM.inc} {$ENDIF ASM_VERSION}
{$IFDEF LIN}
{$DEFINE implementation} {$I KOL_Linux.inc} {$UNDEF implementation}
{$ENDIF LIN}
{ -- }
{$IFDEF USE_CUSTOMEXTENSIONS}
{$I CUSTOM_CODE_EXTENSION.inc} // See comments in TControl
{$ENDIF USE_CUSTOMEXTENSIONS}
//[initialization]
{$IFNDEF NOT_UNLOAD_RICHEDITLIB}
{$IFDEF UNLOAD_RICHEDITLIB}
{$DEFINE INIT_FINIT}
{$ENDIF}
{$ENDIF}
{$IFDEF USE_NAMES}
{$DEFINE INIT_FINIT}
{$ENDIF}
{$IFDEF GRAPHCTL_XPSTYLES}
{$DEFINE INIT_FINIT}
{$ENDIF}
{$IFDEF KOL_MMX}
{$DEFINE INIT_FINIT}
{$ENDIF}
{$IFDEF INIT_FINIT}
initialization
{$IFDEF GRAPHCTL_XPSTYLES}
CheckThemes;
if AppTheming then
InitThemes;
{$ENDIF}
//[finalization]
finalization
{$IFDEF GRAPHCTL_XPSTYLES}
if AppTheming then
DeinitThemes;
{$ENDIF}
{$IFNDEF NOT_UNLOAD_RICHEDITLIB}
{$IFDEF UNLOAD_RICHEDITLIB}
if FRichEditModule <> 0 then
FreeLibrary( FRichEditModule );
{$ENDIF UNLOAD_RICHEDITLIB}
{$ENDIF}
{$ENDIF INIT_FINIT}
//[END OF KOL.pas]
end.