initial commit

[rofl0r-KOL.git] / Kol.pas.200to208-000.old

//[START OF KOL.pas]\r
{****************************************************************\r
\r
        KKKKK    KKKKK    OOOOOOOOO    LLLLL\r
        KKKKK    KKKKK  OOOOOOOOOOOOO  LLLLL\r
        KKKKK    KKKKK  OOOOO   OOOOO  LLLLL\r
        KKKKK  KKKKK    OOOOO   OOOOO  LLLLL\r
        KKKKKKKKKK      OOOOO   OOOOO  LLLLL\r
        KKKKK  KKKKK    OOOOO   OOOOO  LLLLL\r
        KKKKK    KKKKK  OOOOO   OOOOO  LLLLL\r
        KKKKK    KKKKK  OOOOOOOOOOOOO  LLLLLLLLLLLLL\r
        KKKKK    KKKKK    OOOOOOOOO    LLLLLLLLLLLLL\r
\r
  Key Objects Library (C) 2000 by Kladov Vladimir.\r
\r
//[VERSION]\r
****************************************************************\r
* VERSION 2.00\r
****************************************************************\r
//[END OF VERSION]\r
\r
  K.O.L. - is a set of objects to create small programs\r
  with the Delphi, but without the VCL. KOL allows to\r
  create executables of size about 10 times smaller then\r
  those created with the VCL. But this does not mean that\r
  KOL is less power then the VCL - perhaps just the opposite...\r
\r
  KOL is provided free with the source code.\r
  Copyright (C) Vladimir Kladov, 2000-2003.\r
\r
  For code provided by other  developers (even if later\r
  changed by me) authors are noted in the source.\r
\r
  mailto: bonanzas@online.sinor.ru\r
  Web-Page: http://bonanzas.rinet.ru\r
\r
  See also Mirror Classes Kit (M.C.K.) which allows\r
  to create KOL programs visually.\r
\r
****************************************************************}\r
\r
//[UNIT DEFINES]\r
{$INCLUDE delphidef.inc}\r
\r
//[START OF UNIT]\r
unit KOL;\r
{-}\r
{*\r
   Please note, that KOL does not use keyword 'class'. Instead,\r
   poor Pascal 'object' is the base of our objects. So, remember,\r
   how we worked earlier with such Object Pascal's objects:\r
|<br>\r
   - to create objects dynamically, use P<objname> instead of\r
     T<objname> to allocate a pointer for dynamically created\r
     object instance;\r
|<br>\r
   - remember, that constructors of objects can not be virtual.\r
     Override procedure Init instead in your own derived objects;\r
|<br>\r
   - rather then call constructors of objects, call global procedures\r
     New<objname> (e.g. NewLabel). If not, first (for virtualally\r
     created objects) call New( ); then call constructor Create\r
     (which calls Init) - but this is possible only if the constructor\r
     is overriden by a new one.\r
|<br>\r
   - the operator 'is' is not applicable to objects. And operator 'as'\r
     is not necessary (and is not applicable too), use typecast to desired\r
     object type, e.g.: "PSomeObjectType( C )" inplace of "C as TSomeClassType".\r
|<br>\r
|<hr>\r
     Also remember, that IF [ MyObj: PMyObj ] THEN\r
\r
     NOT[ with MyObj do ] BUT[ with MyObj^ do ]\r
\r
     Though it is possible to skip '^' symbol when accessing member\r
     fields, methods, properties, e.g. [ MyObj.Execute; ]\r
|<hr>\r
|&U=&nbsp;&nbsp;&nbsp;<a href="#%0">%0</a><br>\r
|&B=<a href="%1.htm">%0</a><br>\r
|&C=<a href="%1.htm">%0</a>\r
|     <table border=1 cellpadding=6 width=100%>\r
|     <colgroup valign=top span=2>\r
|       <tr>\r
|         <td>  objects  </td>     <td>   functions by category </td>\r
|       </tr>\r
|         <td>\r
              <C _TObj> <B TObj>\r
              <C TList> <C TListEx> <C TStrList> <B TStrListEx>\r
              <C TTree> <C TDirList> <C TIniFile> <C TCabFile>\r
              <B TStream>\r
              <B TControl>\r
              <C TGraphicTool> <C TCanvas> <C TImageList> <C TIcon> <C TBitmap>\r
              <C TGif> <C TGifDecoder> <B TJpeg>\r
              <C TTimer> <C TThread> <C TTrayIcon> <C TDirChange> <B TMediaPlayer>\r
              <C TMenu> <C TOpenSaveDialog> <C TOpenDirDialog> <B TColorDialog>\r
              <C TAction> <B TActionList>\r
              <B Exception>\r
|         </td>\r
|         <td>\r
|<a href="kol_pas.htm#visual_objects_constructors">\r
      Visual objects constructing functions\r
|</a><br><br>\r
              <U Working with null-terminated and ansi strings>\r
              <U Small bit arrays (max 32 bits in array)>\r
              <U Arithmetics, geometry and other utility functions>\r
              <U Data sorting (quicksort implementation)>\r
              <U String to number and number to string conversions>\r
              <U 64-bit integer numbers>\r
              <U Floating point numbers>\r
              <U Date and time handling>\r
              <U File and directory routines>\r
              <U System functions and working with windows>\r
              <U Text in clipboard operations>\r
              <U Wrappers to registry API functions>\r
|         </td>\r
|     </table>\r
\r
  Several conditional symbols can be used in a project\r
  (Project | Options | Directories/Conditional Defines)\r
  to change code generated a bit. There are following:\r
|<pre>\r
\r
  PAS_VERSION           - to use Pascal version of the code.\r
  PARANOIA              - to force short versions of asm instructions (for D5\r
                        and below, D6 and higher use those instructions always).\r
  USE_CONSTRUCTORS      - to use constructors like in VCL.\r
  USE_CUSTOMEXTENSIONS  - to extend TControl with custom additions.\r
  UNICODE_CTRLS         - to use Unicode versions of controls (WM_XXXXW messages,\r
                        etc.)\r
  USE_MHTOOLTIP         - to use MHTOOLTIP.\r
  NOT_USE_OnIdle        - to stop using OnIdle event (to make code smaller\r
                        if it is not used actually).\r
  USE_ASM_DODRAG        - to use assembler version of code for DoDrag.\r
  ENUM_DYN_HANDLERS_AFTER_RUN - to allow all the events handling even when\r
                        AppletTerminated become TRUE.\r
  ALL_BUTTONS_RESPOND_TO_ENTER - obvious (by default, buttons respond to key\r
                        SPACE, since those are working this way in Windows).\r
  ESC_CLOSE_DIALOGS     - to allow closing all dialogs with ESCAPE.\r
  OpenSaveDialog_Extended - to allow using custom extensions for OpenSaveDialog.\r
  AUTO_CONTEXT_HELP     - to use automatic respond to WM_CONTEXTMENU to call\r
                        context help.\r
  NOT_FIX_CURINDEX      - to use old version of TControl.SetItems, which could\r
                        lead to loose CurIndex value (e.g. for Combobox)\r
  NEW_MODAL             - to use extended madalness.\r
  USE_SETMODALRESULT    - to guarantee ModalResult property assigninig handling.\r
  USE_MENU_CURCTL       - to use CurCtl property in popup menu to detect which\r
                        control initiated a pop-up.\r
  NEW_MENU_ACCELL       - to use another menu accelerators handling, without\r
                        AcceleratorTable\r
  USE_DROPDOWNCOUNT     - to force setting combobox dropdown count.\r
  NOT_UNLOAD_RICHEDITLIB - to stop unload Rich Edit library in finalization\r
                        section (to economy several byte of code).\r
  DEBUG_GDIOBJECTS      - to allow counting all the GDI objects used.\r
  CHK_BITBLT            - to check BitBlt operations.\r
  DEBUG_ENDSESSION      - to allow debugging WM_ENDSESSION handling.\r
  DEBUG_CREATEWINDOW    - to debug CreateWindow.\r
  TEST_CLOSE            - to debug Close.\r
  DEBUG_MENU            - to debug menu.\r
  DEBUG_DBLBUFF         - to debug DoubleBuffered.\r
  DEBUG                 - other debugging.\r
\r
|</pre>\r
}\r
{= K.O.L - êëþ÷åâàÿ áèáëèîòåêà îáúåêòîâ. (C) Êëàäîâ Âëàäèìèð, 2000-2003.\r
}\r
\r
//[OPTIONS]\r
{$A-} // align off, otherwise code is not good\r
{+}\r
\r
{$Q-} // no overflow check: this option makes code wrong\r
{$R-} // no range checking: this option makes code wrong\r
{$T-} // not typed @-operator\r
//{$D+}\r
{$IFDEF INPACKAGE} // use this symbol in packages requiring kol.pas\r
  {$WARNINGS OFF}\r
{$ENDIF}\r
{$IFDEF _D7orHigher}\r
  {$WARN UNSAFE_TYPE OFF} // Too many such warnings in Delphi7\r
  {$WARN UNSAFE_CODE OFF}\r
  {$WARN UNSAFE_CAST OFF}\r
{$ENDIF}\r
\r
\r
//[START OF INTERFACE]\r
interface\r
\r
//{$DEFINE DEBUG_GDIOBJECTS}\r
//{$DEFINE CHK_GDI}\r
\r
//[USES]\r
uses\r
    messages, windows, RichEdit {$IFDEF CHK_GDI}, ChkGdi {$ENDIF};\r
//[END OF USES]\r
\r
{$IFDEF DEBUG_GDIOBJECTS}\r
var\r
  BrushCount: Integer;\r
  FontCount: Integer;\r
  PenCount: Integer;\r
{$ENDIF}\r
\r
\r
//{_#IF [DELPHI]}\r
{$INCLUDE delphicommctrl.inc}\r
//{_#ENDIF}\r
\r
type\r
//[_TObj DEFINITION]\r
\r
{-}\r
   _TObj = object\r
   {* auxiliary object type. See TObj. }\r
   protected\r
     procedure Init; virtual;\r
     {* Is called from a constructor to initialize created object instance\r
        filling its fields with 0. Can be overriden in descendant objects\r
        to add another initialization code there. (Main reason of intending\r
        is what constructors can not be virtual in poor objects). }\r
     {= Âûçûâàåòñÿ äëÿ èíèöèàëèçàöèè îáúåêòà. }\r
   public\r
     function VmtAddr: Pointer;\r
     {* Returns addres of virtual methods table of object. ? }\r
     {= âîçâðàùàåò àäðåñ òàáëèöû âèðòóàëüíûõ ìåòîäîâ (VMT). ? }\r
   end;\r
{+}\r
\r
  {++}(* TObj = class;*){--}\r
  PObj = {-}^{+}TObj;\r
  {* }\r
\r
  {++}(* TList = class;*){--}\r
  PList = {-}^{+}TList;\r
  {* }\r
\r
//[TObjectMethod DECLARATION]\r
  TObjectMethod = procedure of object;\r
  {* }\r
  TOnEvent = procedure( Sender: PObj ) of object;\r
  {* This type of event is the most common - event handler when called can\r
     know only what object was a sender of this call. Replaces good known\r
     VCL TNotifyEvent event type. }\r
\r
//[TPointerList DECLARATION]\r
   PPointerList = ^TPointerList;\r
   TPointerList = array[0..MaxInt div 4 - 1] of Pointer;\r
\r
{ ---------------------------------------------------------------------\r
\r
                  TObj - base object to derive all others\r
\r
---------------------------------------------------------------------- }\r
//[TObj DEFINITION]\r
   TObj = {-} object( _TObj ) {+}{++}(*class*){--}\r
   {* Prototype for all objects of KOL. All its methods are important to\r
      implement objects in a manner similar to Delphi TObject class. }\r
   {= Áàçîâûé êëàññ äëÿ âñåõ ïðî÷èõ îáúåêòîâ KOL. }\r
   protected\r
     fRefCount: Integer;\r
     fOnDestroy: TOnEvent;\r
     procedure DoDestroy;\r
   protected\r
     fAutoFree: PList;\r
     {* Is called from a constructor to initialize created object instance\r
        filling its fields with 0. Can be overriden in descendant objects\r
        to add another initialization code there. (Main reason of intending\r
        is what constructors can not be virtual in poor objects). }\r
     {= Âûçûâàåòñÿ äëÿ èíèöèàëèçàöèè îáúåêòà. }\r
     fTag: DWORD;\r
     {* Custom data. }\r
   {++}(*public*){--}\r
     destructor Destroy; {-} virtual; {+}{++}(* override; *){--}\r
     {* Disposes memory, allocated to an object. Does not release huge strings,\r
        dynamic arrays and so on. Such memory should be freeing in overriden\r
        destructor. }\r
     {= Îñâîáîæäàåò ïàìÿòü, âûäåëåííóþ äëÿ îáúåêòà. Íå îñâîáîæäàåò ïàìÿòü, âûäåëåííóþ\r
        äëÿ ñòðîê, äèíàìè÷èñêèõ ìàññèâîâ è ò.ï. Òàêàÿ ïàìÿòü äîëæíà áûòü îñâîáîæäåíà\r
        â ïåðåîïðåäåëåííîì äåñòðóêòîðå îáúåêòà. }\r
   {++}(*protected*){--}\r
     {++}(*\r
     procedure Init; virtual;\r
     {* Can be overriden in descendant objects\r
        to add initialization code there. (Main reason of intending\r
        is what constructors can not be virtual in poor objects). }\r
     *){--}\r
     procedure Final;\r
     {* Is called in destructor to perform OnDestroy event call and to\r
        released objects, added to fAutoFree list. }\r
   public\r
     procedure Free;\r
     {* Before calling destructor of object, checks if passed pointer is not\r
        nil - similar what is done in VCL for TObject. It is ALWAYS recommended\r
        to use Free instead of Destroy - see also comments to RefInc, RefDec. }\r
     {= Äî âûçîâà äåñòðóêòîðà, ïðîâåðÿåò, íå ïåðåäàí ëè nil â êà÷åñòâå ïàðàìåòðà.\r
        ÂÑÅÃÄÀ ðåêîìåíäóåòñÿ èñïîëüçîâàòü Free âìåñòî Destroy - ñì. òàê æå RefInc,\r
        RefDec. }\r
\r
     {-}\r
     // By Vyacheslav Gavrik:\r
     function InstanceSize: Integer;\r
     {* Returns a size of object instance. }\r
     {+}\r
\r
     constructor Create;\r
     {* Constructor. Do not call it. Instead, use New<objectname> function\r
        call for certain object, e.g., NewLabel( AParent, 'caption' ); }\r
     {= Êîíñòðóêòîð. Íå ñëåäóåò âûçûâàòü åãî. Äëÿ êîíñòðóèðîâàíèÿ îáúåêòîâ,\r
        âûçûâàéòå ñîîòâåòñòâóþùóþ ãëîáàëüíóþ ôóíêöèþ New<èìÿ-îáúåêòà>. Íàïðèìåð,\r
        NewLabel( MyForm, 'Ìåòêà¹1' ); }\r
     {-}\r
     class function AncestorOfObject( Obj: Pointer ): Boolean;\r
     {* Is intended to replace 'is' operator, which is not applicable to objects. }\r
     {= }\r
     function VmtAddr: Pointer;\r
     {* Returns addres of virtual methods table of object. }\r
     {= âîçâðàùàåò àëðåñ òàáëèöû âèðòóàëüíûõ ìåòîäîâ (VMT). }\r
     {+}\r
     procedure RefInc;\r
     {* See comments below. }\r
     {= Ñì. RefDec íèæå. }\r
     procedure RefDec;\r
     {* Decrements reference count. If it is becoming <0, and Free\r
        method was already called, object is (self-) destroyed. Otherwise,\r
        Free method does not destroy object, but only sets flag\r
        "Free was called".\r
     |<br>\r
        Use RefInc..RefDec to provide a block of code, where\r
        object can not be destroyed by call of Free method.\r
        This makes code more safe from intersecting flows of processing,\r
        where some code want to destroy object, but others suppose that it\r
        is yet existing.\r
     |<br>\r
        If You want to release object at the end of block RefInc..RefDec,\r
        do it immediately BEFORE call of last RefDec (to avoid situation,\r
        when object is released in result of RefDec, and attempt to\r
        destroy it follow leads to AV exception).\r
     }\r
     {= Óìåíüøàåò ñ÷åò÷èê èñïîëüçîâàíèÿ. Åñëè â ðåçóëüòàòå ñ÷åò÷èê ñòàíîâèòñÿ\r
        < 0, è ìåòîä Free óæå áûë âûçâàí, îáúåêò (ñàìî-) ðàçðóøàåòñÿ. Èíà÷å,\r
        ìåòîä Free íå ðàçðóøàåò îáúåêò, à òîëüêî óñòàíàâëèâàåò ôëàã "Free áûë\r
        âûçâàí".\r
        |<br>\r
        Èñïîëüçóéòå RefInc..RefDec äëÿ ïðåäîòâðàùåíèÿ ðàçðóøåíèÿ îáúåêòà íà\r
        íåêîòîðîì ó÷àñòêå êîäà (åñëè åñòü òàêàÿ íåîáõîäèìîñòü).\r
        |<br>\r
        Åñëè íóæíî óáèòü (âðåìåííûé) îáúåêò âìåñòå ñ ïîñëåäíèì RefDec, ñäåëàéòå\r
        âûçîâ Free íåìåäëåííî ÏÅÐÅÄ ïîñëåäíèì RefDec. }\r
     property RefCount: Integer read fRefCount;\r
     {* }\r
     property OnDestroy: TOnEvent read fOnDestroy write fOnDestroy;\r
     {* This event is provided for any KOL object, so You can provide your own\r
        OnDestroy event for it. }\r
     {= Äàííîå ñîáûòèå îáåñïå÷èâàåòñÿ äëÿ âñåõ îáúåêòîâ KOL. Ïîçâîëÿåò ñäåëàòü\r
        ÷òî-íèáóäü â ñâÿçè ñ ðàçðóøåíèåì îáúåêòà. }\r
    procedure Add2AutoFree( Obj: PObj );\r
    {* Adds an object to the list of objects, destroyed automatically\r
       when the object is destroyed. Do not add here child controls of\r
       the TControl (these are destroyed by another way). Only non-control\r
       objects, which are not destroyed automatically, should be added here. }\r
    procedure Add2AutoFreeEx( Proc: TObjectMethod );\r
    {* Adds an event handler to the list of events, called in destructor.\r
       This method is mainly for internal use, and allows to auto-destroy\r
       VCL components, located on KOL form at design time (in MCK project). }\r
    property Tag: DWORD read fTag write fTag;\r
    {* Custom data field. }\r
   end;\r
//[END OF TObj DEFINITION]\r
\r
{ ---------------------------------------------------------------------\r
\r
        TList - object to implement list of pointers (or dwords)\r
\r
---------------------------------------------------------------------- }\r
//[TList DEFINITION]\r
  TList = object( TObj )\r
  {* Simple list of pointers. It is used in KOL instead of standard VCL\r
     TList to store any kind data (or pointers to these ones). Can be created\r
     calling function NewList. }\r
  {= Ïðîñòîé ñïèñîê óêàçàòåëåé. }\r
  protected\r
    fItems: PPointerList;\r
    fCount: Integer;\r
    fCapacity: Integer;\r
    fAddBy: Integer;\r
    procedure SetCount(const Value: Integer);\r
    procedure SetAddBy(Value: Integer);\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* Destroys list, freeing memory, allocated for pointers. Programmer\r
       is resposible for destroying of data, referenced by the pointers. }\r
    {= }\r
  {++}(*protected*){--}\r
    procedure SetCapacity( Value: Integer );\r
    function Get( Idx: Integer ): Pointer;\r
    procedure Put( Idx: Integer; Value: Pointer );\r
    {$IFDEF USE_CONSTRUCTORS}\r
    procedure Init; virtual;\r
    {$ENDIF USE_CONSTRUCTORS}\r
  public\r
    procedure Clear;\r
    {* Makes Count equal to 0. Not responsible for freeing (or destroying)\r
       data, referenced by released pointers. }\r
    procedure Add( Value: Pointer );\r
    {* Adds pointer to the end of list, increasing Count by one. }\r
    procedure Insert( Idx: Integer; Value: Pointer );\r
    {* Inserts pointer before given item. Returns Idx, i.e. index of\r
       inserted item in the list. Indeces of items, located after insertion\r
       point, are increasing. To add item to the end of list, pass Count\r
       as index parameter. To insert item before first item, pass 0 there. }\r
    function IndexOf( Value: Pointer ): Integer;\r
    {* Searches first (from start) item pointer with given value and returns\r
       its index (zero-based) if found. If not found, returns -1. }\r
    procedure Delete( Idx: Integer );\r
    {* Deletes given (by index) pointer item from the list, shifting all\r
       follow item indeces up by one. }\r
    procedure DeleteRange( Idx, Len: Integer );\r
    {* Deletes Len items starting from Idx. }\r
    procedure Remove( Value: Pointer );\r
    {* Removes first entry of a Value in the list. }\r
    property Count: Integer read fCount write SetCount;\r
    {* Returns count of items in the list. It is possible to delete a number\r
       of items at the end of the list, keeping only first Count items alive,\r
       assigning new value to Count property (less then Count it is). }\r
    property Capacity: Integer read fCapacity write SetCapacity;\r
    {* Returns number of pointers which could be stored in the list\r
       without reallocating of memory. It is possible change this value\r
       for optimize usage of the list (for minimize number of reallocating\r
       memory operations). }\r
    property Items[ Idx: Integer ]: Pointer read Get write Put; default;\r
    {* Provides access (read and write) to items of the list. Please note,\r
       that TList is not responsible for freeing memory, referenced by stored\r
       pointers. }\r
    function Last: Pointer;\r
    {* Returns the last item (or nil, if the list is empty). }\r
    procedure Swap( Idx1, Idx2: Integer );\r
    {* Swaps two items in list directly (fast, but without testing of\r
       index bounds). }\r
    procedure MoveItem( OldIdx, NewIdx: Integer );\r
    {* Moves item to new position. Pass NewIdx >= Count to move item\r
       after the last one. }\r
    procedure Release;\r
    {* Especially for lists of pointers to dynamically allocated memory.\r
       Releases all pointed memory blocks and destroys object itself. }\r
    procedure ReleaseObjects;\r
    {* Especially for a list of objects derived from TObj.\r
       Calls Free for every of the object in the list, and then calls\r
       Free for the object itself. }\r
    property AddBy: Integer read fAddBy write SetAddBy;\r
    {* Value to increment capacity when new items are added or inserted\r
       and capacity need to be increased. }\r
    property DataMemory: PPointerList read fItems;\r
    {* Raw data memory. Can be used for direct access to items of a list. }\r
    procedure Assign( SrcList: PList );\r
    {* Copies all source list items. }\r
  end;\r
//[END OF TList DEFINITION]\r
\r
//[NewList DECLARATION]\r
function NewList: PList;\r
{* Returns pointer to newly created TList object. Use it instead usual\r
   TList.Create as it is done in VCL or XCL. }\r
\r
procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer );\r
{* Very fast adds Value to List elements from List[FromIdx] to List[FromIdx+Count-1].\r
   Given elements must exist. Count must be > 0. }\r
\r
procedure Free_And_Nil( var Obj );\r
{* Obj.Free and Obj := nil, where Obj *MUST* be TObj or its descendant\r
   (TControl, TMenu, etc.) This procedure is not compatible with VCL's\r
   FreeAndNil, which works with TObject, since this it has another name. }\r
\r
type\r
\r
//[TListEx DEFINITION]\r
  {++}(*TListEx = class;*){--}\r
  PListEx = {-}^{+}TListEx;\r
  TListEx = object( TObj )\r
  {* Extended list, with Objects[ ] property. Created calling NewListEx function. }\r
  protected\r
    fList: PList;\r
    fObjects: PList;\r
    function GetEx(Idx: Integer): Pointer;\r
    procedure PutEx(Idx: Integer; const Value: Pointer);\r
    function GetCount: Integer;\r
    function GetAddBy: Integer;\r
    procedure Set_AddBy(const Value: Integer);\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
    property AddBy: Integer read GetAddBy write Set_AddBy;\r
    {* }\r
    property Items[ Idx: Integer ]: Pointer read GetEx write PutEx;\r
    {* }\r
    property Count: Integer read GetCount;\r
    {* }\r
    procedure Clear;\r
    {* }\r
    procedure Add( Value: Pointer );\r
    {* }\r
    procedure AddObj( Value, Obj: Pointer );\r
    {* }\r
    procedure Insert( Idx: Integer; Value: Pointer );\r
    {* }\r
    procedure InsertObj( Idx: Integer; Value, Obj: Pointer );\r
    {* }\r
    procedure Delete( Idx: Integer );\r
    {* }\r
    procedure DeleteRange( Idx, Len: Integer );\r
    {* }\r
    function IndexOf( Value: Pointer ): Integer;\r
    {* }\r
    function IndexOfObj( Obj: Pointer ): Integer;\r
    {* }\r
    procedure Swap( Idx1, Idx2: Integer );\r
    {* }\r
    procedure MoveItem( OldIdx, NewIdx: Integer );\r
    {* }\r
    property ItemsList: PList read fList;\r
    {* }\r
    property ObjList: PList read fObjects;\r
    {* }\r
    function Last: Pointer;\r
    {* }\r
    function LastObj: Pointer;\r
    {* }\r
  end;\r
//[END OF TListEx DEFINITION]\r
\r
//[NewListEx DECLARATION]\r
function NewListEx: PListEx;\r
{* Creates extended list. }\r
\r
\r
\r
\r
\r
\r
\r
{ -- tree (non-visual) -- }\r
\r
type\r
//[TTree DEFINITION]\r
  {++}(*TTree = class;*){--}\r
  PTree = {-}^{+}TTree;\r
  TTree = object( TObj )\r
  {* Object to store tree-like data in memory (non-visual). }\r
  protected\r
    fParent: PTree;\r
    fChildren: PList;\r
    fPrev: PTree;\r
    fNext: PTree;\r
    fName: String;\r
    fData: Pointer;\r
    function GetCount: Integer;\r
    function GetItems(Idx: Integer): PTree;\r
    procedure Unlink;\r
    function GetRoot: PTree;\r
    function GetLevel: Integer;\r
    function GetTotal: Integer;\r
    function GetIndexAmongSiblings: Integer;\r
  protected\r
    {$IFDEF USE_CONSTRUCTORS}\r
    constructor CreateTree( AParent: PTree; const AName: String );\r
    {* }\r
    {$ENDIF}\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
  {++}(*protected*){--}\r
    procedure Init; {-}virtual;{+}{++}(*override;*){--}\r
  public\r
    procedure Clear;\r
    {* Destoyes all child nodes. }\r
    property Name: String read fName write fName;\r
    {* Optional node name. }\r
    property Data: Pointer read fData write fData;\r
    {* Optional user-defined pointer. }\r
    property Count: Integer read GetCount;\r
    {* Number of child nodes of given node. }\r
    property Items[ Idx: Integer ]: PTree read GetItems;\r
    {* Child nodes list items. }\r
    procedure Add( Node: PTree );\r
    {* Adds another node as a child of given tree node. This operation\r
       as well as Insert can be used to move node together with its children\r
       to another location of the same tree or even from another tree.\r
       Anyway, added Node first correctly removed from old place (if it is\r
       defined for it). But for simplest task, such as filling of tree with\r
       nodes, code should looking as follows:\r
       !  Node := NewTree( nil, 'test of creating node without parent' );\r
       !  RootOfMyTree.Add( Node );\r
       Though, this code gives the same result as:\r
       !  Node := NewTree( RootOfMyTree, 'test of creatign node as a child' ); }\r
    procedure Insert( Before, Node: PTree );\r
    {* Inserts earlier created 'Node' just before given child node 'Before'\r
       as a child of given tree node. See also Add method. }\r
    property Parent: PTree read fParent;\r
    {* Returns parent node (or nil, if there is no parent). }\r
    property Index: Integer read GetIndexAmongSiblings;\r
    {* Returns an index of the node in a list of nodes of the same parent\r
       (or -1, if Parent is not defined). }\r
    property PrevSibling: PTree read fPrev;\r
    {* Returns previous node in a list of children of the Parent. Nil is\r
       returned, if given node is the first child of the Parent or has\r
       no Parent. }\r
    property NextSibling: PTree read fNext;\r
    {* Returns next node in a list of children of the Parent. Nil is returned,\r
       if given node is the last child of the Parent or has no Parent at all. }\r
    property Root: PTree read GetRoot;\r
    {* Returns root node (i.e. the last Parent, enumerating parents recursively). }\r
    property Level: Integer read GetLevel;\r
    {* Returns level of the node, i.e. integer value, equal to 0 for root\r
       of a tree, 1 for its children, etc. }\r
    property Total: Integer read GetTotal;\r
    {* Returns total number of children of the node and all its children\r
       counting its recursively (but node itself is not considered, i.e.\r
       Total for node without children is equal to 0). }\r
    procedure SortByName;\r
    {* Sorts children of the node in ascending order. Sorting is not\r
       recursive, i.e. only immediate children are sorted. }\r
    procedure SwapNodes( i1, i2: Integer );\r
    {* Swaps two child nodes. }\r
    function IsParentOfNode( Node: PTree ): Boolean;\r
    {* Returns true, if Node is the tree itself or is a parent of the given node\r
       on any level. }\r
    function IndexOf( Node: PTree ): Integer;\r
    {* Total index of the child node (on any level under this node). }\r
\r
  end;\r
//[END OF TTree DEFINITION]\r
\r
//[NewTree DECLARATION]\r
function NewTree( AParent: PTree; const AName: String ): PTree;\r
{* Constructs tree node, adding it to the end of children list of\r
   the AParent. If AParent is nil, new root tree node is created. }\r
\r
\r
\r
\r
\r
\r
\r
//[DummyObjProc, DummyObjProcParam DECLARATION]\r
procedure DummyObjProc( Sender: PObj );\r
procedure DummyObjProcParam( Sender: PObj; Param: Pointer );\r
\r
\r
\r
\r
{ --- threads --- }\r
//[THREADS]\r
\r
const\r
  ABOVE_NORMAL_PRIORITY_CLASS = $8000; // only for Windows 2K\r
  BELOW_NORMAL_PRIORITY_CLASS = $4000; // and higher !\r
\r
type\r
  {++}(*TThread = class;*){--}\r
  PThread = {-}^{+}TThread;\r
\r
  TThreadMethod = procedure of object;\r
  TThreadMethodEx = procedure( Sender: PThread; Param: Pointer ) of object;\r
\r
  TOnThreadExecute = function(Sender:PThread): Integer of object;\r
  {* Event to be called when Execute method is called for TThread }\r
\r
{ ---------------------------------------------------------------------\r
\r
                            TThread object\r
\r
---------------------------------------------------------------------- }\r
//[TThread DEFINITION]\r
  TThread = object(TObj)\r
  {* Thread object. It is possible not to derive Your own thread-based\r
     object, but instead create thread Suspended and assign event\r
     OnExecute. To create, use one of NewThread of NewThreadEx functions,\r
     or derive Your own descendant object and write creation function\r
     (or constructor) for it.\r
     |<br><br>\r
     Aknowledgements. Originally class ZThread was developed for XCL:\r
     |<br> * By: Tim Slusher : junior@nlcomm.com\r
     |<br> * Home: http://www.nlcomm.com/~junior\r
   }\r
  protected\r
    FSuspended,\r
    FTerminated: boolean;\r
    FHandle: THandle;\r
    FThreadId: DWORD;\r
    FOnSuspend: TObjectMethod;\r
    FOnResume: TOnEvent;\r
    FData : Pointer;\r
    FOnExecute : TOnThreadExecute;\r
    FMethod: TThreadMethod;\r
    FMethodEx: TThreadMethodEx;\r
    F_AutoFree: Boolean;\r
    function GetPriorityCls: Integer;\r
    function GetThrdPriority: Integer;\r
    procedure SetPriorityCls(Value: Integer);\r
    procedure SetThrdPriority(Value: Integer);\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
  public\r
    function Execute: integer; virtual;\r
    {* Executes thread. Do not call this method from another thread! (Even do\r
       not call this method at all!) Instead, use Resume.\r
       |<br>\r
       Note also that in contrast to VCL, it is not necessary to create your\r
       own descendant object from TThread and override Execute method. In KOL,\r
       it is sufficient to create an instance of TThread object (see NewThread,\r
       NewThreadEx, NewThreadAutoFree functions) and assign OnExecute event\r
       handler for it. }\r
    procedure Resume;\r
    {* Continues executing. It is necessary to make call for every\r
       nested Suspend. }\r
    procedure Suspend;\r
    {* Suspends thread until it will be resumed. Can be called from another\r
       thread or from the thread itself. }\r
    procedure Terminate;\r
    {* Terminates thread. }\r
    function WaitFor: Integer;\r
    {* Waits (infinitively) until thead will be finished. }\r
\r
    property Handle: THandle read FHandle;\r
    {* Thread handle. It is created immediately when object is created\r
       (using NewThread). }\r
    property Suspended: boolean read FSuspended;\r
    {* True, if suspended. }\r
    property Terminated: boolean read FTerminated;\r
    {* True, if terminated. }\r
    property ThreadId: DWORD read FThreadId;\r
    {* Thread id. }\r
    property PriorityClass: Integer read GetPriorityCls write SetPriorityCls;\r
    {* Thread priority class. One of following values: HIGH_PRIORITY_CLASS,\r
       IDLE_PRIORITY_CLASS, NORMAL_PRIORITY_CLASS, REALTIME_PRIORITY_CLASS. }\r
    property ThreadPriority: Integer read GetThrdPriority write SetThrdPriority;\r
    {* Thread priority value. One of following values: THREAD_PRIORITY_ABOVE_NORMAL,\r
       THREAD_PRIORITY_BELOW_NORMAL, THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_IDLE,\r
       THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_TIME_CRITICAL. }\r
    property Data : Pointer read FData write FData;\r
    {* Custom data pointer. Use it for Youe own purpose. }\r
\r
    property OnExecute: TOnThreadExecute read FOnExecute write FOnExecute;\r
    {* Is called, when Execute is starting. }\r
    property OnSuspend: TObjectMethod read FOnSuspend write FOnSuspend;\r
    {* Is called, when Suspend is performed. }\r
    property OnResume: TOnEvent read FOnResume write FOnResume;\r
    {* Is called, when resumed. }\r
    procedure Synchronize( Method: TThreadMethod );\r
    {* Call it to execute given method in main thread context. Applet variable\r
       must exist for that time. }\r
    procedure SynchronizeEx( Method: TThreadMethodEx; Param: Pointer );\r
    {* Call it to execute given method in main thread context, with a given\r
       parameter. Applet variable must exist for that time. Param must not be nil. }\r
    {$IFDEF USE_CONSTRUCTORS}\r
    constructor ThreadCreate;\r
    constructor ThreadCreateEx( const Proc: TOnThreadExecute );\r
    {$ENDIF USE_CONSTRUCTORS}\r
\r
    property AutoFree: Boolean read F_AutoFree write F_AutoFree;\r
    {* Set this property to true to provide automatic destroying of thread\r
       object when its executing is finished. }\r
  end;\r
//[END OF TThread DEFINITION]\r
\r
//[NewThread, NewThreadEx, NewThreadAutoFree, Global_Synchronized DECLARATIONS]\r
function NewThread: PThread;\r
{* Creates thread object (always suspended). After creating, set event\r
   OnExecute and perform Resume operation. }\r
\r
function NewThreadEx( const Proc: TOnThreadExecute ): PThread;\r
{* Creates thread object, assigns Proc to its OnExecute event and runs\r
   it. }\r
\r
function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread;\r
{* Creates thread object similar to NewThreadEx, but freeing automatically\r
   when executing of such thread finished. Be sure that a thread is resumed\r
   at least to provide its object keeper freeing. }\r
\r
var Global_Synchronized: procedure( Sender: PObj; Param: Pointer ) = DummyObjProcParam;\r
// It is not necessary to declare it as threadvar.\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- streams -- }\r
//[STREAMS]\r
\r
type\r
  TMoveMethod = ( spBegin, spCurrent, spEnd );\r
\r
  {++}(*TStream = class;*){--}\r
  PStream = {-}^{+}TStream;\r
\r
  PStreamMethods = ^TStreamMethods;\r
  TStreamMethods = Packed Record\r
    fSeek: function( Strm: PStream; MoveTo: Integer; MoveMethod: TMoveMethod ): DWORD;\r
    fGetSiz: function( Strm: PStream ): DWORD;\r
    fSetSiz: procedure( Strm: PStream; Value: DWORD );\r
    fRead: function( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
    fWrite: function( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
    fClose: procedure( Strm: PStream );\r
    fCustom: Pointer;\r
    fWait: procedure( Strm: PStream );\r
  end;\r
\r
  TStreamData = Packed Record\r
    fHandle: THandle;\r
    fCapacity, fSize, fPosition: DWORD;\r
    fThread: PThread;\r
  end;\r
\r
{ ---------------------------------------------------------------------\r
\r
                TStream - streaming objects incapsulation\r
\r
---------------------------------------------------------------------- }\r
//[TStream DEFINITION]\r
  TStream = object(TObj)\r
  {* Simple stream object. Can be opened for file, or as memory stream (see\r
     NewReadFileStream, NewWriteFileStream, NewMemoryStream, etc.). And, another\r
     type of streaming object can be derived (without inheriting new object\r
     type, just by writing another New...Stream method, which calls\r
     _NewStream and pass methods record to it). }\r
  protected\r
    fPMethods: PStreamMethods;\r
    fMethods: TStreamMethods;\r
    fMemory: Pointer;\r
    fData: TStreamData;\r
    fParam1, fParam2: DWORD; // parameters to use in thread\r
    function GetCapacity: DWORD;\r
    procedure SetCapacity(const Value: DWORD);\r
    function DoAsyncRead( Sender: PThread ): Integer;\r
    function DoAsyncWrite( Sender: PThread ): Integer;\r
    function DoAsyncSeek( Sender: PThread ): Integer;\r
  protected\r
    function GetFileStreamHandle: THandle;\r
    procedure SetPosition(Value: DWord);\r
    function GetPosition: DWord;\r
    function GetSize: DWord;\r
    procedure SetSize(NewSize: DWord);\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
  public\r
    function Read(var Buffer; Count: DWord): DWord;\r
    {* Reads Count bytes from a stream. Returns number of bytes read. }\r
    function Seek(MoveTo: Integer; MoveMethod: TMoveMethod): DWord;\r
    {* Allows to change current position or to obtain it. Property\r
       Position uses this method both for get and set position. }\r
    function Write(var Buffer; Count: DWord): DWord;\r
    {* Writes Count bytes from Buffer, starting from current position\r
       in a stream. Returns how much bytes are written. }\r
    function WriteStr( S: String ): DWORD;\r
    {* Writes string to the stream, not including ending #0. Exactly\r
       Length( S ) characters are written. }\r
    function WriteStrZ( S: String ): DWORD;\r
    {* Writes string, adding #0. Number of bytes written is returned. }\r
    function ReadStrZ: String;\r
    {* Reads string, finished by #0. After reading, current position in\r
       the stream is set to the byte, follows #0. }\r
    function ReadStr: String;\r
    {* Reads string, finished by #13, #10 or #13#10 symbols. Terminating symbols\r
       #13 and/or #10 are not added to the end of returned string though\r
       stream positioned follow it. }\r
    function WriteStrEx(S: String): DWord;\r
    {* Writes string S to stream, also saving its size for future use by\r
       ReadStrEx* functions. Returns number of actually written characters. }\r
    function ReadStrExVar(var S: String): DWord;\r
    {* Reads string from stream and assigns it to S.\r
       Returns number of actually read characters.\r
       Note:\r
         String must be written by using WriteStrEx function.\r
         Return value is count of characters READ, not the length of string. }\r
    function ReadStrEx: String;\r
    {* Reads string from stream and returns it. }\r
    function WriteStrPas( S: String ): DWORD;\r
    {* Writes a string in Pascal short string format - 1 byte length, then string\r
       itself without trailing #0 char. S parameter length should not exceed 255\r
       chars, rest chars are truncated while writing. Total amount of bytes\r
       written is returned. }\r
    function ReadStrPas: String;\r
    {* Reads 1 byte from a stream, then treat it as a length of following string\r
       which is read and returned. A purpose of this function is reading strings\r
       written using WriteStrPas. }\r
    property Size: DWord read GetSize write SetSize;\r
    {* Returns stream size. For some custom streams, can be slow\r
       operation, or even always return undefined value (-1 recommended). }\r
    property Position: DWord read GetPosition write SetPosition;\r
    {* Current position. }\r
\r
    property Memory: Pointer read fMemory;\r
    {* Only for memory stream. }\r
    property Handle: THandle read GetFileStreamHandle;\r
    {* Only for file stream. It is possible to check that Handle <>\r
       INVALID_HANDLE_VALUE to ensure that file stream is created OK. }\r
\r
    //---------- for asynchronous operations (using thread - not tested):\r
    procedure SeekAsync(MoveTo: Integer; MoveMethod: TMoveMethod);\r
    {* Changes current position asynchronously. To wait for finishing the\r
       operation, use method Wait. }\r
    procedure ReadAsync(var Buffer; Count: DWord);\r
    {* Reads Count bytes from a stream asynchronously. To wait finishing the\r
       operation, use method Wait. }\r
    procedure WriteAsync(var Buffer; Count: DWord);\r
    {* Writes Count bytes from Buffer, starting from current position\r
       in a stream - asynchronously. To wait finishing the operation,\r
       use method Wait. }\r
    function Busy: Boolean;\r
    {* Returns TRUE until finishing the last asynchronous operation\r
       started by calling SeekAsync, ReadAsync, WriteAsync methods. }\r
    procedure Wait;\r
    {* Waits for finishing the last asynchronous operation. }\r
\r
    property Methods: PStreamMethods read fPMethods;\r
    {* Pointer to TStreamMethods record. Useful to implement custom-defined\r
       streams, which can access its fCustom field, or even to change\r
       methods when necessary. }\r
    property Data: TStreamData read fData;\r
    {* Pointer to TStreamData record. Useful to implement custom-defined\r
    streams, which can access Data fields directly when implemented. }\r
\r
    property Capacity: DWORD read GetCapacity write SetCapacity;\r
    {* Amound of memory allocated for data (MemoryStream). }\r
\r
  end;\r
//[END OF TStream DEFINITION]\r
\r
//[_NewStream DECLARATION]\r
function _NewStream( const StreamMethods: TStreamMethods ): PStream;\r
{* Use this method only to define your own stream type. See also declared\r
   below (in KOL.pas) methods used to implement standard KOL streams. You can use it in\r
   your code to create streams, which are partially based on standard\r
   methods. }\r
\r
// Methods below are declared here to simplify creating your\r
// own streams with some methods standard and some non-standard\r
// together:\r
function SeekFileStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;\r
function GetSizeFileStream( Strm: PStream ): DWORD;\r
function ReadFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
function WriteFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
function WriteFileStreamEOF( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
procedure CloseFileStream( Strm: PStream );\r
function SeekMemStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;\r
function GetSizeMemStream( Strm: PStream ): DWORD;\r
procedure SetSizeMemStream( Strm: PStream; NewSize: DWORD );\r
function ReadMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
function WriteMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
procedure CloseMemStream( Strm: PStream );\r
procedure SetSizeFileStream( Strm: PStream; NewSize: DWORD );\r
\r
function DummyReadWrite( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
procedure DummySetSize( Strm: PStream; Value: DWORD );\r
procedure DummyStreamProc(Strm: PStream);\r
\r
\r
//[NewFileStream DECLARATION]\r
function NewFileStream( const FileName: String; Options: DWORD ): PStream;\r
{* Creates file stream for read and write. Exact set of open attributes\r
   should be passed through Options parameter (see FileCreate where those\r
   flags are listed). }\r
\r
function NewReadFileStream( const FileName: String ): PStream;\r
{* Creates file stream for read only. }\r
\r
function NewWriteFileStream( const FileName: String ): PStream;\r
{* Creates file stream for write only. Truncating of file (if needed)\r
   is provided automatically. }\r
\r
function NewReadWriteFileStream( const FileName: String ): PStream;\r
{* Creates stream for read and write file. To truncate file, if it is\r
   necessary, change Size property. }\r
\r
//[NewMemoryStream DECLARATION]\r
function NewMemoryStream: PStream;\r
{* Creates memory stream (read and write). }\r
\r
function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream;\r
{* Creates memory stream on base of existing memory. It is not possible\r
   to write out of top bound given by Size (i.e. memory can not be resized,\r
   or reallocated. When stream object is destroyed this memory is not freed. }\r
\r
//[Stream2Stream DECLARATION]\r
function Stream2Stream( Dst, Src: PStream; Count: DWORD ): DWORD;\r
{* Copies Count (or less, if the rest of Src is not sufficiently long)\r
   bytes from Src to Dst, but with optimizing in cases, when Src or/and\r
   Dst are memory streams (intermediate buffer is not allocated). }\r
function Stream2StreamEx( Dst, Src: PStream; Count: DWORD ): DWORD;\r
{* Copies Count bytes from Src to Dst, but without any optimization.\r
   Unlike Stream2Stream function, it can be applied to very large streams.\r
   See also Stream2StreamExBufSz. }\r
function Stream2StreamExBufSz( Dst, Src: PStream; Count, BufSz: DWORD ): DWORD;\r
{* Copies Count bytes from Src to Dst using buffer of given size, but without\r
   other optimizations.\r
   Unlike Stream2Stream function, it can be applied to very large streams }\r
\r
//[Resource2Stream DECLARATION]\r
function Resource2Stream( DestStrm : PStream; Inst : HInst;\r
                          ResName : PChar; ResType : PChar ): Integer;\r
{* Loads given resource to DestStrm. Useful for non-standard\r
   resources to load it into memory (use memory stream for such\r
   purpose). Use one of following resource types to pass as ResType:\r
   |<pre>\r
RT_ACCELERATOR  Accelerator table\r
RT_ANICURSOR    Animated cursor\r
RT_ANIICON      Animated icon\r
RT_BITMAP       Bitmap resource\r
RT_CURSOR       Hardware-dependent cursor resource\r
RT_DIALOG       Dialog box\r
RT_FONT         Font resource\r
RT_FONTDIR      Font directory resource\r
RT_GROUP_CURSOR Hardware-independent cursor resource\r
RT_GROUP_ICON   Hardware-independent icon resource\r
RT_ICON         Hardware-dependent icon resource\r
RT_MENU         Menu resource\r
RT_MESSAGETABLE Message-table entry\r
RT_RCDATA       Application-defined resource (raw data)\r
RT_STRING       String-table entry\r
RT_VERSION      Version resource\r
   |</pre>\r
   |<br>For example:\r
   !var MemStrm: PStream;\r
   !    JpgObj: PJpeg;\r
   !......\r
   ! MemStrm := NewMemoryStream;\r
   ! JpgObj := NewJpeg;\r
   !......\r
   ! Resource2Stream( MemStrm, hInstance, 'MYJPEG', RT_RCDATA );\r
   ! MemStrm.Position := 0;\r
   ! JpgObj.LoadFromStream( MemStrm );\r
   ! MemStrm.Free;\r
   !......\r
   }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
type\r
//[TBits DEFINITION]\r
  {++}(*TBits = class;*){--}\r
  PBits = {-}^{+}TBits;\r
  TBits = object( TObj )\r
  {* Variable-length bits array object. Created using function NewBits. See also\r
     |<a href="kol_pas.htm#Small bit arrays (max 32 bits in array)">\r
     Small bit arrays (max 32 bits in array)\r
     |</a>. }\r
  protected\r
    fList: PList;\r
    fCount: Integer;\r
    function GetBit(Idx: Integer): Boolean;\r
    function GetCapacity: Integer;\r
    function GetSize: Integer;\r
    procedure SetBit(Idx: Integer; const Value: Boolean);\r
    procedure SetCapacity(const Value: Integer);\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
    property Bits[ Idx: Integer ]: Boolean read GetBit write SetBit;\r
    {* }\r
    property Size: Integer read GetSize;\r
    {* Size in bytes of the array. To get know number of bits, use property Count. }\r
    property Count: Integer read fCount;\r
    {* Number of bits an the array. }\r
    property Capacity: Integer read GetCapacity write SetCapacity;\r
    {* Number of bytes allocated. Can be set before assigning bit values\r
       to improve performance (minimizing amount of memory allocation\r
       operations).  }\r
    function Copy( From, BitsCount: Integer ): PBits;\r
    {* Use this property to get a sub-range of bits starting from given bit\r
       and of BitsCount bits count. }\r
    function IndexOf( Value: Boolean ): Integer;\r
    {* Returns index of first bit with given value (True or False). }\r
    function OpenBit: Integer;\r
    {* Returns index of the first bit not set to true. }\r
    procedure Clear;\r
    {* Clears bits array. Count, Size and Capacity become 0. }\r
    function LoadFromStream( strm: PStream ): Integer;\r
    {* Loads bits from the stream. Data should be stored in the stream\r
       earlier using SaveToStream method. While loading, previous bits\r
       data are discarded and replaced with new one totally. In part,\r
       Count of bits also is changed. Count of bytes read from the stream\r
       while loading data is returned. }\r
    function SaveToStream( strm: PStream ): Integer;\r
    {* Saves entire array of bits to the stream. First, Count of bits\r
       in the array is saved, then all bytes containing bits data. }\r
    function Range( Idx, N: Integer ): PBits;\r
    {* Creates and returns new TBits object instance containing N bits\r
       starting from index Idx. If you call this method, you are responsible\r
       for destroying returned object when it become not neccessary. }\r
    procedure AssignBits( ToIdx: Integer; FromBits: PBits; FromIdx, N: Integer );\r
    {* Assigns bits from another bits array object. N bits are assigned\r
       starting at index ToIdx. }\r
  end;\r
//[END OF TBits DEFINITION]\r
\r
//[NewBits DECLARATION]\r
function NewBits: PBits;\r
{* Creates variable-length bits array object. }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- string list objects -- }\r
//[TStrList]\r
\r
type\r
  {++}(*TStrList = class;*){--}\r
  PStrList = {-}^{+}TStrList;\r
{ ---------------------------------------------------------------------\r
\r
                TStrList - string list\r
\r
---------------------------------------------------------------------- }\r
//[TStrList DEFINITION]\r
  TStrList = object(TObj)\r
  {* Easy string list implementation (non-visual, just to store\r
     string data). It is well improved and has very high performance\r
     allowing to work fast with huge text files (more then megabyte\r
     of text data).\r
     |\r
     Please note that #0 charaster if stored in string lines, will cut it\r
     preventing reading the rest of a line. Be careful, if your data\r
     contain such characters. }\r
  protected\r
    procedure Init; virtual;\r
  protected\r
    fList: PList;\r
    fCount: Integer;\r
    fCaseSensitiveSort: Boolean;\r
    fTextBuf: PChar;\r
    fTextSiz: DWORD;\r
    function GetPChars(Idx: Integer): PChar;\r
    //procedure AddTextBuf( Src: PChar; Len: DWORD );\r
  protected\r
    function Get(Idx: integer): string;\r
    function GetTextStr: string;\r
    procedure Put(Idx: integer; const Value: string);\r
    procedure SetTextStr(const Value: string);\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
  protected\r
    // by Dod:\r
    procedure SetValue(const Name, Value: string);\r
    function GetValue(const Name: string): string;\r
  public\r
    // by Dod:\r
    function IndexOfName(Name: string): Integer;\r
    {* by Dod. Returns index of line starting like Name=... }\r
    property Values[const Name: string]: string read GetValue write SetValue;\r
    {* by Dod. Returns right side of a line starting like Name=... }\r
  public\r
    function Add(const S: string): integer;\r
    {* Adds a string to list. }\r
    procedure AddStrings(Strings: PStrList);\r
    {* Merges string list with given one. Very fast - more preferrable to\r
       use than any loop with calling Add method. }\r
    procedure Assign(Strings: PStrList);\r
    {* Fills string list with strings from other one. The same as AddStrings,\r
       but Clear is called first. }\r
    procedure Clear;\r
    {* Makes string list empty. }\r
    procedure Delete(Idx: integer);\r
    {* Deletes string with given index (it *must* exist). }\r
    function IndexOf(const S: string): integer;\r
    {* Returns index of first string, equal to given one. }\r
    function IndexOf_NoCase(const S: string): integer;\r
    {* Returns index of first string, equal to given one (while comparing it\r
       without case sensitivity). }\r
    function IndexOfStrL_NoCase( Str: PChar; L: Integer ): integer;\r
    {* Returns index of first string, equal to given one (while comparing it\r
       without case sensitivity). }\r
    function Find(const S: String; var Index: Integer): Boolean;\r
    {* Returns Index of the first string, equal or greater to given pattern, but\r
       works only for sorted TStrList object. Returns TRUE if exact string found,\r
       otherwise nearest (greater then a pattern) string index is returned,\r
       and the result is FALSE. }\r
    procedure Insert(Idx: integer; const S: string);\r
    {* Inserts string before one with given index. }\r
    function LoadFromFile(const FileName: string): Boolean;\r
    {* Loads string list from a file. (If file does not exist, nothing\r
       happens). Very fast even for huge text files. }\r
    procedure LoadFromStream(Stream: PStream; Append2List: boolean);\r
    {* Loads string list from a stream (from current position to the end of\r
       a stream). Very fast even for huge text. }\r
    procedure MergeFromFile(const FileName: string);\r
    {* Merges string list with strings in a file. Fast. }\r
    procedure Move(CurIndex, NewIndex: integer);\r
    {* Moves string to another location. }\r
    procedure SetText(const S: string; Append2List: boolean);\r
    {* Allows to set strings of string list from given string (in which\r
       strings are separated by $0D,$0A or $0D characters). Text must not\r
       contain #0 characters. Works very fast. This method is used in\r
       all others, working with text arrays (LoadFromFile, MergeFromFile,\r
       Assign, AddStrings). }\r
    procedure SetUnixText( const S: String; Append2List: Boolean );\r
    {* Allows to assign UNIX-style text (with #10 as string separator). }\r
    function SaveToFile(const FileName: string): Boolean;\r
    {* Stores string list to a file. }\r
    procedure SaveToStream(Stream: PStream);\r
    {* Saves string list to a stream (from current position). }\r
    function AppendToFile(const FileName: string): Boolean;\r
    {* Appends strings of string list to the end of a file. }\r
    property Count: integer read fCount;\r
    {* Number of strings in a string list. }\r
    property Items[Idx: integer]: string read Get write Put; default;\r
    {* Strings array items. If item does not exist, empty string is returned.\r
       But for assign to property, string with given index *must* exist. }\r
    property ItemPtrs[ Idx: Integer ]: PChar read GetPChars;\r
    {* Fast access to item strings as PChars. }\r
    function Last: String;\r
    {* Last item (or '', if string list is empty). }\r
    property Text: string read GetTextStr write SetTextStr;\r
    {* Content of string list as a single string (where strings are separated\r
       by characters $0D,$0A). }\r
    procedure Swap( Idx1, Idx2 : Integer );\r
    {* Swaps to strings with given indeces. }\r
    procedure Sort( CaseSensitive: Boolean );\r
    {* Call it to sort string list. }\r
    procedure AnsiSort( CaseSensitive: Boolean );\r
    {* Call it to sort ANSI string list. }\r
\r
    // by Alexander Pravdin:\r
  protected\r
    fNameDelim: Char;\r
    function GetLineName( Idx: Integer ): string;\r
    procedure SetLineName( Idx: Integer; const NV: string );\r
    function GetLineValue(Idx: Integer): string;\r
    procedure SetLineValue(Idx: Integer; const Value: string);\r
  public\r
    property LineName[ Idx: Integer ]: string read GetLineName write SetLineName;\r
    property LineValue[ Idx: Integer ]: string read GetLineValue write SetLineValue;\r
    property NameDelimiter: Char read fNameDelim write fNameDelim;\r
  end;\r
//[END OF TStrList DEFINITION]\r
\r
//[DefaultNameDelimiter]\r
var DefaultNameDelimiter: Char = '=';\r
\r
//[NewStrList DECLARATION]\r
function NewStrList: PStrList;\r
{* Creates string list object. }\r
\r
function  GetFileList(const dir: string): PStrList;\r
{* By Alexander Shakhaylo. Returns list of file names of the given directory. }\r
\r
\r
\r
\r
//[TStrListEx]\r
type\r
  {++}(*TStrListEx = class;*){--}\r
  PStrListEx = {-}^{+}TStrListEx;\r
\r
//[TStrListEx DEFINITION]\r
  TStrListEx = object( TStrList )\r
  {* Extended string list object. Has additional capability to associate\r
     numbers or objects with string list items. }\r
  protected\r
    FObjects: PList;\r
    function GetObjects(Idx: Integer): DWORD;\r
    procedure SetObjects(Idx: Integer; const Value: DWORD);\r
    procedure Init; {-}virtual;{+}{++}(*override;*){--}\r
    procedure ProvideObjCapacity( NewCap: Integer );\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
    property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects;\r
    {* Objects are just 32-bit values. You can treat and use it as pointers to\r
       any other data in the memory. But it is your task to free allocated\r
       memory in such case therefore. }\r
    procedure AddStrings(Strings: PStrListEx);\r
    {* Merges string list with given one. Very fast - more preferrable to\r
       use than any loop with calling Add method. }\r
    procedure Assign(Strings: PStrListEx);\r
    {* Fills string list with strings from other one. The same as AddStrings,\r
       but Clear is called first. }\r
    procedure Clear;\r
    {* Makes string list empty. }\r
    procedure Delete(Idx: integer);\r
    {* Deletes string with given index (it *must* exist). }\r
    procedure Move(CurIndex, NewIndex: integer);\r
    {* Moves string to another location. }\r
    procedure Swap( Idx1, Idx2 : Integer );\r
    {* Swaps to strings with given indeces. }\r
    procedure Sort( CaseSensitive: Boolean );\r
    {* Call it to sort string list. }\r
    procedure AnsiSort( CaseSensitive: Boolean );\r
    {* Call it to sort ANSI string list. }\r
    function LastObj: DWORD;\r
    {* Object assotiated with the last string. }\r
    function AddObject( const S: String; Obj: DWORD ): Integer;\r
    {* Adds a string and associates given number with it. Index of the item added\r
       is returned. }\r
    procedure InsertObject( Before: Integer; const S: String; Obj: DWORD );\r
    {* Inserts a string together with object associated. }\r
    function IndexOfObj( Obj: Pointer ): Integer;\r
    {* Returns an index of a string associated with the object passed as a\r
       parameter. If there are no such strings, -1 is returned. }\r
  end;\r
//[END OF TStrListEx DEFINITION]\r
\r
//[NewStrListEx DECLARATION]\r
function NewStrListEx: PStrListEx;\r
{* Creates extended string list object. }\r
\r
\r
\r
\r
\r
//[TWStrList]\r
\r
{-}\r
{$IFNDEF _D2} //------------------ WideString is not supported in D2 -----------\r
\r
type\r
  PWStrList = ^TWstrList;\r
  {* }\r
//[TWstrList DEFINITION]\r
  TWStrList = object( TObj )\r
  {* String list to store Unicode (null-terminated) strings. }\r
  protected\r
    function GetCount: Integer;\r
    function GetItems(Idx: Integer): WideString;\r
    procedure SetItems(Idx: Integer; const Value: WideString);\r
    function GetPtrs(Idx: Integer): PWideChar;\r
    function GetText: WideString;\r
  protected\r
    fList: PList;\r
    fText: PWideChar;\r
    fTextBufSz: Integer;\r
    fTmp1, fTmp2: WideString;\r
    procedure Init; virtual;\r
  public\r
    procedure SetText(const Value: WideString);\r
    {* See also TStrList.SetText }\r
    destructor Destroy; virtual;\r
    {* }\r
    procedure Clear;\r
    {* See also TStrList.Clear }\r
    property Items[ Idx: Integer ]: WideString read GetItems write SetItems;\r
    {* See also TStrList.Items }\r
    property ItemPtrs[ Idx: Integer ]: PWideChar read GetPtrs;\r
    {* See also TStrList.ItemPtrs }\r
    property Count: Integer read GetCount;\r
    {* See also TStrList.Count }\r
    function Add( const W: WideString ): Integer;\r
    {* See also TStrList.Add }\r
    procedure Insert( Idx: Integer; const W: WideString );\r
    {* See also TStrList.Insert }\r
    procedure Delete( Idx: Integer );\r
    {* See also TStrList.Delete }\r
    property Text: WideString read GetText write SetText;\r
    {* See also TStrList.Text }\r
    procedure AddWStrings( WL: PWStrList );\r
    {* See also TStrList.AddStrings }\r
    procedure Assign( WL: PWStrList );\r
    {* See also TStrList.Assign }\r
    function LoadFromFile( const Filename: String ): Boolean;\r
    {* See also TStrList.LoadFromFile }\r
    procedure LoadFromStream( Strm: PStream );\r
    {* See also TStrList.LoadFromStream }\r
    function MergeFromFile( const Filename: String ): Boolean;\r
    {* See also TStrList.MergeFromFile }\r
    procedure MergeFromStream( Strm: PStream );\r
    {* See also TStrList.MergeFromStream }\r
    function SaveToFile( const Filename: String ): Boolean;\r
    {* See also TStrList.SaveToFile }\r
    procedure SaveToStream( Strm: PStream );\r
    {* See also TStrList.SaveToStream }\r
    function AppendToFile( const Filename: String ): Boolean;\r
    {* See also TStrList.AppendToFile }\r
    procedure Swap( Idx1, Idx2: Integer );\r
    {* See also TStrList.Swap }\r
    procedure Sort( CaseSensitive: Boolean );\r
    {* See also TStrList.Sort }\r
    procedure Move( IdxOld, IdxNew: Integer );\r
    {* See also TStrList.Move }\r
  end;\r
//[END OF TWStrList DEFINITION]\r
\r
//[TWStrListEx]\r
  PWStrListEx = ^TWStrListEx;\r
\r
//[TWStrListEx DEFINITION]\r
  TWStrListEx = object( TWStrList )\r
  {* Extended Unicode string list (with Objects). }\r
  protected\r
    function GetObjects(Idx: Integer): DWORD;\r
    procedure SetObjects(Idx: Integer; const Value: DWORD);\r
    procedure ProvideObjectsCapacity( NewCap: Integer );\r
  protected\r
    fObjects: PList;\r
    procedure Init; virtual;\r
  public\r
    destructor Destroy; virtual;\r
    {* }\r
    property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects;\r
    {* }\r
    procedure AddWStrings( WL: PWStrListEx );\r
    {* }\r
    procedure Assign( WL: PWStrListEx );\r
    {* }\r
    procedure Clear;\r
    {* }\r
    procedure Delete( Idx: Integer );\r
    {* }\r
    procedure Move( IdxOld, IdxNew: Integer );\r
    {* }\r
    function AddObject( const S: WideString; Obj: DWORD ): Integer;\r
    {* Adds a string and associates given number with it. Index of the item added\r
       is returned. }\r
    procedure InsertObject( Before: Integer; const S: WideString; Obj: DWORD );\r
    {* Inserts a string together with object associated. }\r
    function IndexOfObj( Obj: Pointer ): Integer;\r
    {* Returns an index of a string associated with the object passed as a\r
       parameter. If there are no such strings, -1 is returned. }\r
  end;\r
//[END OF TWStrListEx DEFINITION]\r
\r
//[NewWStrList DECLARATION]\r
function NewWStrList: PWStrList;\r
{* Creates new TWStrList object and returns a pointer to it. }\r
\r
//[NewWStrListEx DECLARATION]\r
function NewWStrListEx: PWStrListEx;\r
{* Creates new TWStrListEx objects and returns a pointer to it. }\r
\r
{$ENDIF}\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{+}\r
////////////////////////////////////////////////////////////////////////////////\r
//                            GRAPHIC OBJECTS                                 //\r
////////////////////////////////////////////////////////////////////////////////\r
//[GRAPHIC OBJECTS]\r
{\r
  It is very important, that the most of code, implementing graphic objets\r
  from this section, is included into executable ONLY if really accessed in your\r
  project directly (e.g., if Font or Brush properies of a control are accessed\r
  or changed).\r
}\r
type\r
  TColor = Integer;\r
\r
const\r
//[COLOR CONSTANTS]\r
  clScrollBar = TColor(COLOR_SCROLLBAR or $80000000);\r
  clBackground = TColor(COLOR_BACKGROUND or $80000000);\r
  clActiveCaption = TColor(COLOR_ACTIVECAPTION or $80000000);\r
  clInactiveCaption = TColor(COLOR_INACTIVECAPTION or $80000000);\r
  clMenu = TColor(COLOR_MENU or $80000000);\r
  clWindow = TColor(COLOR_WINDOW or $80000000);\r
  clWindowFrame = TColor(COLOR_WINDOWFRAME or $80000000);\r
  clMenuText = TColor(COLOR_MENUTEXT or $80000000);\r
  clWindowText = TColor(COLOR_WINDOWTEXT or $80000000);\r
  clCaptionText = TColor(COLOR_CAPTIONTEXT or $80000000);\r
  clActiveBorder = TColor(COLOR_ACTIVEBORDER or $80000000);\r
  clInactiveBorder = TColor(COLOR_INACTIVEBORDER or $80000000);\r
  clAppWorkSpace = TColor(COLOR_APPWORKSPACE or $80000000);\r
  clHighlight = TColor(COLOR_HIGHLIGHT or $80000000);\r
  clHighlightText = TColor(COLOR_HIGHLIGHTTEXT or $80000000);\r
  clBtnFace = TColor(COLOR_BTNFACE or $80000000);\r
  clBtnShadow = TColor(COLOR_BTNSHADOW or $80000000);\r
  clGrayText = TColor(COLOR_GRAYTEXT or $80000000);\r
  clBtnText = TColor(COLOR_BTNTEXT or $80000000);\r
  clInactiveCaptionText = TColor(COLOR_INACTIVECAPTIONTEXT or $80000000);\r
  clBtnHighlight = TColor(COLOR_BTNHIGHLIGHT or $80000000);\r
  cl3DDkShadow = TColor(COLOR_3DDKSHADOW or $80000000);\r
  cl3DLight = TColor(COLOR_3DLIGHT or $80000000);\r
  clInfoText = TColor(COLOR_INFOTEXT or $80000000);\r
  clInfoBk = TColor(COLOR_INFOBK or $80000000);\r
\r
  clBlack = TColor($000000);\r
  clMaroon = TColor($000080);\r
  clGreen = TColor($008000);\r
  clOlive = TColor($008080);\r
  clNavy = TColor($800000);\r
  clPurple = TColor($800080);\r
  clTeal = TColor($808000);\r
  clGray = TColor($808080);\r
  clSilver = TColor($C0C0C0);\r
  clRed = TColor($0000FF);\r
  clLime = TColor($00FF00);\r
  clYellow = TColor($00FFFF);\r
  clBlue = TColor($FF0000);\r
  clFuchsia = TColor($FF00FF);\r
  clAqua = TColor($FFFF00);\r
  clLtGray = TColor($C0C0C0);\r
  clDkGray = TColor($808080);\r
  clWhite = TColor($FFFFFF);\r
  clNone = TColor($1FFFFFFF);\r
  clDefault = TColor($20000000);\r
\r
  clMoneyGreen = TColor($C0DCC0);\r
  clSkyBlue = TColor($F0CAA6);\r
  clCream = TColor($F0FBFF);\r
  clMedGray = TColor($A4A0A0);\r
//[END OF COLOR CONSTANTS]\r
\r
const\r
//[TGraphicTool FIELD OFFSET CONSTANTS]\r
  go_Color                 = 0;\r
  go_FontHeight            = 4;\r
  go_FontWidth             = 8;\r
  go_FontEscapement        = 12;\r
  go_FontOrientation       = 16;\r
  go_FontWeight            = 20;\r
  go_FontItalic            = 24;\r
  go_FontUnderline         = 25;\r
  go_FontStrikeOut         = 26;\r
  go_FontCharSet           = 27;\r
  go_FontOutPrecision      = 28;\r
  go_FontClipPrecision     = 29;\r
  go_FontQuality           = 30;\r
  go_FontPitch             = 31;\r
  go_FontName              = 32;\r
  go_BrushBitmap           = 4;\r
  go_BrushStyle            = 8;\r
  go_BrushLineColor        = 9;\r
  go_PenBrushBitmap        = 4;\r
  go_PenBrushStyle         = 8;\r
  go_PenStyle              = 9;\r
  go_PenWidth              = 10;\r
  go_PenMode               = 14;\r
  go_PenGeometric          = 15;\r
  go_PenEndCap             = 16;\r
  go_PenJoin               = 17;\r
//[END OF TGraphicTool FIELD OFFSET CONSTANTS]\r
\r
//[TGraphicTool]\r
type\r
   TGraphicToolType = ( gttBrush, gttFont, gttPen );\r
   {* Graphic object types, mainly for internal use. }\r
\r
   {++}(*TGraphicTool = class;*){--}\r
   PGraphicTool = {-}^{+}TGraphicTool;\r
   {* }\r
   TOnGraphicChange = procedure ( Sender: PGraphicTool ) of object;\r
   {* An event mainly for internal use. }\r
\r
   TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,\r
    bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);\r
   {* Available brush styles. }\r
\r
   TFontStyles = (fsBold, fsItalic, fsUnderline, fsStrikeOut);\r
   {* Available font styles. }\r
   TFontStyle = set of TFontStyles;\r
   {* Font style is representing as a set of XFontStyles. }\r
   TFontPitch = (fpDefault, fpFixed, fpVariable);\r
   {* Availabe font pitch values. }\r
   TFontName = type string;\r
   {* Font name is represented as a string. }\r
   TFontCharset = 0..255;\r
   {* Font charset is represented by number from 0 to 255. }\r
   TFontQuality = (fqDefault, fqDraft, fqProof, fqNonAntialiased, fqAntialiased);\r
   {* Font quality. }\r
\r
   TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,\r
    psInsideFrame);\r
   {* Available pen styles. For more info see Delphi or Win32 help files. }\r
   TPenMode = (pmBlack, pmNotMerge, pmMaskNotPen, pmNotCopy, pmMaskPenNot,\r
               pmNot, pmXor, pmNotMask, pmMask, pmNotXor, pmNop, pmMergePenNot,\r
               pmCopy, pmMergeNotPen, pmMerge, pmWhite);\r
   {* Available pen modes. For more info see Delphi or Win32 help files. }\r
   TPenEndCap = (pecRound, pecSquare, pecFlat);\r
   {* Avalable (for geometric pen) end cap styles. }\r
   TPenJoin = (pjRound, pjBevel, pjMiter);\r
   {* Available (for geometric pen) join styles. }\r
\r
//[TGdiFont]\r
   TGDIFont = packed record\r
     Height: Integer;\r
     Width: Integer;\r
     Escapement: Integer;\r
     Orientation: Integer;\r
     Weight: Integer;\r
     Italic: Boolean;\r
     Underline: Boolean;\r
     StrikeOut: Boolean;\r
     CharSet: TFontCharset;\r
     OutPrecision: Byte;\r
     ClipPrecision: Byte;\r
     Quality: TFontQuality;\r
     Pitch: TFontPitch;\r
     Name: array[0..LF_FACESIZE - 1] of Char;\r
   end;\r
\r
//[TGDIBrush]\r
   TGDIBrush = packed record\r
     Bitmap: HBitmap;\r
     Style: TBrushStyle;\r
     LineColor: TColor;\r
   end;\r
\r
//[TGDIPen]\r
   TGDIPen = packed record\r
     BrushBitmap: HBitmap;\r
     BrushStyle: TBrushStyle;\r
     Style: TPenStyle;\r
     Width: Integer;\r
     Mode: TPenMode;\r
     Geometric: Boolean;\r
     EndCap: TPenEndCap;\r
     Join: TPenJoin;\r
   end;\r
\r
//[TGDIToolData]\r
   TGDIToolData = packed record\r
     Color: TColor;\r
     case Integer of\r
     1: (Font: TGDIFont);\r
     2: (Pen: TGDIPen);\r
     3: (Brush: TGDIBrush);\r
   end;\r
\r
//[TNewGraphicTool]\r
   TNewGraphicTool = function: PGraphicTool;\r
\r
{ ---------------------------------------------------------------------\r
\r
     TGraphicTool - object to implement GDI-tools (brush, pen, font)\r
\r
---------------------------------------------------------------------- }\r
//[TGraphicTool DEFINITION]\r
  TGraphicTool = object( TObj )\r
  {* Incapsulates all GDI objects: Pen, Brush and Font. }\r
  protected\r
    fType: TGraphicToolType;\r
    fHandle: THandle;\r
    fParentGDITool: PGraphicTool;\r
    fOnChange: TOnGraphicChange;\r
    fColorRGB: TColor;\r
    fData: TGDIToolData;\r
\r
    fNewProc: TNewGraphicTool;\r
    fMakeHandleProc: function( Self_: PGraphicTool ): THandle;\r
\r
    procedure SetInt( const Index: Integer; Value: Integer );\r
    {$IFDEF F_P}\r
    function GetInt( const Index: Integer ): Integer;\r
    {$ENDIF}\r
    procedure SetColor( Value: TColor );\r
    procedure SetBrushBitmap(const Value: HBitmap);\r
    procedure SetBrushStyle(const Value: TBrushStyle);\r
    procedure SetFontCharset(const Value: TFontCharset);\r
    procedure SetFontQuality(const Value: TFontQuality);\r
    function GetFontName: String;\r
    procedure SetFontName(const Value: String);\r
    procedure SetFontOrientation(Value: Integer);\r
    procedure SetFontPitch(const Value: TFontPitch);\r
    function GetFontStyle: TFontStyle;\r
    procedure SetFontStyle(const Value: TFontStyle);\r
    procedure SetPenMode(const Value: TPenMode);\r
    procedure SetPenStyle(const Value: TPenStyle);\r
    procedure SetGeometricPen(const Value: Boolean);\r
    procedure SetPenEndCap(const Value: TPenEndCap);\r
    procedure SetPenJoin(const Value: TPenJoin);\r
    procedure SetFontWeight(const Value: Integer);\r
    procedure SetLogFontStruct(const Value: TLogFont);\r
    function GetLogFontStruct: TLogFont;\r
  protected\r
    procedure Changed;\r
    {* }\r
    function GetHandle: THandle;\r
    {* }\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
    property Handle: THandle read GetHandle;\r
    {* Every time, when accessed, real GDI object is created (if it is\r
       not yet created). So, to prevent creating of the handle, use\r
       HandleAllocated instead of comparing Handle with value 0. }\r
    function HandleAllocated: Boolean;\r
    {* Returns True, if handle is allocated (i.e., if real GDI\r
       objet is created. }\r
    property OnChange: TOnGraphicChange read fOnChange write fOnChange;\r
    {* Called, when object is changed. }\r
    function ReleaseHandle: Integer;\r
    {* Returns Handle value (if allocated), releasing it from the\r
       object (so, it is no more knows about this handle and its\r
       HandleAllocated function returns False. }\r
    property Color: TColor {index go_Color} read fData.Color write SetColor;\r
    {* Color is the most common property for all Pen, Brush and\r
       Font objects, so it is placed in its common for all of them. }\r
    function Assign( Value: PGraphicTool ): PGraphicTool;\r
    {* Assigns properties of the same (only) type graphic object,\r
       excluding Handle. If assigning is really leading to change\r
       object, procedure Changed is called. }\r
    procedure AssignHandle( NewHandle: Integer );\r
    {* Assigns value to Handle property. }\r
\r
    property BrushBitmap: HBitmap read fData.Brush.Bitmap write SetBrushBitmap;\r
    {* Brush bitmap. For more info about using brush bitmap,\r
       see Delphi or Win32 help files. }\r
    property BrushStyle: TBrushStyle read fData.Brush.Style write SetBrushStyle;\r
    {* Brush style. }\r
    property BrushLineColor: TColor index go_BrushLineColor\r
             {$IFDEF F_P}\r
             read GetInt\r
             {$ELSE DELPHI}\r
             read fData.Brush.LineColor\r
             {$ENDIF F_P/DELPHI}\r
             write SetInt;\r
    {* Brush line color, used to represent lines in hatched brush. Default value is clBlack. }\r
\r
    property FontHeight: Integer index go_FontHeight\r
             {$IFDEF F_P}\r
             read GetInt\r
             {$ELSE DELPHI}\r
             read fData.Font.Height\r
             {$ENDIF F_P/DELPHI}\r
             write SetInt;\r
    {* Font height. Value 0 (default) seys to use system default value,\r
       negative values are to represent font height in "points", positive\r
       - in pixels. In XCL usually positive values (if not 0) are used to\r
       make appearance independent from different local settings. }\r
    property FontWidth: Integer index go_FontWidth\r
             {$IFDEF F_P}\r
             read GetInt\r
             {$ELSE DELPHI}\r
             read fData.Font.Width\r
             {$ENDIF F_P/DELPHI}\r
             write SetInt;\r
    {* Font width in logical units. If FontWidth = 0, then as it is said\r
       in Win32.hlp, "the aspect ratio of the device is matched against the\r
       digitization aspect ratio of the available fonts to find the closest match,\r
       determined by the absolute value of the difference." }\r
    property FontPitch: TFontPitch read fData.Font.Pitch write SetFontPitch;\r
    {* Font pitch. Change it very rare. }\r
    property FontStyle: TFontStyle read GetFontStyle write SetFontStyle;\r
    {* Very useful property to control text appearance. }\r
    property FontCharset: TFontCharset read fData.Font.Charset write SetFontCharset;\r
    {* Do not change it if You do not know what You do. }\r
    property FontQuality: TFontQuality read fData.Font.Quality write SetFontQuality;\r
    {* Font quality. }\r
    property FontOrientation: Integer read fData.Font.Orientation write SetFontOrientation;\r
    {* It is possible to rotate text in XCL just by changing this\r
       property of a font (tenths of degree, i.e. value 900 represents\r
       90 degree - text written from bottom to top). }\r
    property FontWeight: Integer read fData.Font.Weight write SetFontWeight;\r
    {* Additional font weight for bold fonts (must be 0..1000). When set to\r
       value <> 0, fsBold is added to FontStyle. And otherwise, when set to 0,\r
       fsBold is removed from FontStyle. Value 700 corresponds to Bold,\r
       400 to Normal. }\r
    property FontName: String read GetFontName write SetFontName;\r
    {* Font face name. }\r
    function IsFontTrueType: Boolean;\r
    {* Returns True, if font is True Type. Requires of creating of a Handle,\r
       if it is not yet created. }\r
\r
    property PenWidth: Integer index go_PenWidth\r
             {$IFDEF F_P}\r
             read GetInt\r
             {$ELSE DELPHI}\r
             read fData.Pen.Width\r
             {$ENDIF F_P/DELPHI}\r
             write SetInt;\r
    {* Value 0 means default pen width. }\r
    property PenStyle: TPenStyle read fData.Pen.Style write SetPenStyle;\r
    {* Pen style. }\r
    property PenMode: TPenMode read fData.Pen.Mode write SetPenMode;\r
    {* Pen mode. }\r
\r
    property GeometricPen: Boolean read fData.Pen.Geometric write SetGeometricPen;\r
    {* True if Pen is geometric. Note, that under Win95/98 only pen styles\r
       psSolid, psNull, psInsideFrame are supported by OS. }\r
    property PenBrushStyle: TBrushStyle read fData.Pen.BrushStyle write SetBrushStyle;\r
    {* Brush style for hatched geometric pen. }\r
    property PenBrushBitmap: HBitmap read fData.Pen.BrushBitmap write SetBrushBitmap;\r
    {* Brush bitmap for geometric pen (if assigned Pen is functioning as\r
       its style = BS_PATTERN, regadless of PenBrushStyle value). }\r
    property PenEndCap: TPenEndCap read fData.Pen.EndCap write SetPenEndCap;\r
    {* Pen end cap mode - for GeometricPen only. }\r
    property PenJoin: TPenJoin read fData.Pen.Join write SetPenJoin;\r
    {* Pen join mode - for GeometricPen only. }\r
    property LogFontStruct: TLogFont read GetLogFontStruct write SetLogFontStruct;\r
    {* by Alex Pravdin: a property to change all font structure items at once. }\r
  end;\r
//[END OF TGraphicTool DEFINITION]\r
\r
//[Color2XXX FUNCTIONS]\r
function Color2RGB( Color: TColor ): TColor;\r
{* Function to get RGB color from system color. Parameter can be also RGB\r
   color, in that case result is just equal to a parameter. }\r
function ColorsMix( Color1, Color2: TColor ): TColor;\r
{* Returns color, which RGB components are build as an (approximate)\r
   arithmetic mean of correspondent RGB components of both source\r
   colors (these both are first converted from system to RGB, and\r
   result is always RGB color). Please note: this function is fast,\r
   but can be not too exact. }\r
function Color2RGBQuad( Color: TColor ): TRGBQuad;\r
{* Converts color to RGB, used to represent RGB values in palette entries\r
   (actually swaps R and B bytes). }\r
function Color2Color16( Color: TColor ): WORD;\r
{* Converts Color to RGB, packed to word (as it is used in format pf16bit). }\r
\r
//[DefFont VARIABLE]\r
var    // New TFont instances are intialized with the values in this structure:\r
  DefFont: TGDIFont = (\r
     Height: 0;\r
     Width: 0;\r
     Escapement: 0;\r
     Orientation: 0;\r
     Weight: 0;\r
     Italic: FALSE;\r
     Underline: FALSE;\r
     StrikeOut: FALSE;\r
     CharSet: 1;\r
     OutPrecision: 0;\r
     ClipPrecision: 0;\r
     Quality: fqDefault;\r
     Pitch: fpDefault;\r
     Name: 'MS Sans Serif';\r
  );\r
  DefFontColor: TColor = clWindowText;\r
  {* Default font color. }\r
\r
//[GlobalGraphics_UseFontOrient]\r
  GlobalGraphics_UseFontOrient: Boolean;\r
  {* Global flag. If stays False (default), Orientation property of Font\r
     objects is ignored. This flag is set to True automatically in\r
     RotateFonts add-on. }\r
\r
{ -- Constructors for different GDI tools -- }\r
\r
//[New FUNCTIONS FOR TGraphicTool]\r
function NewFont: PGraphicTool;\r
{* Creates and returns font graphic tool object. }\r
function NewBrush: PGraphicTool;\r
{* Creates and returns new brush object. }\r
function NewPen: PGraphicTool;\r
{* Creates and returns new pen object. }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- TCanvas object -- }\r
//[TCanvas]\r
const\r
  HandleValid = 1;\r
  PenValid    = 2;\r
  BrushValid  = 4;\r
  FontValid   = 8;\r
  ChangingCanvas = 16;\r
\r
type\r
   TFillStyle = (fsSurface, fsBorder);\r
   {* Available filling styles. For more info see Win32 or Delphi help files. }\r
   TFillMode = (fmAlternate, fmWinding);\r
   {* Available filling modes. For more info see Win32 or Delphi help files. }\r
   TCopyMode = Integer;\r
   {* Available copying modes are following:\r
      |  cmBlackness<br>\r
      |  cmDstInvert<br>\r
      |  cmMergeCopy<br>\r
      |  cmMergePaint<br>\r
      |  cmNotSrcCopy<br>\r
      |  cmNotSrcErase<br>\r
      |  cmPatCopy<br>\r
      |  cmPatInvert<br>\r
      |  cmPatPaint<br>\r
      |  cmSrcAnd<br>\r
      |  cmSrcCopy<br>\r
      |  cmSrcErase<br>\r
      |  cmSrcInvert<br>\r
      |  cmSrcPaint<br>\r
      |  cmWhiteness<br>&nbsp;&nbsp;&nbsp;\r
      Also it is possible to use any other available ROP2 modes. For more info,\r
      see Win32 help files. }\r
\r
const\r
  cmBlackness = BLACKNESS;\r
  cmDstInvert = DSTINVERT;\r
  cmMergeCopy = MERGECOPY;\r
  cmMergePaint = MERGEPAINT;\r
  cmNotSrcCopy = NOTSRCCOPY;\r
  cmNotSrcErase = NOTSRCERASE;\r
  cmPatCopy = PATCOPY;\r
  cmPatInvert = PATINVERT;\r
  cmPatPaint = PATPAINT;\r
  cmSrcAnd = SRCAND;\r
  cmSrcCopy = SRCCOPY;\r
  cmSrcErase = SRCERASE;\r
  cmSrcInvert = SRCINVERT;\r
  cmSrcPaint = SRCPAINT;\r
  cmWhiteness = WHITENESS;\r
\r
type\r
  {++}(*TCanvas = class;*){--}\r
  PCanvas = {-}^{+}TCanvas;\r
  {* }\r
  TOnGetHandle = function( Canvas: PCanvas ): HDC of object;\r
  {* For internal use mainly. }\r
  TOnTextArea = procedure( Sender: PCanvas; var Size : TSize; var P0 : TPoint );\r
  {* Event to calculate actual area, occupying by a text. It is used\r
     to optionally extend calculating of TextArea taking into considaration\r
     font Orientation property. }\r
\r
{ ---------------------------------------------------------------------\r
\r
                TCanvas - high-level drawing helper object\r
\r
----------------------------------------------------------------------- }\r
//[TCanvas DEFINITION]\r
  TCanvas = object( TObj )\r
  {* Very similar to VCL's TCanvas object. But with some changes, specific\r
     for KOL: there is no necessary to use canvases in all applications.\r
     And graphic tools objects are not created with canvas, but only\r
     if really accessed in program. (Actually, even if paint box used,\r
     only programmer decides, if to implement painting using Canvas or\r
     to call low level API drawing functions working directly with DC).\r
     Therefore TCanvas has some powerful extensions: rotated text support,\r
     geometric pen support - just by changing correspondent properties\r
     of certain graphic tool objects (Font.FontOrientation, Pen.GeometricPen).\r
     See also additional Font properties (Font.FontWeight, Font.FontQuality,\r
     etc. }\r
  protected\r
    fOwnerControl: Pointer; //PControl;\r
    fHandle : HDC;\r
    fPenPos : TPoint;\r
    fBrush, fFont, fPen : PGraphicTool; // order is important for ASM version\r
    fState : Byte;\r
    fCopyMode : TCopyMode;\r
    fOnChange: TOnEvent;\r
    fOnGetHandle: TOnGetHandle;\r
    procedure SetHandle( Value : HDC );\r
    procedure SetPenPos( const Value : TPoint );\r
    procedure CreatePen;\r
    procedure CreateBrush;\r
    procedure CreateFont;\r
    procedure ObjectChanged( Sender : PGraphicTool );\r
    procedure Changing;\r
    function GetBrush: PGraphicTool;\r
    function GetFont: PGraphicTool;\r
    function GetPen: PGraphicTool;\r
    function GetHandle: HDC;\r
    procedure AssignChangeEvents;\r
    function GetPixels(X, Y: Integer): TColor;\r
    procedure SetPixels(X, Y: Integer; const Value: TColor);\r
  protected\r
    fIsPaintDC : Boolean;\r
    {* TRUE, if DC obtained during current WM_PAINT (or WM_ERASEBKGND?)\r
       processing for a control. This affects a way how Handle is released. }\r
  {++}(*public*){--}\r
    destructor Destroy;{-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
  {++}(*protected*){--}\r
    property OnGetHandle: TOnGetHandle read fOnGetHandle write fOnGetHandle;\r
    {* For internal use only. }\r
  public\r
    property Handle : HDC read GetHandle write SetHandle;\r
    {* GDI device context object handle. Never created by\r
       Canvas itself (to use Canvas with memory bitmaps,\r
       always create DC by yourself and assign it to the\r
       Handle property of Canvas object, or use property\r
       Canvas of a bitmap). }\r
    property PenPos : TPoint read FPenPos write SetPenPos;\r
    {* Position of a pen. }\r
    property Pen : PGraphicTool read GetPen;\r
    {* Pen of Canvas object. Do not change its Pen.OnChange event value. }\r
    property Brush : PGraphicTool read GetBrush;\r
    {* Brush of Canvas object. Do not change its Brush.OnChange event value. }\r
    property Font : PGraphicTool read GetFont;\r
    {* Font of Canvas object. Do not change its Font.OnChange event value. }\r
    procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;\r
    {* Draws arc. For more info, see Delphi TCanvas help. }\r
    procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;\r
    {* Draws chord. For more info, see Delphi TCanvas help. }\r
    procedure DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);\r
    {* Draws rectangle to represent focused visual object.\r
       For more info, see Delphi TCanvas help. }\r
    procedure Ellipse(X1, Y1, X2, Y2: Integer);\r
    {* Draws an ellipse. For more info, see Delphi TCanvas help. }\r
    procedure FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);\r
    {* Fills rectangle. For more info, see Delphi TCanvas help. }\r
    procedure FillRgn( const Rgn : HRgn );\r
    {* Fills region. For more info, see Delphi TCanvas help. }\r
    procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);\r
    {* Fills a figure with givien color, floodfilling its surface.\r
       For more info, see Delphi TCanvas help. }\r
    procedure FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);\r
    {* Draws a rectangle. For more info, see Delphi TCanvas help. }\r
    procedure MoveTo( X, Y : Integer );\r
    {* Moves current PenPos to a new position.\r
       For more info, see Delphi TCanvas help. }\r
    procedure LineTo( X, Y : Integer );\r
    {* Draws a line from current PenPos up to new position.\r
       For more info, see Delphi TCanvas help. }\r
    procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;\r
    {* Draws a pie. For more info, see Delphi TCanvas help. }\r
    procedure Polygon(const Points: array of TPoint);\r
    {* Draws a polygon. For more info, see Delphi TCanvas help. }\r
    procedure Polyline(const Points: array of TPoint);\r
    {* Draws a bound for polygon. For more info, see Delphi TCanvas help. }\r
    procedure Rectangle(X1, Y1, X2, Y2: Integer);\r
    {* Draws a rectangle using current Pen and/or Brush.\r
       For more info, see Delphi TCanvas help. }\r
    procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);\r
    {* Draws a rounded rectangle. For more info, see Delphi TCanvas help. }\r
    procedure TextOut(X, Y: Integer; const Text: String); stdcall;\r
    {* Draws a text. For more info, see Delphi TCanvas help. }\r
    procedure ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: String;\r
              const Spacing: array of Integer );\r
    {* }\r
    procedure DrawText(Text:String; var Rect:TRect; Flags:DWord);\r
    {* }\r
    procedure TextRect(const Rect: TRect; X, Y: Integer; const Text: string);\r
    {* Draws a text, clipping output into given rectangle.\r
       For more info, see Delphi TCanvas help. }\r
    function TextExtent(const Text: string): TSize;\r
    {* Calculates size of a Text, using current Font settings.\r
       Does not need in Handle for Canvas object (if it is not\r
       yet allocated, temporary device context is created and used. }\r
    procedure TextArea( const Text : String; var Sz : TSize; var P0 : TPoint );\r
    {* Calculates size and starting point to output Text,\r
       taking into considaration all Font attributes, including\r
       Orientation (only if GlobalGraphics_UseFontOrient flag\r
       is set to True, i.e. if rotated fonts are used).\r
       Like for TextExtent, does not need in Handle (and if this\r
       last is not yet allocated/assigned, temporary device context\r
       is created and used). }\r
    function TextWidth(const Text: string): Integer;\r
    {* Calculates text width (using TextArea). }\r
    function TextHeight(const Text: string): Integer;\r
    {* Calculates text height (using TextArea). }\r
    function ClipRect: TRect;\r
    {* returns ClipBox. by Dmitry Zharov. }\r
\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2} //------- WideString not supported in D2\r
    procedure WTextOut(X, Y: Integer; const WText: WideString); stdcall;\r
    {* Draws a Unicode text. }\r
    procedure WExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect;\r
              const WText: WideString; const Spacing: array of Integer );\r
    {* }\r
    procedure WDrawText(WText: WideString; var Rect:TRect; Flags:DWord);\r
    {* }\r
    procedure WTextRect(const Rect: TRect; X, Y: Integer;\r
              const WText: WideString);\r
    {* Draws a Unicode text, clipping output into given rectangle. }\r
    function WTextExtent( const WText: WideString ): TSize;\r
    {* Calculates Unicode text width and height. }\r
    function WTextWidth( const WText: WideString ): Integer;\r
    {* Calculates Unicode text width. }\r
    function WTextHeight( const WText: WideString ): Integer;\r
    {* Calculates Unicode text height. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
\r
    property ModeCopy : TCopyMode read fCopyMode write fCopyMode;\r
    {* Current copy mode. Is used in CopyRect method. }\r
    procedure CopyRect( const DstRect : TRect; SrcCanvas : PCanvas; const SrcRect : TRect );\r
    {* Copyes a rectangle from source to destination, using StretchBlt. }\r
    property OnChange: TOnEvent read fOnChange write fOnChange;\r
    {* }\r
    function Assign( SrcCanvas : PCanvas ) : Boolean;\r
    {* }\r
    function RequiredState( ReqState : DWORD ): Integer; stdcall;// public now\r
    {* It is possible to call this method before using Handle property\r
       to pass it into API calls - to provide valid combinations of\r
       pen, brush and font, selected into device context. This method\r
       can not provide valid Handle - You always must create it by\r
       yourself and assign to TCanvas.Handle property manually.\r
       To optimize assembler version, returns Handle value. }\r
    procedure DeselectHandles;\r
    {* Call this method to deselect all graphic tool objects from the canvas. }\r
    property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels;\r
    {* Obvious. }\r
  end;\r
//[END OF TCanvas DEFINITION]\r
\r
//[GlobalCanvas_OnTextArea]\r
var\r
    GlobalCanvas_OnTextArea : TOnTextArea;\r
    {* Global event to extend Canvas with possible add-ons, applied\r
       when rotated fonts are used only (to take into consideration\r
       Font.Orientation property in TextArea method). }\r
\r
//[NewCanvas DECLARATION]\r
function NewCanvas( DC: HDC ): PCanvas;\r
{* Use to construct Canvas on base of memory DC. }\r
\r
//[Extended FUNCTIONS TO WORK WITH CANVAS]\r
{++}(*\r
{$IFDEF F_P}\r
function Windows_Polygon(DC: HDC; var Points; Count: Integer): BOOL; stdcall;\r
function Windows_Polyline(DC: HDC; var Points; Count: Integer): BOOL; stdcall;\r
function FillRect(hDC: HDC; const lprc: TRect; hbr: HBRUSH): Integer; stdcall;\r
function OffsetRect(var lprc: TRect; dx, dy: Integer): BOOL; stdcall;\r
function CreateAcceleratorTable(var Accel; Count: Integer): HACCEL; stdcall;\r
function TrackPopupMenu(hMenu: HMENU; uFlags: UINT; x, y, nReserved: Integer;\r
  hWnd: HWND; prcRect: PRect): BOOL; stdcall;\r
function AdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;\r
  const NewState: TTokenPrivileges; BufferLength: DWORD;\r
  var PreviousState: TTokenPrivileges; var ReturnLength: DWORD): BOOL; stdcall;\r
function InflateRect(var lprc: TRect; dx, dy: Integer): BOOL; stdcall;\r
{$IFDEF F_P105ORBELOW}\r
function InvalidateRect(hWnd: HWND; lpRect: PRect; bErase: BOOL): BOOL; stdcall;\r
function ValidateRect(hWnd: HWND; lpRect: PRect): BOOL; stdcall;\r
{$ENDIF F_P105ORBELOW}\r
{$ENDIF}\r
*){--}\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- Image list object -- }\r
//[IMAGE LIST]\r
\r
type\r
  TImageListColors = (ilcColor,ilcColor4,ilcColor8,ilcColor16,\r
                      ilcColor24,ilcColor32,ilcColorDDB,ilcDefault);\r
  {* ImageList color schemes available. }\r
\r
  TDrawingStyles = ( dsBlend25, dsBlend50, dsMask, dsTransparent );\r
  {* ImageList drawing styles available. }\r
  TDrawingStyle = Set of TDrawingStyles;\r
  {* Style of drawing is a combination of all available drawing styles. }\r
\r
  TImageType = (itBitmap,itIcon,itCursor);\r
  {* ImageList types available. }\r
\r
  {++}(*TImageList = class;*){--}\r
  PImageList = {-}^{+}TImageList;\r
  {* }\r
\r
  TImgLOVrlayIdx = 1..15;\r
\r
{ ---------------------------------------------------------------------\r
\r
                TImageList - images container\r
\r
----------------------------------------------------------------------- }\r
//[TImageList DEFINITION]\r
  TImageList = object( TObj )\r
  {* ImageList incapsulation. }\r
  protected\r
    FHandle: THandle;\r
    FControl: Pointer; // PControl;\r
    fPrev, fNext: PImageList;\r
    FColors: TImageListColors;\r
    FMasked: Boolean;\r
    FImgWidth: Integer;\r
    FImgHeight: Integer;\r
    FDrawingStyle: TDrawingStyle;\r
    FBlendColor: TColor;\r
    fBkColor: TColor;\r
    FAllocBy: Integer;\r
    FShareImages: Boolean;\r
    FOverlay: array[ TImgLOVrlayIdx ] of Integer;\r
    function HandleNeeded : Boolean;\r
    procedure SetColors(const Value: TImageListColors);\r
    procedure SetMasked(const Value: Boolean);\r
    procedure SetImgWidth(const Value: Integer);\r
    procedure SetImgHeight(const Value: Integer);\r
    function GetCount: Integer;\r
    function GetBkColor: TColor;\r
    procedure SetBkColor(const Value: TColor);\r
    function GetBitmap: HBitmap;\r
    function GetMask: HBitmap;\r
    function GetDrawStyle : DWord;\r
    procedure SetAllocBy(const Value: Integer);\r
    function GetHandle: THandle;\r
    function GetOverlay(Idx: TImgLOVrlayIdx): Integer;\r
    procedure SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer);\r
  protected\r
    procedure SetHandle(const Value: THandle);\r
    {*}\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {*}\r
    property Handle : THandle read GetHandle write SetHandle;\r
    {* Handle of ImageList object. }\r
    property ShareImages : Boolean read FShareImages write FShareImages;\r
    {* True if images are shared between processes (it is set to True,\r
       if its Handle is assigned to given value, which is a handle of\r
       already existing ImageList object). }\r
    property Colors : TImageListColors read FColors write SetColors;\r
    {* Colors used to represent images. }\r
    property Masked : Boolean read FMasked write SetMasked;\r
    {* True, if mask is used. It is set to True, if first added image\r
       is icon, e.g. }\r
    property ImgWidth : Integer read FImgWidth write SetImgWidth;\r
    {* Width of every image in list. If change, ImageList is cleared. }\r
    property ImgHeight : Integer read FImgHeight write SetImgHeight;\r
    {* Height of every image in list. If change, ImageList is cleared. }\r
    property Count : Integer read GetCount;\r
    {* Number of images in list. }\r
    property AllocBy : Integer read FAllocBy write SetAllocBy;\r
    {* Allocation factor. Default is 1. Set it to size of ImageList if this\r
       value is known - to optimize speed of allocation. }\r
    property BkColor : TColor read GetBkColor write SetBkColor;\r
    {* Background color. }\r
    property BlendColor : TColor read FBlendColor write FBlendColor;\r
    {* Blend color. }\r
\r
    property Bitmap : HBitmap read GetBitmap;\r
    {* Bitmap, containing all ImageList images (tiled horizontally). }\r
    property Mask : HBitmap read GetMask;\r
    {* Monochrome bitmap, containing masks for all images in list (if not\r
       Masked, always returns nil). }\r
    function ImgRect( Idx : Integer ) : TRect;\r
    {* Rectangle occupied of given image in ImageList. }\r
\r
    function Add( Bmp, Msk : HBitmap ) : Integer;\r
    {* Adds bitmap and given mask to ImageList. }\r
    function AddMasked( Bmp : HBitmap; Color : TColor ) : Integer;\r
    {* Adds bitmap to ImageList, using given color to create mask. }\r
    function AddIcon( Ico : HIcon ) : Integer;\r
    {* Adds icon to ImageList (always masked). }\r
    procedure Delete( Idx : Integer );\r
    {* Deletes given image from ImageList. }\r
    procedure Clear;\r
    {* Makes ImageList empty. }\r
    function Replace( Idx : Integer; Bmp, Msk : HBitmap ) : Boolean;\r
    {* Replaces given (by index) image with bitmap and its mask with mask bitmap. }\r
    function ReplaceIcon( Idx : Integer; Ico : HIcon ) : Boolean;\r
    {* Replaces given (by index) image with an icon. }\r
    function Merge( Idx : Integer; ImgList2 : PImageList; Idx2 : Integer; X, Y : Integer )\r
             : PImageList;\r
    {* Merges two ImageList objects, returns resulting ImageList. }\r
    function ExtractIcon( Idx : Integer ) : HIcon;\r
    {* Extracts icon by index. }\r
    function ExtractIconEx( Idx : Integer ) : HIcon;\r
    {* Extracts icon (is created using current drawing style). }\r
\r
    property DrawingStyle : TDrawingStyle read FDrawingStyle write FDrawingStyle;\r
    {* Drawing style. }\r
    procedure Draw( Idx : Integer; DC : HDC; X, Y : Integer );\r
    {* Draws given (by index) image from ImageList onto passed Device Context. }\r
    procedure StretchDraw( Idx : Integer; DC : HDC; const Rect : TRect );\r
    {* Draws given image with stratching. }\r
\r
    function LoadBitmap( ResourceName : PChar; TranspColor : TColor ) : Boolean;\r
    {* Loads ImageList from resource. }\r
    //function LoadIcon( ResourceName : PChar ) : Boolean;\r
    //function LoadCursor( ResourceName : PChar ) : Boolean;\r
    function LoadFromFile( FileName : PChar; TranspColor : TColor; ImgType : TImageType ) : Boolean;\r
    {* Loads ImageList from file. }\r
    function LoadSystemIcons( SmallIcons : Boolean ) : Boolean;\r
    {* Assigns ImageList to system icons list (big or small). }\r
\r
    property Overlay[ Idx: TImgLOVrlayIdx ]: Integer read GetOverlay write SetOverlay;\r
    {* Overlay images for image list (images, used as overlay images to draw over\r
       other images from the image list). These overalay images can be used in\r
       listview and treeview as overlaying images (up to four masks at the same\r
       time). }\r
    {$IFDEF USE_CONSTRUCTORS}\r
    constructor CreateImageList( POwner: Pointer );\r
    {$ENDIF USE_CONSTRUCTORS}\r
  end;\r
//[END OF TImageList DEFINITION]\r
\r
//[IMAGE LIST API]\r
\r
const\r
  CLR_NONE                = $FFFFFFFF;\r
  CLR_DEFAULT             = $FF000000;\r
\r
type\r
  HImageList = THandle;\r
\r
const\r
  ILC_MASK                = $0001;\r
  ILC_COLOR               = $00FE;\r
  ILC_COLORDDB            = $00FE;\r
  ILC_COLOR4              = $0004;\r
  ILC_COLOR8              = $0008;\r
  ILC_COLOR16             = $0010;\r
  ILC_COLOR24             = $0018;\r
  ILC_COLOR32             = $0020;\r
  ILC_PALETTE             = $0800;\r
\r
const\r
  ILD_NORMAL              = $0000;\r
  ILD_TRANSPARENT         = $0001;\r
  ILD_MASK                = $0010;\r
  ILD_IMAGE               = $0020;\r
  ILD_BLEND25             = $0002;\r
  ILD_BLEND50             = $0004;\r
  ILD_OVERLAYMASK         = $0F00;\r
\r
const\r
  ILD_SELECTED            = ILD_BLEND50;\r
  ILD_FOCUS               = ILD_BLEND25;\r
  ILD_BLEND               = ILD_BLEND50;\r
  CLR_HILIGHT             = CLR_DEFAULT;\r
\r
function ImageList_Create(CX, CY: Integer; Flags: UINT;\r
  Initial, Grow: Integer): HImageList; stdcall;\r
function ImageList_Destroy(ImageList: HImageList): Bool; stdcall;\r
function ImageList_GetImageCount(ImageList: HImageList): Integer; stdcall;\r
function ImageList_SetImageCount(ImageList: HImageList; Count: Integer): Integer; stdcall;\r
function ImageList_Add(ImageList: HImageList; Image, Mask: HBitmap): Integer; stdcall;\r
function ImageList_ReplaceIcon(ImageList: HImageList; Index: Integer;\r
  Icon: HIcon): Integer; stdcall;\r
function ImageList_SetBkColor(ImageList: HImageList; ClrBk: TColorRef): TColorRef; stdcall;\r
function ImageList_GetBkColor(ImageList: HImageList): TColorRef; stdcall;\r
function ImageList_SetOverlayImage(ImageList: HImageList; Image: Integer;\r
  Overlay: Integer): Bool; stdcall;\r
\r
function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer;\r
\r
function Index2OverlayMask(Index: Integer): Integer;\r
\r
function ImageList_Draw(ImageList: HImageList; Index: Integer;\r
  Dest: HDC; X, Y: Integer; Style: UINT): Bool; stdcall;\r
\r
function ImageList_Replace(ImageList: HImageList; Index: Integer;\r
  Image, Mask: HBitmap): Bool; stdcall;\r
function ImageList_AddMasked(ImageList: HImageList; Image: HBitmap;\r
  Mask: TColorRef): Integer; stdcall;\r
function ImageList_DrawEx(ImageList: HImageList; Index: Integer;\r
  Dest: HDC; X, Y, DX, DY: Integer; Bk, Fg: TColorRef; Style: Cardinal): Bool; stdcall;\r
function ImageList_Remove(ImageList: HImageList; Index: Integer): Bool; stdcall;\r
function ImageList_GetIcon(ImageList: HImageList; Index: Integer;\r
  Flags: Cardinal): HIcon; stdcall;\r
function ImageList_LoadImageA(Instance: THandle; Bmp: PAnsiChar; CX, Grow: Integer;\r
  Mask: TColorRef; pType, Flags: Cardinal): HImageList; stdcall;\r
function ImageList_LoadImageW(Instance: THandle; Bmp: PWideChar; CX, Grow: Integer;\r
  Mask: TColorRef; pType, Flags: Cardinal): HImageList; stdcall;\r
function ImageList_LoadImage(Instance: THandle; Bmp: PChar; CX, Grow: Integer;\r
  Mask: TColorRef; pType, Flags: Cardinal): HImageList; stdcall;\r
function ImageList_BeginDrag(ImageList: HImageList; Track: Integer;\r
  XHotSpot, YHotSpot: Integer): Bool; stdcall;\r
function ImageList_EndDrag: Bool; stdcall;\r
function ImageList_DragEnter(LockWnd: HWnd; X, Y: Integer): Bool; stdcall;\r
function ImageList_DragLeave(LockWnd: HWnd): Bool; stdcall;\r
function ImageList_DragMove(X, Y: Integer): Bool; stdcall;\r
function ImageList_SetDragCursorImage(ImageList: HImageList; Drag: Integer;\r
  XHotSpot, YHotSpot: Integer): Bool; stdcall;\r
function ImageList_DragShowNolock(Show: Bool): Bool; stdcall;\r
function ImageList_GetDragImage(Point, HotSpot: PPoint): HImageList; stdcall;\r
\r
{ macros }\r
procedure ImageList_RemoveAll(ImageList: HImageList); stdcall;\r
function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList;\r
  Image: Integer): HIcon; stdcall;\r
function ImageList_LoadBitmap(Instance: THandle; Bmp: PChar;\r
  CX, Grow: Integer; MasK: TColorRef): HImageList; stdcall;\r
\r
//function ImageList_Read(Stream: IStream): HImageList; stdcall;\r
//function ImageList_Write(ImageList: HImageList; Stream: IStream): BOOL; stdcall;\r
\r
//[TImageInfo]\r
type\r
  PImageInfo = ^TImageInfo;\r
  TImageInfo = packed record\r
    hbmImage: HBitmap;\r
    hbmMask: HBitmap;\r
    Unused1: Integer;\r
    Unused2: Integer;\r
    rcImage: TRect;\r
  end;\r
\r
function ImageList_GetIconSize(ImageList: HImageList; var CX, CY: Integer): Bool; stdcall;\r
function ImageList_SetIconSize(ImageList: HImageList; CX, CY: Integer): Bool; stdcall;\r
function ImageList_GetImageInfo(ImageList: HImageList; Index: Integer;\r
  var ImageInfo: TImageInfo): Bool; stdcall;\r
function ImageList_Merge(ImageList1: HImageList; Index1: Integer;\r
  ImageList2: HImageList; Index2: Integer; DX, DY: Integer)://Bool - ERROR IN VCL\r
  HImageList; stdcall;\r
\r
//[LoadBmp]\r
function LoadBmp( Instance: Integer; Rsrc: PChar; MasterObj: PObj ): HBitmap;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
//[BITMAPS]\r
type\r
  tagBitmap = Windows.TBitmap;\r
\r
  TPixelFormat = ( pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit,\r
                   pf32bit, pfCustom );\r
  {* Available pixel formats. }\r
  TBitmapHandleType = ( bmDIB, bmDDB );\r
  {* Available bitmap handle types. }\r
\r
  {++}(*TBitmap = class;*){--}\r
  PBitmap = {-}^{+}TBitmap;\r
{ ----------------------------------------------------------------------\r
\r
                      TBitmap - bitmap image\r
\r
----------------------------------------------------------------------- }\r
//[TBitmap DEFINITION]\r
  TBitmap = object( TObj )\r
  {* Bitmap incapsulation object. }\r
  protected\r
    fHeight: Integer;\r
    fWidth: Integer;\r
    fHandle: HBitmap;\r
    fCanvas: PCanvas;\r
    fScanLineSize: Integer;\r
    fBkColor: TColor;\r
    fApplyBkColor2Canvas: procedure( Sender: PBitmap );\r
    fDetachCanvas: procedure( Sender: PBitmap );\r
    fCanvasAttached : Integer;\r
    fHandleType: TBitmapHandleType;\r
    fDIBHeader: PBitmapInfo;\r
    fDIBBits: Pointer;\r
    fDIBSize: Integer;\r
    fNewPixelFormat: TPixelFormat;\r
    fFillWithBkColor: procedure( BmpObj: PBitmap; DC: HDC; oldW, oldH: Integer );\r
                        //stdcall;\r
    fTransMaskBmp: PBitmap;\r
    fTransColor: TColor;\r
    fGetDIBPixels: function( Bmp: PBitmap; X, Y: Integer ): TColor;\r
    fSetDIBPixels: procedure( Bmp: PBitmap; X, Y: Integer; Value: TColor );\r
    fScanLine0: PByte;\r
    fScanLineDelta: Integer;\r
    fPixelMask: DWORD;\r
    fPixelsPerByteMask: Integer;\r
    fBytesPerPixel: Integer;\r
    fDIBAutoFree: Boolean;\r
    procedure SetHeight(const Value: Integer);\r
    procedure SetWidth(const Value: Integer);\r
    function GetEmpty: Boolean;\r
    function GetHandle: HBitmap;\r
    function GetHandleAllocated: Boolean;\r
    procedure SetHandle(const Value: HBitmap);\r
    procedure SetPixelFormat(Value: TPixelFormat);\r
    procedure FormatChanged;\r
    function GetCanvas: PCanvas;\r
    procedure CanvasChanged( Sender: PObj );\r
    function GetScanLine(Y: Integer): Pointer;\r
    function GetScanLineSize: Integer;\r
    procedure ClearData;\r
    procedure ClearTransImage;\r
    procedure SetBkColor(const Value: TColor);\r
    function GetDIBPalEntries(Idx: Integer): TColor;\r
    function GetDIBPalEntryCount: Integer;\r
    procedure SetDIBPalEntries(Idx: Integer; const Value: TColor);\r
    procedure SetHandleType(const Value: TBitmapHandleType);\r
    function GetPixelFormat: TPixelFormat;\r
    function GetPixels(X, Y: Integer): TColor;\r
    procedure SetPixels(X, Y: Integer; const Value: TColor);\r
    function GetDIBPixels(X, Y: Integer): TColor;\r
    procedure SetDIBPixels(X, Y: Integer; const Value: TColor);\r
    function GetBoundsRect: TRect;\r
  protected\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
  public\r
    property Width: Integer read fWidth write SetWidth;\r
    {* Width of bitmap. To make code smaller, avoid changing Width or Height\r
       after bitmap is created (using NewBitmap) or after it is loaded from\r
       file, stream of resource. }\r
    property Height: Integer read fHeight write SetHeight;\r
    {* Height of bitmap. To make code smaller, avoid changing Width or Height\r
       after bitmap is created (using NewBitmap) or after it is loaded from\r
       file, stream of resource. }\r
    property BoundsRect: TRect read GetBoundsRect;\r
    {* Returns rectangle (0,0,Width,Height). }\r
    property Empty: Boolean read GetEmpty;\r
    {* Returns True if Width or Height is 0. }\r
    procedure Clear;\r
    {* Makes bitmap empty, setting its Width and Height to 0. }\r
    procedure LoadFromFile( const Filename: String );\r
    {* Loads bitmap from file (LoadFromStream used). }\r
    function LoadFromFileEx( const Filename: String ): Boolean;\r
    {* Loads bitmap from a file. If necessary, bitmap is RLE-decoded. Code given\r
       by Vyacheslav A. Gavrik. }\r
    procedure SaveToFile( const Filename: String );\r
    {* Stores bitmap to file (SaveToStream used). }\r
    procedure LoadFromStream( Strm: PStream );\r
    {* Loads bitmap from stream. Follow loading, bitmap has DIB format (without\r
       handle allocated). It is possible to draw DIB bitmap without creating\r
       handle for it, which can economy GDI resources. }\r
    function LoadFromStreamEx( Strm: PStream ): Boolean;\r
    {* Loads bitmap from a stream. Difference is that RLE decoding supported.\r
       Code given by Vyacheslav A. Gavrik. }\r
    procedure SaveToStream( Strm: PStream );\r
    {* Saves bitmap to stream. If bitmap is not DIB, it is converted to DIB\r
       before saving. }\r
    procedure LoadFromResourceID( Inst: DWORD; ResID: Integer );\r
    {* Loads bitmap from resource using integer ID of resource. To load by name,\r
       use LoadFromResurceName. To load resource of application itself, pass\r
       hInstance as first parameter. This method also can be used to load system\r
       predefined bitmaps, if 0 is passed as Inst parameter:\r
       |<pre>\r
       OBM_BTNCORNERS   OBM_REDUCE\r
       OBM_BTSIZE       OBM_REDUCED\r
       OBM_CHECK        OBM_RESTORE\r
       OBM_CHECKBOXES   OBM_RESTORED\r
       OBM_CLOSE        OBM_RGARROW\r
       OBM_COMBO        OBM_RGARROWD\r
       OBM_DNARROW      OBM_RGARROWI\r
       OBM_DNARROWD     OBM_SIZE\r
       OBM_DNARROWI     OBM_UPARROW\r
       OBM_LFARROW      OBM_UPARROWD\r
       OBM_LFARROWD     OBM_UPARROWI\r
       OBM_LFARROWI     OBM_ZOOM\r
       OBM_MNARROW      OBM_ZOOMD\r
       |</pre>        }\r
    procedure LoadFromResourceName( Inst: DWORD; ResName: PChar );\r
    {* Loads bitmap from resurce (using passed name of bitmap resource. }\r
    function Assign( SrcBmp: PBitmap ): Boolean;\r
    {* Assigns bitmap from another. Returns False if not success.\r
       Note: remember, that Canvas is not assigned - only bitmap image\r
       is copied. And for DIB, handle is not allocating due this process. }\r
    property Handle: HBitmap read GetHandle write SetHandle;\r
    {* Handle of bitmap. Created whenever property accessed. To check if handle\r
       is allocated (without allocating it), use HandleAllocated property. }\r
    property HandleAllocated: Boolean read GetHandleAllocated;\r
    {* Returns True, if Handle already allocated. }\r
    function ReleaseHandle: HBitmap;\r
    {* Returns Handle and releases it, so bitmap no more know about handle.\r
       This method does not destroy bitmap image, but converts it into DIB.\r
       Returned Handle actually is a handle of copy of original bitmap. If\r
       You need not in keping it up, use Dormant method instead. }\r
    procedure Dormant;\r
    {* Releases handle from bitmap and destroys it. But image is not destroyed\r
       and its data are preserved in DIB format. Please note, that in KOL, DIB\r
       bitmaps can be drawn onto given device context without allocating of\r
       handle. So, it is very useful to call Dormant preparing it using\r
       Canvas drawing operations - to economy GDI resources. }\r
    property HandleType: TBitmapHandleType read fHandleType write SetHandleType;\r
    {* bmDIB, if DIB part of image data is filled and stored internally in\r
       TBitmap object. DIB image therefore can have Handle allocated, which\r
       require resources. Use HandleAllocated funtion to determine if handle\r
       is allocated and Dormant method to remove it, if You want to economy\r
       GDI resources. (Actually Handle needed for DIB bitmap only in case\r
       when Canvas is used to draw on bitmap surface). Please note also, that\r
       before saving bitmap to file or stream, it is converted to DIB. }\r
    property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;\r
    {* Current pixel format. If format of bitmap is unknown, or bitmap is DDB,\r
       value is pfDevice. Setting PixelFormat to any other format converts\r
       bitmap to DIB, back to pfDevice converts bitmap to DDB again. Avoid\r
       such conversations for large bitmaps or for numerous bitmaps in your\r
       application to keep good performance. }\r
    function BitsPerPixel: Integer;\r
    {* Returns bits per pixel if possible. }\r
    procedure Draw( DC: HDC; X, Y: Integer );\r
    {* Draws bitmap to given device context. If bitmap is DIB, it is always\r
       drawing using SetDIBitsToDevice API call, which does not require bitmap\r
       handle (so, it is very sensible to call Dormant method to free correspondent\r
       GDI resources). }\r
    procedure StretchDraw( DC: HDC; const Rect: TRect );\r
    {* Draws bitmap onto DC, stretching it to fit given rectangle Rect. }\r
    procedure DrawTransparent( DC: HDC; X, Y: Integer; TranspColor: TColor );\r
    {* Draws bitmap onto DC transparently, using TranspColor as transparent. }\r
    procedure StretchDrawTransparent( DC: HDC; const Rect: TRect; TranspColor: TColor );\r
    {* Draws bitmap onto given rectangle of destination DC (with stretching it\r
       to fit Rect) - transparently, using TranspColor as transparent. }\r
    procedure DrawMasked( DC: HDC; X, Y: Integer; Mask: HBitmap );\r
    {* Draws bitmap to destination DC transparently by mask. It is possible\r
       to pass as a mask handle of another TBitmap, previously converted to\r
       monochrome mask using Convert2Mask method. }\r
    procedure StretchDrawMasked( DC: HDC; const Rect: TRect; Mask: HBitmap );\r
    {* Like DrawMasked, but with stretching image onto given rectangle. }\r
    procedure Convert2Mask( TranspColor: TColor );\r
    {* Converts bitmap to monochrome (mask) bitmap with TranspColor replaced\r
       to clBlack and all other ones to clWhite. Such mask bitmap can be used\r
       to draw original bitmap transparently, with given TranspColor as\r
       transparent. (To preserve original bitmap, create new instance of\r
       TBitmap and assign original bitmap to it). See also DrawTransparent and\r
       StretchDrawTransparent methods. }\r
    procedure Invert;\r
    {* Obvious. }\r
    property Canvas: PCanvas read GetCanvas;\r
    {* Canvas can be used to draw onto bitmap. Whenever it is accessed, handle\r
       is allocated for bitmap, if it is not yet (to make it possible\r
       to select bitmap to display compatible device context). }\r
    procedure RemoveCanvas;\r
    {* Call this method to destroy Canvas and free GDI resources. }\r
    property BkColor: TColor read fBkColor write SetBkColor;\r
    {* Used to fill background for Bitmap, when its width or height is increased.\r
       Although this value always synchronized with Canvas.Brush.Color, use it\r
       instead if You do not use Canvas for drawing on bitmap surface. }\r
    property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels;\r
    {* Allows to obtain or change certain pixels of a bitmap. This method is\r
       both for DIB and DDB bitmaps, and leads to allocate handle anyway. For\r
       DIB bitmaps, it is possible to use property DIBPixels[ ] instead,\r
       which is much faster and does not require in Handle. }\r
    property ScanLineSize: Integer read GetScanLineSize;\r
    {* Returns size of scan line in bytes. Use it to measure size of a single\r
       ScanLine. To calculate increment value from first byte of ScanLine to\r
       first byte of next ScanLine, use difference\r
       !  Integer(ScanLine[1]-ScanLine[0])\r
       (this is because bitmap can be oriented from bottom to top, so\r
       step can be negative). }\r
    property ScanLine[ Y: Integer ]: Pointer read GetScanLine;\r
    {* Use ScanLine to access DIB bitmap pixels in memory to direct access it\r
       fast. Take in attention, that for different pixel formats, different\r
       bit counts are used to represent bitmap pixels. Also do not forget, that\r
       for formats pf4bit and pf8bit, pixels actually are indices to palette\r
       entries, and for formats pf16bit, pf24bit and pf32bit are actually\r
       RGB values (for pf16bit B:5-G:6-R:5, for pf15bit B:5-G:5-R:5 (high order\r
       bit not used), for pf24bit B:8-G:8-R:8, and for pf32bit high order byte\r
       of TRGBQuad structure is not used). }\r
    property DIBPixels[ X, Y: Integer ]: TColor read GetDIBPixels write SetDIBPixels;\r
    {* Allows direct access to pixels of DIB bitmap, faster then Pixels[ ]\r
       property. Access to read is slower for pf15bit, pf16bit formats (because\r
       some conversation needed to translate packed RGB color to TColor). And\r
       for write, operation performed most slower for pf4bit, pf8bit (searching\r
       nearest color required) and fastest for pf24bit, pf32bit and pf1bit. }\r
    property DIBPalEntryCount: Integer read GetDIBPalEntryCount;\r
    {* Returns palette entries count for DIB image. Always returns 2 for pf1bit,\r
       16 for pf4bit, 256 for pf8bit and 0 for other pixel formats. }\r
    property DIBPalEntries[ Idx: Integer ]: TColor read GetDIBPalEntries write\r
             SetDIBPalEntries;\r
    {* Provides direct access to DIB palette. }\r
    function DIBPalNearestEntry( Color: TColor ): Integer;\r
    {* Returns index of entry in DIB palette with color nearest (or matching)\r
       to given one. }\r
    property DIBBits: Pointer read fDIBBits;\r
    {* This property is mainly for internal use. }\r
    property DIBSize: Integer read fDIBSize;\r
    {* Size of DIBBits array. }\r
    property DIBHeader: PBitmapInfo read fDIBHeader;\r
    {* This property is mainly for internal use. }\r
    procedure DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect );\r
    {* This procedure copies given rectangle to the target device context,\r
       but only for DIB bitmap (using SetDIBBitsToDevice API call). }\r
    procedure RotateRight;\r
    {* Rotates bitmap right (90 degree). Bitmap must be DIB. If You definitevely\r
       know format of a bitmap, use instead one of methods RotateRightMono,\r
       RotateRight4bit, RotateRight8bit, RotateRight16bit or RotateRightTrueColor\r
       - this will economy code. But if for most of formats such methods are\r
       called, this can be more economy just to call always universal method\r
       RotateRight. }\r
    procedure RotateLeft;\r
    {* Rotates bitmap left (90 degree). Bitmap must be DIB. If You definitevely\r
       know format of a bitmap, use instead one of methods RotateLeftMono,\r
       RotateLeft4bit, RotateLeft8bit, RotateLeft16bit or RotateLeftTrueColor\r
       - this will economy code. But if for most of formats such methods are\r
       called, this can be more economy just to call always universal method\r
       RotateLeft. }\r
    procedure RotateRightMono;\r
    {* Rotates bitmat right, but only if bitmap is monochrome (pf1bit). }\r
    procedure RotateLeftMono;\r
    {* Rotates bitmap left, but only if bitmap is monochrome (pf1bit). }\r
    procedure RotateRight4bit;\r
    {* Rotates bitmap right, but only if PixelFormat is pf4bit. }\r
    procedure RotateLeft4bit;\r
    {* Rotates bitmap left, but only if PixelFormat is pf4bit. }\r
    procedure RotateRight8bit;\r
    {* Rotates bitmap right, but only if PixelFormat is pf8bit. }\r
    procedure RotateLeft8bit;\r
    {* Rotates bitmap left, but only if PixelFormat is pf8bit. }\r
    procedure RotateRight16bit;\r
    {* Rotates bitmap right, but only if PixelFormat is pf16bit. }\r
    procedure RotateLeft16bit;\r
    {* Rotates bitmap left, but only if PixelFormat is pf16bit. }\r
    procedure RotateRightTrueColor;\r
    {* Rotates bitmap right, but only if PixelFormat is pf24bit or pf32bit. }\r
    procedure RotateLeftTrueColor;\r
    {* Rotates bitmap left, but only if PixelFormat is pf24bit or pf32bit. }\r
    procedure FlipVertical;\r
    {* Flips bitmap vertically }\r
    procedure FlipHorizontal;\r
    {* Flips bitmap horizontally }\r
    procedure CopyRect( const DstRect : TRect; SrcBmp : PBitmap; const SrcRect : TRect );\r
    {* It is possible to use Canvas.CopyRect for such purpose, but if You\r
       do not want use TCanvas, it is possible to copy rectangle from one\r
       bitmap to another using this function. }\r
    function CopyToClipboard: Boolean;\r
    {* Copies bitmap to clipboard. }\r
    function PasteFromClipboard: Boolean;\r
    {* Takes CF_DIB format bitmap from clipboard and assigns it to the\r
       TBitmap object. }\r
  end;\r
//[END OF TBitmap DEFINITION]\r
\r
//[NewBitmap DECLARATION]\r
function NewBitmap( W, H: Integer ): PBitmap;\r
{* Creates bitmap object of given size. If it is possible, do not change its\r
   size (Width and Heigth) later - this can economy code a bit. See TBitmap. }\r
\r
function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;\r
{* Creates DIB bitmap object of given size and pixel format. If it is possible,\r
   do not change its size (Width and Heigth) later - this can economy code a bit.\r
   See TBitmap. }\r
\r
//[CalcScanLineSize DECLARATION]\r
function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;\r
{* May be will be useful. }\r
\r
//[DefaultPixelFormat VARIABLE]\r
var\r
  //DefaultBitsPerPixel: Integer = 16;\r
  DefaultPixelFormat: TPixelFormat = pf16bit;\r
\r
//[Mapped bitmaps]\r
\r
{ -- Function to load bitmap mapping some its colors. -- }\r
function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor )\r
         : HBitmap;\r
{* This function can be used to load bitmap and replace some it colors to\r
   desired ones. This function especially useful when loaded by the such way\r
   bitmap is used as toolbar bitmap - to replace some original colors to\r
   system default colors. To use this function properly, the bitmap shoud\r
   be prepared as 16-color bitmap, which uses only system colors. To do so,\r
   create a new 16-color bitmap with needed dimensions in Borland Image Editor\r
   and paste a bitmap image, copyed in another graphic tool, and then save it.\r
   If this is not done, bitmap will not be loaded correctly! }\r
function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PChar; const Map: array of TColor )\r
         : HBitmap;\r
{* Like LoadMappedBitmap, but much powerful. It uses CreateMappedBitmapEx\r
   by Alex Pravdin, so it understands any bitmap color format, including\r
   pf24bit. Also, LoadMappedBitmapEx provides auto-destroying loaded resource\r
   when MasterObj is destroyed. }\r
function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;\r
  Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; stdcall;\r
{* Creates mapped bitmap replacing colors correspondently to the\r
   ColorMap (each pare of colors defines color replaced and a color\r
   used for replace it in the bitmap). See also CreateMappedBitmapEx. }\r
function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PChar; Flags:\r
  Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap;\r
{* By Alex Pravdin.\r
Creates mapped bitmap independently from bitmap color format (works\r
correctly with bitmaps having format deeper than 8bit per pixel). }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
//[ICONS]\r
\r
type\r
  {++}(*TIcon = class;*){--}\r
  PIcon = {-}^{+}TIcon;\r
{ ----------------------------------------------------------------------\r
\r
                          TIcon - icon image\r
\r
----------------------------------------------------------------------- }\r
//[TIcon DEFINITION]\r
  TIcon = object( TObj )\r
  {* Object type to incapsulate icon or cursor image. }\r
  protected\r
    FSize : Integer;\r
    FHandle: HIcon;\r
    FShareIcon: Boolean;\r
    procedure SetSize(const Value: Integer);\r
    procedure SetHandle(const Value: HIcon);\r
    function GetHotSpot: TPoint;\r
    function GetEmpty: Boolean;\r
  protected\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
  public\r
    property Size : Integer read FSize write SetSize;\r
    {* Icon dimension (width and/or height, which are equal to each other always). }\r
    property Handle : HIcon read FHandle write SetHandle;\r
    {* Windows icon object handle. }\r
    procedure Clear;\r
    {* Clears icon, freeing image and allocated GDI resource (Handle). }\r
    property Empty: Boolean read GetEmpty;\r
    {* Returns True if icon is Empty. }\r
    property ShareIcon : Boolean read FShareIcon write FShareIcon;\r
    {* True, if icon object is shared and can not be deleted when TIcon object\r
       is destroyed (set this flag is to True, if an icon is obtained from another\r
       TIcon object, for example). }\r
    property HotSpot : TPoint read GetHotSpot;\r
    {* Hot spot point - for cursors. }\r
    procedure Draw( DC : HDC; X, Y : Integer );\r
    {* Draws icon onto given device context. Icon always is drawn transparently\r
       using its transparency mask (stored internally in icon object). }\r
    procedure StretchDraw( DC : HDC; Dest : TRect );\r
    {* Draws icon onto given device context with stretching it to fit destination\r
       rectangle. See also Draw. }\r
    procedure LoadFromStream( Strm : PStream );\r
    {* Loads icon from stream. If stream contains several icons (of\r
       different dimentions), icon with the most appropriate size is loading. }\r
    procedure LoadFromFile( const FileName : String );\r
    {* Load icon from file. If file contains several icons (of\r
       different dimensions), icon with the most appropriate size is loading. }\r
    procedure LoadFromResourceID( Inst: Integer; ResID: Integer; DesiredSize: Integer );\r
    {* Loads icon from resource. To load system default icon, pass 0 as Inst and\r
       one of followin values as ResID:\r
       |<pre>\r
       IDI_APPLICATION  Default application icon.\r
       IDI_ASTERISK     Asterisk (used in informative messages).\r
       IDI_EXCLAMATION  Exclamation point (used in warning messages).\r
       IDI_HAND         Hand-shaped icon (used in serious warning messages).\r
       IDI_QUESTION     Question mark (used in prompting messages).\r
       IDI_WINLOGO      Windows logo.\r
       |</pre> It is also possible to load icon from resources of another module,\r
       if pass instance handle of loaded module as Inst parameter. }\r
    procedure LoadFromResourceName( Inst: Integer; ResName: PChar; DesiredSize: Integer );\r
    {* Loads icon from resource. To load own application resource, pass\r
       hInstance as Inst parameter. It is possible to load resource from\r
       another module, if pass its instance handle as Inst. }\r
    procedure LoadFromExecutable( const FileName: String; IconIdx: Integer );\r
    {* Loads icon from executable (exe or dll file). Always default sized icon\r
       is loaded. It is possible also to get know how much icons are contained\r
       in executable using gloabl function GetFileIconCount. To obtain icon of\r
       another size, try to load given executable and use LoadFromResourceID\r
       method. }\r
    procedure SaveToStream( Strm : PStream );\r
    {* Saves single icon to stream. To save icons with several different\r
       dimensions, use global procedure SaveIcons2Stream. }\r
    procedure SaveToFile( const FileName : String );\r
    {* Saves single icon to file. To save icons with several different\r
       dimensions, use global procedure SaveIcons2File. }\r
    function Convert2Bitmap( TranColor: TColor ): HBitmap;\r
    {* Converts icon to bitmap, returning Windows GDI bitmap resource as\r
       a result. It is possible later to assign returned bitmap handle to\r
       Handle property of TBitmap object to use features of TBitmap.\r
       Pass TranColor to replace transparent area of icon with given color. }\r
  end;\r
//[END OF TIcon DEFINITION]\r
\r
//[Icon save functions]\r
\r
  procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream );\r
  {* Saves several icons (of different dimentions) to stream. }\r
  function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean;\r
  {* Saves icons creating it from pairs of bitmaps and their masks.\r
     BmpHandles array must contain pairs of bitmap handles, each pair\r
     of color bitmap and mask bitmap of the same size. }\r
  procedure SaveIcons2File( const Icons : array of PIcon; const FileName : String );\r
  {* Saves several icons (of different dimentions) to file. (Single file\r
     with extension .ico can contain several different sized icon images\r
     to use later one with the most appropriate size). }\r
\r
//[NewIcon DECLARATION]\r
  function NewIcon: PIcon;\r
  {* Creates new icon object, setting its Size to 32 by default. Created icon\r
     is Empty. }\r
\r
//[GetFileIconCount DECLARATION]\r
  function GetFileIconCount( const FileName: String ): Integer;\r
  {* Returns number of icon resources stored in given (executable) file. }\r
\r
//[ICON STRUCTURES]\r
type\r
  TIconHeader = packed record\r
    idReserved: Word; (* Always set to 0 *)\r
    idType: Word;     (* Always set to 1 *)\r
    idCount: Word;    (* Number of icon images *)\r
    (* immediately followed by idCount TIconDirEntries *)\r
  end;\r
\r
  TIconDirEntry = packed record\r
    bWidth: Byte;          (* Width *)\r
    bHeight: Byte;         (* Height *)\r
    bColorCount: Byte;     (* Nr. of colors used, see below *)\r
    bReserved: Byte;       (* not used, 0 *)\r
    wPlanes: Word;         (* not used, 0 *)\r
    wBitCount: Word;       (* not used, 0 *)\r
    dwBytesInRes: Longint; (* total number of bytes in images *)\r
    dwImageOffset: Longint;(* location of image from the beginning of file *)\r
  end;\r
\r
//[LoadImgIcon DECLARATION]\r
function LoadImgIcon( RsrcName: PChar; Size: Integer ): HIcon;\r
{* Loads icon of specified size from the resource. }\r
\r
\r
\r
\r
\r
\r
\r
\r
//[METAFILES]\r
\r
type\r
  {++}(*TMetafile = class;*){--}\r
  PMetafile = {-}^{+}TMetafile;\r
{ ----------------------------------------------------------------------\r
\r
      TMetafile - Windows metafile and Enchanced Metafile image\r
\r
----------------------------------------------------------------------- }\r
//[TMetafile DEFINITION]\r
  TMetafile = object( TObj )\r
  {* Object type to incapsulate metafile image. }\r
  protected\r
    function GetHeight: Integer;\r
    function GetWidth: Integer;\r
    procedure SetHandle(const Value: THandle);\r
  protected\r
    fHandle: THandle;\r
    fHeader: PEnhMetaHeader;\r
    procedure RetrieveHeader;\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
    procedure Clear;\r
    {* }\r
    function Empty: Boolean;\r
    {* Returns TRUE if empty}\r
    property Handle: THandle read fHandle write SetHandle;\r
    {* Returns handle of enchanced metafile. }\r
    function LoadFromStream( Strm: PStream ): Boolean;\r
    {* Loads emf or wmf file format from stream. }\r
    function LoadFromFile( const Filename: String ): Boolean;\r
    {* Loads emf or wmf from stream. }\r
    procedure Draw( DC: HDC; X, Y: Integer );\r
    {* Draws enchanced metafile on DC. }\r
    procedure StretchDraw( DC: HDC; const R: TRect );\r
    {* Draws enchanced metafile stretched. }\r
    property Width: Integer read GetWidth;\r
    {* Native width of the metafile. }\r
    property Height: Integer read GetHeight;\r
    {* Native height of the metafile. }\r
  end;\r
//[END OF TMetafile DEFINITION]\r
\r
//[NewMetafile DECLARATION]\r
function NewMetafile: PMetafile;\r
{* Creates metafile object. }\r
\r
//[Metafile CONSTANTS, STRUCTURES, ETC.]\r
const\r
  WMFKey = Integer($9AC6CDD7);\r
  WMFWord = $CDD7;\r
type\r
  TMetafileHeader = packed record\r
    Key: Longint;\r
    Handle: SmallInt;\r
    Box: TSmallRect;\r
    Inch: Word;\r
    Reserved: Longint;\r
    CheckSum: Word;\r
  end;\r
\r
function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;\r
\r
{++}(*\r
function SetEnhMetaFileBits(p1: UINT; p2: PChar): HENHMETAFILE; stdcall;\r
function PlayEnhMetaFile(DC: HDC; p2: HENHMETAFILE; const p3: TRect): BOOL; stdcall;\r
*){--}\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
////////////////////////////////////////////////////////////////////////////////\r
//                       UNIVERSAL CONTROL OBJECT                             //\r
////////////////////////////////////////////////////////////////////////////////\r
\r
//[CM_XXX CONSTANTS]\r
\r
const\r
  CM_EXECPROC       = $8FFF;\r
  CM_BASE           = $B000;\r
  CM_ACTIVATE       = CM_BASE + 0;\r
  CM_DEACTIVATE     = CM_BASE + 1;\r
  CM_ENTER          = CM_BASE + 2;\r
  CM_RELEASE        = CM_BASE + 3;\r
  CM_QUIT           = CM_BASE + 4;\r
  CM_COMMAND        = CM_BASE + 5;\r
  CM_MEASUREITEM    = CM_BASE + 6;\r
  CM_DRAWITEM       = CM_BASE + 7;\r
  CM_TRAYICON       = CM_BASE + 8;\r
  CM_INVALIDATE     = CM_BASE + 9;\r
  CM_UPDATE         = CM_BASE + 10;\r
  CM_NCUPDATE       = CM_BASE + 11;\r
  CM_SIZEPOS        = CM_BASE + 12;\r
  CM_SIZE           = CM_BASE + 13;\r
  CM_SETFOCUS       = CM_BASE + 14;\r
  CM_CBN_SELCHANGE  = 15;\r
\r
  CM_UIACTIVATE     = CM_BASE + 16;\r
  CM_UIDEACTIVATE   = CM_BASE + 17;\r
  CM_PROCESS        = CM_BASE + 18;\r
  CM_SHOW           = CM_BASE + 19;\r
\r
  //CM_CLOSE           = CM_BASE + 20;\r
  CM_MDIClientShowEdge = CM_BASE + 21;\r
\r
//[CN_XXX CONSTANTS]\r
\r
  CN_BASE = $BC00;\r
  CN_CHARTOITEM        = CN_BASE + WM_CHARTOITEM;\r
  CN_COMMAND           = CN_BASE + WM_COMMAND;\r
  CN_COMPAREITEM       = CN_BASE + WM_COMPAREITEM;\r
\r
  CN_CTLCOLORMSGBOX    = CN_BASE + WM_CTLCOLORMSGBOX;\r
  CN_CTLCOLOREDIT      = CN_BASE + WM_CTLCOLOREDIT;\r
  CN_CTLCOLORLISTBOX   = CN_BASE + WM_CTLCOLORLISTBOX;\r
  CN_CTLCOLORBTN       = CN_BASE + WM_CTLCOLORBTN;\r
  CN_CTLCOLORDLG       = CN_BASE + WM_CTLCOLORDLG;\r
  CN_CTLCOLORSCROLLBAR = CN_BASE + WM_CTLCOLORSCROLLBAR;\r
  CN_CTLCOLORSTATIC    = CN_BASE + WM_CTLCOLORSTATIC;\r
\r
  CN_DELETEITEM        = CN_BASE + WM_DELETEITEM;\r
  CN_DRAWITEM          = CN_BASE + WM_DRAWITEM;\r
  CN_HSCROLL           = CN_BASE + WM_HSCROLL;\r
  CN_MEASUREITEM       = CN_BASE + WM_MEASUREITEM;\r
  CN_PARENTNOTIFY      = CN_BASE + WM_PARENTNOTIFY;\r
  CN_VKEYTOITEM        = CN_BASE + WM_VKEYTOITEM;\r
  CN_VSCROLL           = CN_BASE + WM_VSCROLL;\r
  CN_KEYDOWN           = CN_BASE + WM_KEYDOWN;\r
  CN_KEYUP             = CN_BASE + WM_KEYUP;\r
  CN_CHAR              = CN_BASE + WM_CHAR;\r
  CN_SYSKEYDOWN        = CN_BASE + WM_SYSKEYDOWN;\r
  CN_SYSCHAR           = CN_BASE + WM_SYSCHAR;\r
  CN_NOTIFY            = CN_BASE + WM_NOTIFY;\r
\r
\r
//[ID_SELF DEFINED]\r
  ID_SELF: array[ 0..5 ] of Char = ( 'S','E','L','F','_',#0 );\r
  {* Identifier for window property "Self", stored directly in window, when\r
     it is created. This property is used to [fast] find TControl object,\r
     correspondent to given window handle (using API call GetProp). }\r
\r
//[ID_PREVPROC DEFINED]\r
  ID_PREVPROC: array[ 0..9 ] of Char = ( 'P','R','E','V','_','P','R','O','C',#0 );\r
  {* }\r
\r
//[MK_ALT DEFINED]\r
  MK_ALT = $20;\r
\r
//[RICHEDIT STRUCTURES]\r
type\r
  TCharFormat2A = packed record\r
    cbSize: UINT;\r
    dwMask: DWORD;\r
    dwEffects: DWORD;\r
    yHeight: Longint;\r
    yOffset: Longint;\r
    crTextColor: TColorRef;\r
    bCharSet: Byte;\r
    bPitchAndFamily: Byte;\r
    szFaceName: array[0..LF_FACESIZE - 1] of AnsiChar;\r
    R2Bytes: Word;\r
    wWeight: Word;                   { Font weight (LOGFONT value)               }\r
    sSpacing: Smallint;              { Amount to space between letters   }\r
    crBackColor: TColorRef;          { Background color                                  }\r
    lid: LCID;                       { Locale ID                                                 }\r
    dwReserved: DWORD;               { Reserved. Must be 0                               }\r
    sStyle: Smallint;                { Style handle                                              }\r
    wKerning: Word;                  { Twip size above which to kern char pair }\r
    bUnderlineType: Byte;            { Underline type                                    }\r
    bAnimation: Byte;                { Animated text like marching ants  }\r
    bRevAuthor: Byte;                { Revision author index                     }\r
    bReserved1: Byte;\r
  end;\r
  TCharFormat2 = TCharFormat2A;\r
\r
  TParaFormat2 = packed record\r
    cbSize: UINT;\r
    dwMask: DWORD;\r
    wNumbering: Word;\r
    wReserved: Word;\r
    dxStartIndent: Longint;\r
    dxRightIndent: Longint;\r
    dxOffset: Longint;\r
    wAlignment: Word;\r
    cTabCount: Smallint;\r
    rgxTabs: array [0..MAX_TAB_STOPS - 1] of Longint;\r
    dySpaceBefore: Longint;     { Vertical spacing before para                   }\r
    dySpaceAfter: Longint;      { Vertical spacing after para                    }\r
    dyLineSpacing: Longint;     { Line spacing depending on Rule                 }\r
    sStyle: Smallint;           { Style handle                                                   }\r
    bLineSpacingRule: Byte;     { Rule for line spacing (see tom.doc)    }\r
    bCRC: Byte;                 { Reserved for CRC for rapid searching   }\r
    wShadingWeight: Word;       { Shading in hundredths of a per cent    }\r
    wShadingStyle: Word;        { Nibble 0: style, 1: cfpat, 2: cbpat    }\r
    wNumberingStart: Word;      { Starting value for numbering                   }\r
    wNumberingStyle: Word;      { Alignment, roman/arabic, (), ), ., etc. }\r
    wNumberingTab: Word;        { Space bet 1st indent and 1st-line text }\r
    wBorderSpace: Word;         { Space between border and text (twips) }\r
    wBorderWidth: Word;         { Border pen width (twips)                               }\r
    wBorders: Word;             { Byte 0: bits specify which borders     }\r
                                { Nibble 2: border style, 3: color index }\r
  end;\r
\r
  TGetTextLengthEx = packed record\r
    flags: DWORD;              { flags (see GTL_XXX defines)                             }\r
    codepage: UINT;            { code page for translation (CP_ACP for default,\r
                                 1200 for Unicode                                        }\r
  end;\r
\r
const\r
  PFM_SPACEBEFORE                     = $00000040;\r
  PFM_SPACEAFTER                      = $00000080;\r
  PFM_LINESPACING                     = $00000100;\r
  PFM_STYLE                           = $00000400;\r
  PFM_BORDER                          = $00000800;      { (*)    }\r
  PFM_SHADING                         = $00001000;      { (*)    }\r
  PFM_NUMBERINGSTYLE                  = $00002000;      { (*)    }\r
  PFM_NUMBERINGTAB                    = $00004000;      { (*)    }\r
  PFM_NUMBERINGSTART                  = $00008000;      { (*)    }\r
\r
  PFM_RTLPARA                         = $00010000;\r
  PFM_KEEP                            = $00020000;      { (*)    }\r
  PFM_KEEPNEXT                        = $00040000;      { (*)    }\r
  PFM_PAGEBREAKBEFORE                 = $00080000;      { (*)    }\r
  PFM_NOLINENUMBER                    = $00100000;      { (*)    }\r
  PFM_NOWIDOWCONTROL                  = $00200000;      { (*)    }\r
  PFM_DONOTHYPHEN                     = $00400000;      { (*)    }\r
  PFM_SIDEBYSIDE                      = $00800000;      { (*)    }\r
\r
  PFM_TABLE                           = $c0000000;      { (*)    }\r
  EM_REDO                             = WM_USER + 84;\r
  EM_AUTOURLDETECT                    = WM_USER + 91;\r
  EM_GETAUTOURLDETECT                 = WM_USER + 92;\r
  CFM_UNDERLINETYPE           = $00800000;              { (*)    }\r
  CFM_HIDDEN                  = $0100;                  { (*)    }\r
  CFM_BACKCOLOR               = $04000000;\r
  CFE_AUTOBACKCOLOR           = CFM_BACKCOLOR; \r
  GTL_USECRLF         = 1;      { compute answer using CRLFs for paragraphs }\r
  GTL_PRECISE         = 2;      { compute a precise answer                                       }\r
  GTL_CLOSE           = 4;      { fast computation of a "close" answer           }\r
  GTL_NUMCHARS        = 8;      { return the number of characters                        }\r
  GTL_NUMBYTES        = 16;     { return the number of _bytes_                           }\r
  EM_GETTEXTLENGTHEX                  = WM_USER + 95; \r
  EM_SETLANGOPTIONS                   = WM_USER + 120; \r
  EM_GETLANGOPTIONS                   = WM_USER + 121;\r
\r
  EM_SETEDITSTYLE = $400 + 204;\r
  EM_GETEDITSTYLE = $400 + 205;\r
\r
  SES_EMULATESYSEDIT = 1;\r
  SES_BEEPONMAXTEXT = 2;\r
  SES_EXTENDBACKCOLOR = 4;\r
  SES_MAPCPS = 8;\r
  SES_EMULATE10 = 16;\r
  SES_USECRLF = 32;\r
  SES_USEAIMM = 64;\r
  SES_NOIME = 128;\r
  SES_ALLOWBEEPS = 256;\r
  SES_UPPERCASE = 512;\r
  SES_LOWERCASE = 1024;\r
  SES_NOINPUTSEQUENCECHK = 2048;\r
  SES_BIDI = 4096;\r
  SES_SCROLLONKILLFOCUS = 8192;\r
  SES_XLTCRCRLFTOCR = 16384;\r
\r
//[CONTROLS]\r
\r
type\r
  {++}(*TControl = class;*){--}\r
  PControl = {-}^{+}TControl;\r
  {* Type of pointer to TControl visual object. All\r
     |<a href="kol_pas.htm#visual_objects_constructors">\r
     constructing functions\r
     |</a>\r
     New[ControlName] are returning\r
     pointer of this type. Do not forget about some difference\r
     of using objects from using classes. Identifier Self for\r
     methods of object is not of pointer type, and to pass\r
     pointer to Self, it is necessary to pass @Self instead.\r
     At the same time, to use pointer to object in 'WITH' operator,\r
     it is necessary to apply suffix '^' to pointer to get know\r
     to compiler, what do You want. }\r
\r
//[TWindowFunc TYPE]\r
  TWindowFunc = function( Sender: PControl; var Msg: TMsg; var Rslt: Integer )\r
                          : Boolean;\r
  {* Event type to define custom extended message handlers (as pointers to\r
     procedure entry points). Such handlers are usually defined like add-ons,\r
     extending behaviour of certain controls and attached using AttachProc\r
     method of TControl. If the handler detects, that it is necessary to stop\r
     further message processing, it should return True. }\r
\r
\r
//[Mouse TYPES]\r
  TMouseButton = ( mbNone, mbLeft, mbRight, mbMiddle );\r
  {* Available mouse buttons. mbNone is useful to get know, that\r
     there were no mouse buttons pressed. }\r
\r
  TMouseEventData = packed Record\r
  {* Record to pass it to mouse handling routines, assigned to OnMouseXXXX\r
     events. }\r
    Button: TMouseButton;\r
    StopHandling: Boolean; // Set it to True in OnMouseXXXX event handler to\r
                           // stop further processing\r
    R1, R2: Byte; // Not used\r
    Shift : DWORD;    // HiWord( Shift ) = zDelta in WM_MOUSEWHEEL\r
    X, Y  : SmallInt;\r
  end;\r
\r
  TOnMouse = procedure( Sender: PControl; var Mouse: TMouseEventData ) of object;\r
  {* Common mouse handling event type. }\r
\r
//[Key TYPES]\r
  TOnKey = procedure( Sender: PControl; var Key: Longint; Shift: DWORD ) of object;\r
  {* Key events. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT.\r
     (See GetShiftState funtion). }\r
\r
  TOnChar = procedure( Sender: PControl; var Key: Char; Shift: DWORD ) of object;\r
  {* Char event. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT. }\r
\r
  TTabKey = ( tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn );\r
  {* Available tabulating key groups. }\r
  TTabKeys = Set of TTabKey;\r
  {* Set of tabulating key groups, allowed to be used in with a control\r
     (are installed by TControl.LookTabKey property). }\r
\r
//[Event TYPES]\r
  TOnMessage = function( var Msg: TMsg; var Rslt: Integer ): Boolean of object;\r
  {* Event type for events, which allows to extend behaviour of windowed controls\r
     descendants using add-ons. }\r
\r
  TOnEventAccept = procedure( Sender: PObj; var Accept: Boolean ) of object;\r
  {* Event type for OnClose event. }\r
  TCloseQueryReason = ( qClose, qShutdown, qLogoff );\r
  {* Request reason type to call OnClose and OnQueryEndSession. }\r
  TWindowState = ( wsNormal, wsMinimized, wsMaximized );\r
  {* Avalable states of TControl's window object. }\r
\r
  TOnSplit = function( Sender: PControl; NewSize1, NewSize2: Integer ): Boolean of object;\r
  {* Event type for OnSplit event handler, designed specially for splitter\r
     control. Event handler must return True to accept new size of previous\r
     (to splitter) control and new size of the rest of client area of parent. }\r
\r
  TOnTVBeginDrag = procedure( Sender: PControl; Item: THandle ) of object;\r
  {* Event type for OnTVBeginDrag event (defined for tree view control). }\r
  TOnTVBeginEdit = function( Sender: PControl; Item: THandle ): Boolean of object;\r
  {* Event type for OnTVBeginEdit event (for tree view control). }\r
  TOnTVEndEdit = function( Sender: PControl; Item: THandle; const NewTxt: String )\r
               : Boolean of object;\r
  {* Event type for TOnTVEndEdit event. }\r
  TOnTVExpanding = function( Sender: PControl; Item: THandle; Expand: Boolean )\r
                 : Boolean of object;\r
  {* Event type for TOnTVExpanding event. }\r
  TOnTVExpanded = procedure( Sender: PControl; Item: THandle; Expand: Boolean )\r
                of object;\r
  {* Event type for OnTVExpanded event. }\r
  TOnTVDelete = procedure( Sender: PControl; Item: THandle ) of object;\r
  {* Event type for OnTVDelete event. }\r
\r
  //--------- by Sergey Shisminzev:\r
  TOnTVSelChanging = function(Sender: PControl; oldItem, newItem: THandle): Boolean  //~ss\r
                  of object;\r
  {* When the handler returns False, selection is not changed. }\r
  //-------------------------------\r
  TOnDrag = function( Sender: PControl; ScrX, ScrY: Integer; var CursorShape: Integer;\r
            var Stop: Boolean ): Boolean of object;\r
  {* Event, called during dragging operation (it is initiated\r
     with method Drag, where callback function of type TOnDrag is\r
     passed as a parameter). Callback function receives Stop parameter True,\r
     when operation is finishing. Otherwise, it can set it to True to force\r
     finishing the operation (in such case, returning False means cancelling\r
     drag operation, True - successful drag and in this last case callback is\r
     no more called). During the operation, when input Stop value is False,\r
     callback function can control Cursor shape, and return True, if the operation\r
     can be finished successfully at the given ScrX, ScrY position.\r
     ScrX, ScrY are screen coordinates of the mouse cursor. }\r
\r
//[Create Window STRUCTURES]\r
  TCreateParams = packed record\r
  {* Record to pass it through CreateSubClass method. }\r
    Caption: PChar;\r
    Style: cardinal;\r
    ExStyle: cardinal;\r
    X, Y: Integer;\r
    Width, Height: Integer;\r
    WndParent: HWnd;\r
    Param: Pointer;\r
    WindowClass: TWndClass;\r
    WinClassName: array[0..63] of Char;\r
  end;\r
\r
  TCreateWndParams = packed Record\r
    ExStyle: DWORD;\r
    WinClassName: PChar;\r
    Caption: PChar;\r
    Style: DWORD;\r
    X, Y, Width, Height: Integer;\r
    WndParent: HWnd;\r
    Menu: HMenu;\r
    Inst: THandle;\r
    Param: Pointer;\r
    WinClsNamBuf: array[ 0..63 ] of Char;\r
    WindowClass: TWndClass;\r
  end;\r
\r
\r
//[COMMAND ACTIONS TYPE FOR DIFFERENT CONTROLS]\r
  PCommandActions = ^TCommandActions;\r
  TCommandActions = packed Record\r
    aClear: procedure( Sender: PControl );\r
    aAddText: procedure( Sender: PControl; const S: String );\r
    aClick, aEnter, aLeave: WORD; aChange: SmallInt; aSelChange: SmallInt;\r
    aGetCount, aSetCount, aGetItemLength, aGetItemText, aSetItemText,\r
    aGetItemData, aSetItemData: WORD;\r
    aAddItem, aDeleteItem, aInsertItem: WORD;\r
    aFindItem, aFindPartial: WORD;\r
    aItem2Pos, aPos2Item: BYTE;\r
    aGetSelCount, aGetSelected, aGetSelRange, aExGetSelRange, aGetCurrent,\r
    aSetSelected, aSetCurrent, aSetSelRange, aExSetSelRange,\r
    aGetSelection, aReplaceSel: WORD;\r
    aTextAlignLeft, aTextAlignRight, aTextAlignCenter: WORD;\r
    aTextAlignMask: Byte;\r
    aVertAlignCenter, aVertAlignTop, aVertAlignBottom: Byte;\r
    aDir, aSetLimit: Word; aSetImgList: Word;\r
    aAutoSzX, aAutoSzY: Word;\r
    aSetBkColor: Word;\r
    aItem2XY: Word;\r
  end;\r
\r
//[Align TYPES]\r
  TTextAlign = ( taLeft, taRight, taCenter );\r
  {* Text alignments available. }\r
  TRichTextAlign = ( raLeft, raRight, raCenter,\r
                 // all other are only set but can not be displayed:\r
                 raJustify, // displayed like raLeft (though stored normally)\r
                 raInterLetter, raScaled, raGlyphs, raSnapGrid );\r
  {* Text alignment styles, available for RichEdit control. }\r
  TVerticalAlign = ( vaCenter, vaTop, vaBottom );\r
  {* Vertical alignments available. }\r
  TControlAlign = ( caNone, caLeft, caTop, caRight, caBottom, caClient );\r
  {* Control alignments available. }\r
\r
//[BitBtn TYPES]\r
  TBitBtnOption = ( bboImageList,\r
                    bboNoBorder,\r
                    bboNoCaption,\r
                    bboFixed );\r
  {* Options available for NewBitBtn. }\r
  TBitBtnOptions = set of TBitBtnOption;\r
  {* Set of options, available for NewBitBtn. }\r
  TGlyphLayout = ( glyphLeft, glyphTop, glyphRight, glyphBottom, glyphOver );\r
  {* Layout of glyph (for NewBitBtn). Layout glyphOver means that text is\r
     drawn over glyph. }\r
  TOnBitBtnDraw = function( Sender: PControl; BtnState: Integer ): Boolean of object;\r
  {* Event type for TControl.OnBitBtnDraw event (which is called just before\r
     drawing the BitBtn). If handler returns True, there are no drawing occure.\r
     BtnState, passed to a handler, determines current button state and can\r
     be following: 0 - not pressed, 1 - pressed, 2 - disabled, 3 - focused.\r
     Value 4 is reserved for highlight state (then mouse is over it), but\r
     highlighting is provided only if property Flat is set to True (or one\r
     of events OnMouseEnter / OnMouseLeave is assigned to something). }\r
\r
//[ListView TYPES]\r
  TListViewStyle = ( lvsIcon, lvsSmallIcon, lvsList, lvsDetail, lvsDetailNoHeader );\r
  {* Styles of view for ListView control (see NewListVew). }\r
\r
  TListViewItemStates = ( lvisFocus, lvisSelect, lvisBlend, lvisHighlight );\r
  TListViewItemState = Set of TListViewItemStates;\r
  TListViewOption = (\r
    lvoIconLeft,      // in lvsIcon, lvsSmallIcon plce icon left from text (rather then top)\r
    lvoAutoArrange,   // keep icons auto arranged in lvsIcon and lvsSmallIcon view\r
    lvoButton,        // icons look like buttons in lvsIcon view\r
    lvoEditLabel,     // allows edit labels inplace (first column #0 text)\r
    lvoNoLabelWrap,   // item text on a single line in lvsIcon view (by default, item text may wrap in lvsIcon view).\r
    lvoNoScroll,      // obvious\r
    lvoNoSortHeader,  // click on header button does not lead to sort items\r
    lvoHideSel,       // hide selection when not in focus\r
    lvoMultiselect,   // allow to select multiple items\r
    lvoSortAscending,\r
    lvoSortDescending,\r
      // extended styles (not documented in my Win32.hlp :( , got from VCL source:\r
    lvoGridLines,\r
    lvoSubItemImages,\r
    lvoCheckBoxes,\r
    lvoTrackSelect,\r
    lvoHeaderDragDrop,\r
    lvoRowSelect,\r
    lvoOneClickActivate,\r
    lvoTwoClickActivate,\r
    lvoFlatsb,\r
    lvoRegional,\r
    lvoInfoTip,\r
    lvoUnderlineHot,\r
    lvoMultiWorkares,\r
      // virtual list view style:\r
    lvoOwnerData,\r
      // custom draw style:\r
    lvoOwnerDrawFixed\r
     );\r
  TListViewOptions = Set of TListViewOption;\r
\r
  TOnEditLVItem = function( Sender: PControl; Idx, Col: Integer; NewText: PChar ): Boolean\r
                  of object;\r
  {* Event type for OnEndEditLVItem. Return True in handler to accept new text value. }\r
  TOnDeleteLVItem = procedure( Sender: PControl; Idx: Integer ) of object;\r
  {* Event type for OnDeleteLVItem event. }\r
  TOnLVData = procedure( Sender: PControl; Idx, SubItem: Integer;\r
              var Txt: String; var ImgIdx: Integer; var State: DWORD;\r
              var Store: Boolean ) of object;\r
  {* Event type for OnLVData event. Used to provide virtual list view control\r
     (i.e. having lvoOwnerData style) with actual data on request. Use parameter\r
     Store as a flag if control should store obtained data by itself or not. }\r
  {$IFNDEF _D2}\r
  {$IFNDEF _FPC}\r
  TOnLVDataW = procedure( Sender: PControl; Idx, SubItem: Integer;\r
              var Txt: WideString; var ImgIdx: Integer; var State: DWORD;\r
              var Store: Boolean ) of object;\r
  {* Event type for OnLVDataW event (the same as OnLVData, but for unicode verion\r
     of the control OnLVDataW allows to return WideString text in the event\r
     handler). Used to provide virtual list view control\r
     (i.e. having lvoOwnerData style) with actual data on request. Use parameter\r
     Store as a flag if control should store obtained data by itself or not. }\r
  {$ENDIF _FPC}\r
  {$ENDIF _D2}\r
  TOnCompareLVItems = function( Sender: PControl; Idx1, Idx2: Integer ): Integer\r
                    of object;\r
  {* Event type to compare two items of the list view (while sorting it). }\r
  TOnLVColumnClick = procedure( Sender: PControl; Idx: Integer ) of object;\r
  {* Event type for OnColumnClick event. }\r
  TOnLVStateChange = procedure( Sender: PControl; IdxFrom, IdxTo: Integer; OldState, NewState: DWORD )\r
                   of object;\r
  {* Event type for OnLVStateChange event, called in responce to select/unselect\r
     a single item or items range in list view control). }\r
  TOnLVDelete = procedure( Sender: PControl; Idx: Integer ) of object;\r
  {* Event type for OnLVDelete event, called when an item is been deleting. }\r
\r
  TDrawActions = ( odaEntire, odaFocus, odaSelect );\r
  TDrawAction = Set of TDrawActions;\r
  TDrawStates = ( odsSelected, odsGrayed, odsDisabled, odsChecked, odsFocused,\r
                  odsDefault, odsHotlist, odsInactive,\r
                  odsNoAccel, odsNoFocusRect,\r
                  ods400reserved, ods800reserved,\r
                  odsComboboxEdit,\r
                  // specific for common controls:\r
                  odsMarked, odsIndeterminate );\r
  {* Possible draw states.\r
     |<br>odsSelected - The menu item's status is selected.\r
     |<br>odsGrayed - The item is to be grayed. This bit is used only in a menu.\r
     |<br>odsDisabled - The item is to be drawn as disabled.\r
     |<br>odsChecked - The menu item is to be checked. This bit is used only in\r
                     a menu.\r
     |<br>odsFocused - The item has the keyboard focus.\r
     |<br>odsDefault - The item is the default item.\r
     |<br>odsHotList - <b>Windows 98, Windows 2000:</b> The item is being\r
                     hot-tracked, that is, the item will be highlighted when\r
                     the mouse is on the item.\r
     |<br>odsInactive - <b>Windows 98, Windows 2000:</b> The item is inactive\r
                      and the window associated with the menu is inactive.\r
     |<br>odsNoAccel - <b>Windows 2000:</b> The control is drawn without the\r
                     keyboard accelerator cues.\r
     |<br>odsNoFocusRect - <b>Windows 2000:</b> The control is drawn without\r
                         focus indicator cues.\r
     |<br>odsComboboxEdit - The drawing takes place in the selection field\r
                          (edit control) of an owner-drawn combo box.\r
     |<br>odsMarked - for Common controls only. The item is marked. The meaning\r
                    of this is up to the implementation.\r
     |<br>odsIndeterminate - for Common Controls only. The item is in an\r
                           indeterminate state. }\r
  TDrawState = Set of TDrawStates;\r
  {* Set of possible draw states. }\r
  TOnDrawItem = function( Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer;\r
                           DrawAction: TDrawAction; ItemState: TDrawState ): Boolean of object;\r
  {* Event type for OnDrawItem event (applied to list box, combo box, list view). }\r
  TOnMeasureItem = function( Sender: PObj; Idx: Integer ): Integer of object;\r
  {* Event type for OnMeasureItem event. The event handler must return height of list box\r
     item as a result. }\r
  TGetLVItemPart = ( lvipBounds, lvipIcon, lvipLabel, lvupIconAndLabel );\r
  {* }\r
  TWherePosLVItem = ( lvwpOnIcon, lvwpOnLabel, lvwpOnStateIcon, lvwpOnColumn,\r
                  lvwpOnItem );\r
  {* }\r
\r
  TOnLVCustomDraw = function( Sender: PControl; DC: HDC; Stage: DWORD;\r
                  ItemIdx, SubItemIdx: Integer; const Rect: TRect;\r
                  ItemState: TDrawState; var TextColor, BackColor: TColor )\r
                  : DWORD of object;\r
  {* Event type for OnLVCustomDraw event. }\r
\r
//[Paint TYPES]\r
  TOnPaint = procedure( Sender: PControl; DC: HDC ) of object;\r
\r
  TGradientStyle = ( gsVertical, gsHorizontal, gsRectangle, gsElliptic, gsRombic );\r
  {* Gradient fill styles. See also TGradientLayout. }\r
  TGradientLayout = ( glTopLeft, glTop, glTopRight,\r
                      glLeft, glCenter, glRight,\r
                      glBottomLeft, glBottom, glBottomRight );\r
  {* Position of starting line / point for gradient filling. Depending on\r
     TGradientStyle, means either position of first line of first rectangle\r
     (ellipse) to be expanded in a loop to fit entire gradient panel area. }\r
\r
//[Edit TYPES]\r
  TEditOption = ( eoNoHScroll, eoNoVScroll, eoLowercase, eoMultiline,\r
                  eoNoHideSel, eoOemConvert, eoPassword, eoReadonly,\r
                  eoUpperCase, eoWantReturn, eoWantTab, eoNumber );\r
  {* Available edit options.\r
  |<br> Please note, that eoWantTab option just removes TAB key from a list\r
  of keys available to tabulate from the edit control. To provide insertion\r
  of tabulating key, do so in TControl.OnChar event handler. Sorry for\r
  inconvenience, but this is because such behaviour is not must in all cases.\r
  See also TControl.EditTabChar property.  }\r
  TEditOptions = Set of TEditOption;\r
  {* Set of available edit options. }\r
\r
  TRichFmtArea = ( raSelection, raWord, raAll );\r
  {* Characters formatting area for RichEdit. }\r
  TRETextFormat = ( reRTF, reText, rePlainRTF, reRTFNoObjs, rePlainRTFNoObjs,\r
                    reTextized );\r
  {* Available formats for transfer RichEdit text using property\r
     TControl.RE_Text.\r
     |<pre>\r
     reRTF - normal rich text (no transformations)\r
     reText - plain text only (without OLE objects)\r
     reTextized - plain text with text representation of OLE objects\r
     rePlainRTF - reRTF without language-specific keywords\r
     reRTFNoObjs - reRTF without OLE objects\r
     rePlainRTFNoObjs - rePlainRTF without OLE objects\r
     |</pre> }\r
  TRichUnderline = ( ruSingle, ruWord, ruDouble, ruDotted,\r
                 //all other - only for RichEditv3.0:\r
                 ruDash, ruDashDot, ruDashDotDot, ruWave, ruThick, ruHairLine );\r
  {* Rich text exteded underline styles (available only for RichEdit v2.0,\r
     and even for RichEdit v2.0 additional styles can not displayed - but\r
     ruDotted under Windows2000 is working). }\r
  TRichTextSizes = ( rtsNoUseCRLF, rtsNoPrecise, rtsClose, rtsBytes );\r
  {* Options to calculate size of rich text. Available only for RichEdit2.0\r
     or higher. }\r
  TRichTextSize = set of TRichTextSizes;\r
  {* Set of all available optioins to calculate rich text size using\r
     property TControl.RE_TextSize[ options ]. }\r
  TRichNumbering = ( rnNone, rnBullets, rnArabic, rnLLetter, rnULetter,\r
                rnLRoman, rnURoman );\r
  {* Advanced numbering styles for paragraph (RichEdit).\r
     |<pre>\r
     rnNone     - no numbering\r
     rnBullets  - bullets only\r
     rnArabic   - 1, 2, 3, 4, ...\r
     rnLLetter  - a, b, c, d, ...\r
     rnULetter  - A, B, C, D, ...\r
     rnLRoman   - i, ii, iii, iv, ...\r
     rnURoman   - I, II, III, IV, ...\r
     rnNoNumber - do not show any numbers (but numbering is taking place).\r
     |</pre> }\r
  TRichNumBrackets = ( rnbRight, rnbBoth, rnbPeriod, rnbPlain, rnbNoNumber );\r
  {* Brackets around number:\r
     |<pre>\r
     rnbRight   - 1) 2) 3)     - this is default !\r
     rnbBoth    - (1) (2) (3)\r
     rnbPeriod  - 1. 2. 3.\r
     rnbPlain   - 1 2 3\r
     |</pre> }\r
  TBorderEdge = (beLeft, beTop, beRight, beBottom);\r
  {* Borders of rectangle. }\r
\r
  TCharFormat = TCharFormat2;\r
  TParaFormat = TParaFormat2;\r
\r
  TOnTestMouseOver = function( Sender: PControl ): Boolean of object;\r
  {* Event type for TControl.OnTestMouseOver event. The handler should\r
     return True, if it dectects, that mouse is over control. }\r
\r
  TEdgeStyle = ( esRaised, esLowered, esNone );\r
  {* Edge styles (for panel - see NewPanel). }\r
\r
//[List TYPES]\r
  TListOption = ( loNoHideScroll, loNoExtendSel, loMultiColumn, loMultiSelect,\r
                  loNoIntegralHeight, loNoSel, loSort, loTabstops,\r
                  loNoStrings, loNoData, loOwnerDrawFixed, loOwnerDrawVariable );\r
  {* Options for ListBox (see NewListbox). }\r
  TListOptions = Set of TListOption;\r
  {* Set of available options for Listbox. }\r
\r
  TComboOption = ( coReadOnly, coNoHScroll, coAlwaysVScroll, coLowerCase,\r
                   coNoIntegralHeight, coOemConvert, coSort, coUpperCase,\r
                   coOwnerDrawFixed, coOwnerDrawVariable, coSimple );\r
  {* Options for combobox. }\r
  TComboOptions = Set of TComboOption;\r
  {* Set of options available for combobox. }\r
\r
//[Progress TYPES]\r
  TProgressbarOption = ( pboVertical, pboSmooth );\r
  {* Options for progress bar. }\r
  TProgressbarOptions = set of TProgressbarOption;\r
  {* Set of options available for progress bar. }\r
\r
//[TreeView TYPES]\r
  TTreeViewOption = ( tvoNoLines, tvoLinesRoot, tvoNoButtons, tvoEditLabels, tvoHideSel,\r
                  tvoDragDrop, tvoNoTooltips, tvoCheckBoxes, tvoTrackSelect,\r
                  tvoSingleExpand, tvoInfoTip, tvoFullRowSelect, tvoNoScroll,\r
                  tvoNonEvenHeight );\r
  {* Tree view options. }\r
  TTreeViewOptions = set of TTreeViewOption;\r
  {* Set of tree view options. }\r
\r
//[TabControl TYPES]\r
  TTabControlOption = ( tcoButtons, tcoFixedWidth, tcoFocusTabs,\r
                        tcoIconLeft, tcoLabelLeft,\r
                        tcoMultiline, tcoMultiselect, tcoFitRows, tcoScrollOpposite,\r
                        tcoBottom, tcoVertical, tcoFlat, tcoHotTrack, tcoBorder,\r
                        tcoOwnerDrawFixed );\r
  {* Options, available for TabControl. }\r
  TTabControlOptions = set of TTabControlOption;\r
  {* Set of options, available for TAbControl during its creation (by\r
     NewTabControl function). }\r
\r
//[Toolbar TYPES]\r
  TToolbarOption = ( tboTextRight, tboTextBottom, tboFlat, tboTransparent,\r
                 tboWrapable, tboNoDivider, tbo3DBorder );\r
  {* Toolbar options. When tboFlat is set and toolbar is placed onto panel,\r
     set its property Transparent to TRUE to provide its correct view. }\r
  TToolbarOptions = Set of TToolbarOption;\r
  {* Set of toolbar options. }\r
  TOnToolbarButtonClick = procedure( Sender: PControl; BtnID: Integer ) of object;\r
  {* Special event type to handle separate toolbar buttons click events. }\r
\r
  TDateTimePickerOption = ( dtpoTime, dtpoDateLong, dtpoUpDown, dtpoRightAlign,\r
    dtpoShowNone, dtpoParseInput );\r
  {* }\r
  TDateTimePickerOptions = set of TDateTimePickerOption;\r
  {* }\r
  TDTParseInputEvent = procedure(Sender: PControl; const UserString: string;\r
    var DateAndTime: TDateTime; var AllowChange: Boolean) of object;\r
  {* }\r
  TDateTimeRange = array[ 0..1 ] of TDateTime;\r
  {* }\r
  TDateTimePickerColor = ( dtpcBackground, dtpcMonthBk, dtpcText, dtpcTitleBk,\r
    dtpcTitleText, dtpcTrailingText );\r
\r
//[TOnDropFiles TYPE]\r
  TOnDropFiles = procedure( Sender: PControl; const FileList: String; const Pt: TPoint ) of object;\r
  {* An event type for OnDropFiles event. When the event is occur, FileList\r
     parameter contains a list of files dropped. File names in a list are\r
     separated with #13 character. This allows You to assign it to TStrList\r
     object using its property Text (for example):\r
     ! procedure TSomeObject.DropFiles( Sender: PControl; const FileList: String;\r
     !           const Pt: TPoint ); )\r
     ! var FList: PStrList;\r
     !     I: Integer;\r
     ! begin\r
     !   FList := NewStrList;\r
     !   FList.Text := FileList;\r
     !   for I := 0 to FList.Count-1 do\r
     !   begin\r
     !     // do something with FList.Items[ I ]\r
     !   end;\r
     !   FList.Free;\r
     ! end; }\r
\r
//[Scroll TYPES]\r
  TScrollerBar = ( sbHorizontal, sbVertical );\r
  TScrollerBars = set of TScrollerBar;\r
\r
  TOnScroll = procedure( Sender: PControl; Bar: TScrollerBar; ScrollCmd: DWORD;\r
            ThumbPos: DWORD ) of object;\r
\r
//[TOnHelp EVENT TYPE]\r
  TOnHelp = procedure( var Sender: PControl; var Context: Integer; var Popup: Boolean )\r
            of object;\r
\r
//[ScrollBar TYPES]\r
  TOnSBBeforeScroll =\r
    procedure(\r
      Sender: PControl; OldPos, NewPos: Integer; Cmd: Word;\r
      var AllowChange: Boolean) of object;\r
  TOnSBScroll = procedure(Sender: PControl; Cmd: Word) of object;\r
\r
\r
  {$IFDEF USE_MHTOOLTIP}\r
  {$DEFINE pre_interface}\r
  {$I KOLMHToolTip}\r
  {$UNDEF pre_interface}\r
  {$ENDIF}\r
\r
{ ----------------------------------------------------------------------\r
\r
             TControl - object to implement any visual control\r
\r
----------------------------------------------------------------------- }\r
//[TControl DEFINITION]\r
  TControl = object( TObj )\r
  protected\r
    fSBMinMax: TPoint;\r
    fSBPageSize: Integer;\r
    fSBPosition: Integer;\r
    procedure SetSBMax(Value: Longint);\r
    procedure SetSBMin(Value: Longint);\r
    procedure SetSBPageSize(Value: Integer);\r
    procedure SetSBPosition(Value: Integer);\r
    procedure SetSBMinMax(const Value: TPoint);\r
\r
    function GetDate: TDateTime;\r
    function GetTime: TDateTime;\r
    procedure SetDate(const Value: TDateTime);\r
    procedure SetTime(const Value: TDateTime);\r
  {*! TControl is the basic visual object of KOL. And now, all visual\r
     objects have the same type PControl, differing only in "constructor",\r
     which during creating of object adjusts it so it can play role of\r
     desired control. Idea of incapsulating of all visual objects having\r
     the most common set of properties, is belonging to Vladimir Kladov,\r
     (C) 2000.\r
     |<br>&nbsp;&nbsp;&nbsp;<b> Since all visual objects are represented\r
     in KOL by this single object type, not all methods, properties and\r
     events defined in TControl, are applicable to different visual objects.\r
     See also notes about certain control kinds, located together with its\r
     |<a href="kol_pas.htm#visual_objects_constructors">\r
     |constructing functions definitions</a></b>. }\r
  protected\r
    function GetHelpPath: String;\r
    procedure SetHelpPath(const Value: String);\r
    procedure SetOnQueryEndSession(const Value: TOnEventAccept);\r
    procedure SetOnMinMaxRestore(const Index: Integer; const Value: TOnEvent);\r
    procedure SetConstraint(const Index, Value: Integer);\r
    {$IFDEF F_P}\r
    function GetOnMinMaxRestore(const Index: Integer): TOnEvent;\r
    function GetConstraint(const Index: Integer): Integer;\r
    {$ENDIF F_P}\r
    procedure SetOnScroll(const Value: TOnScroll);\r
    function GetLVColalign(Idx: Integer): TTextAlign;\r
    procedure SetLVColalign(Idx: Integer; const Value: TTextAlign);\r
\r
    procedure SetParent( Value: PControl );\r
    function GetLeft: Integer;\r
    procedure SetLeft( Value: Integer );\r
    function GetTop: Integer;\r
    procedure SetTop( Value: Integer );\r
    function GetWidth: Integer;\r
    procedure SetWidth( Value: Integer );\r
    function GetHeight: Integer;\r
    procedure SetHeight( Value: Integer );\r
\r
    function GetPosition: TPoint;\r
    procedure Set_Position( Value: TPoint );\r
\r
    function GetMembers(Idx: Integer): PControl;\r
    function GetFont: PGraphicTool;\r
    procedure FontChanged( Sender: PGraphicTool );\r
    function GetBrush: PGraphicTool;\r
    procedure BrushChanged( Sender: PGraphicTool );\r
    function GetClientHeight: Integer;\r
    function GetClientWidth: Integer;\r
    procedure SetClientHeight(const Value: Integer);\r
    procedure SetClientWidth(const Value: Integer);\r
    function GetHasBorder: Boolean;\r
    procedure SetHasBorder(const Value: Boolean);\r
\r
    function GetHasCaption: Boolean;\r
    procedure SetHasCaption(const Value: Boolean);\r
\r
    function GetCanResize: Boolean;\r
    procedure SetCanResize( const Value: Boolean );\r
\r
    function GetStayOnTop: Boolean;\r
    procedure SetStayOnTop(const Value: Boolean);\r
    function GetChecked: Boolean;\r
    procedure Set_Checked(const Value: Boolean);\r
\r
    function GetSelStart: Integer;\r
    procedure SetSelStart(const Value: Integer);\r
    function GetSelLength: Integer;\r
    procedure SetSelLength(const Value: Integer);\r
\r
    function GetItems(Idx: Integer): String;\r
    procedure SetItems(Idx: Integer; const Value: String);\r
\r
    function GetItemsCount: Integer;\r
    function GetItemSelected(ItemIdx: Integer): Boolean;\r
    procedure SetItemSelected(ItemIdx: Integer; const Value: Boolean);\r
\r
    procedure SetCtl3D(const Value: Boolean);\r
    function GetCurIndex: Integer;\r
    procedure SetCurIndex(const Value: Integer);\r
    function GetTextAlign: TTextAlign;\r
    function GetVerticalAlign: TVerticalAlign;\r
    procedure SetTextAlign(const Value: TTextAlign);\r
    procedure SetVerticalAlign(const Value: TVerticalAlign);\r
\r
    function GetCanvas: PCanvas;\r
    function Dc2Canvas( Sender: PCanvas ): HDC;\r
    procedure SetShadowDeep(const Value: Integer);\r
    procedure SetDoubleBuffered(const Value: Boolean);\r
\r
    procedure SetStatusText(Index: Integer; Value: PChar);\r
    function GetStatusText( Index: Integer ): PChar;\r
    function GetStatusPanelX(Idx: Integer): Integer;\r
    procedure SetStatusPanelX(Idx: Integer; const Value: Integer);\r
\r
    procedure SetTransparent(const Value: Boolean);\r
    function GetImgListIdx(const Index: Integer): PImageList;\r
\r
    procedure SetImgListIdx(const Index: Integer; const Value: PImageList);\r
    function GetLVColText(Idx: Integer): String;\r
    procedure SetLVColText(Idx: Integer; const Value: String);\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    function GetLVColTextW(Idx: Integer): WideString;\r
    procedure SetLVColTextW(Idx: Integer; const Value: WideString);\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    function LVGetItemText(Idx, Col: Integer): String;\r
    procedure LVSetItemText(Idx, Col: Integer; const Value: String);\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    function LVGetItemTextW(Idx, Col: Integer): WideString;\r
    procedure LVSetItemTextW(Idx, Col: Integer; const Value: WideString);\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    procedure SetLVOptions(const Value: TListViewOptions);\r
    procedure SetLVStyle(const Value: TListViewStyle);\r
    function GetLVColEx(Idx: Integer; const Index: Integer): Integer;\r
    procedure SetLVColEx(Idx: Integer; const Index: Integer;\r
      const Value: Integer);\r
\r
    function GetChildCount: Integer;\r
\r
    function LVGetItemPos(Idx: Integer): TPoint;\r
    procedure LVSetItemPos(Idx: Integer; const Value: TPoint);\r
    procedure LVSetColorByIdx(const Index: Integer; const Value: TColor);\r
    {$IFDEF F_P}\r
    function LVGetColorByIdx(const Index: Integer): TColor;\r
    {$ENDIF F_P}\r
    function GetIntVal(const Index: Integer): Integer;\r
    procedure SetIntVal(const Index, Value: Integer);\r
    function GetItemVal(Item: Integer; const Index: Integer): Integer;\r
    procedure SetItemVal(Item: Integer; const Index, Value: Integer);\r
    function TBGetButtonVisible(BtnID: Integer): Boolean;\r
    procedure TBSetButtonVisible(BtnID: Integer; const Value: Boolean);\r
\r
    function TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;\r
    procedure TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean);\r
    function TBGetButtonText(BtnID: Integer): String;\r
    function TBGetButtonRect(BtnID: Integer): TRect;\r
\r
    function TBGetRows: Integer;\r
    procedure TBSetRows(const Value: Integer);\r
    procedure SetProgressColor(const Value: TColor);\r
    function TBGetBtnImgIdx(BtnID: Integer): Integer;\r
    procedure TBSetBtnImgIdx(BtnID: Integer; const Value: Integer);\r
\r
    procedure TBSetButtonText(BtnID: Integer; const Value: String);\r
\r
    function TBGetBtnWidth(BtnID: Integer): Integer;\r
    procedure TBSetBtnWidth(BtnID: Integer; const Value: Integer);\r
    procedure TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer);\r
    {$IFDEF F_P}\r
    function TBGetBtMinMaxWidth(const Idx: Integer): Integer;\r
    {$ENDIF F_P}\r
    procedure TBFreeTBevents;\r
    procedure Set_Align(const Value: TControlAlign);\r
    function GetSelection: String;\r
    procedure SetSelection(const Value: String);\r
    procedure SetTabOrder(const Value: Integer);\r
    function GetFocused: Boolean;\r
    procedure SetFocused(const Value: Boolean);\r
    function REGetFont: PGraphicTool;\r
    procedure RESetFont(Value: PGraphicTool);\r
    procedure RESetFontEx(const Index: Integer);\r
    function REGetFontEffects(const Index: Integer): Boolean;\r
    function REGetFontMask(const Index: Integer): Boolean;\r
    procedure RESetFontEffect(const Index: Integer; const Value: Boolean);\r
    function REGetFontAttr(const Index: Integer): Integer;\r
    procedure RESetFontAttr(const Index, Value: Integer);\r
    procedure RESetFontAttr1(const Index, Value: Integer);\r
    function REGetFontSizeValid: Boolean;\r
    function REGetCharformat: TCharFormat;\r
    procedure RESetCharFormat(const Value: TCharFormat);\r
    function REReadText(Format: TRETextFormat;\r
      SelectionOnly: Boolean): String;\r
    procedure REWriteText(Format: TRETextFormat; SelectionOnly: Boolean;\r
      const Value: String);\r
    function REGetFontName: String;\r
    procedure RESetFontName(const Value: String);\r
    function REGetParaFmt: TParaFormat;\r
    procedure RESetParaFmt(const Value: TParaFormat);\r
    function REGetNumbering: Boolean;\r
    function REGetParaAttr( const Index: Integer ): Integer;\r
    function REGetParaAttrValid( const Index: Integer ): Boolean;\r
    function REGetTabCount: Integer;\r
    function REGetTabs(Idx: Integer): Integer;\r
    function REGetTextAlign: TRichTextAlign;\r
    procedure RESetNumbering(const Value: Boolean);\r
    procedure RESetParaAttr(const Index, Value: Integer);\r
    procedure RESetTabCount(const Value: Integer);\r
    procedure RESetTabs(Idx: Integer; const Value: Integer);\r
    procedure RESetTextAlign(const Value: TRichTextAlign);\r
    function REGetStartIndentValid: Boolean;\r
    function REGetAutoURLDetect: Boolean;\r
    procedure RESetAutoURLDetect(const Value: Boolean);\r
\r
    function GetMaxTextSize: DWORD;\r
    procedure SetMaxTextSize(const Value: DWORD);\r
    procedure SetOnResize(const Value: TOnEvent);\r
\r
    procedure DoSelChange;\r
\r
    function REGetUnderlineEx: TRichUnderline;\r
    procedure RESetUnderlineEx(const Value: TRichUnderline);\r
\r
    function GetTextSize: Integer;\r
    function REGetTextSize(Units: TRichTextSize): Integer;\r
\r
    function REGetNumStyle: TRichNumbering;\r
    procedure RESetNumStyle(const Value: TRichNumbering);\r
    function REGetNumBrackets: TRichNumBrackets;\r
    procedure RESetNumBrackets(const Value: TRichNumBrackets);\r
    function REGetNumTab: Integer;\r
    procedure RESetNumTab(const Value: Integer);\r
    function REGetNumStart: Integer;\r
    procedure RESetNumStart(const Value: Integer);\r
    function REGetSpacing(const Index: Integer): Integer;\r
    procedure RESetSpacing(const Index, Value: Integer);\r
    function REGetSpacingRule: Integer;\r
    procedure RESetSpacingRule(const Value: Integer);\r
    function REGetLevel: Integer;\r
    function REGetBorder(Side: TBorderEdge; const Index: Integer): Integer;\r
    procedure RESetBorder(Side: TBorderEdge; const Index: Integer;\r
      const Value: Integer);\r
    function REGetParaEffect(const Index: Integer): Boolean;\r
    procedure RESetParaEffect(const Index: Integer; const Value: Boolean);\r
    function REGetOverwite: Boolean;\r
    procedure RESetOverwrite(const Value: Boolean);\r
    procedure RESetOvrDisable(const Value: Boolean);\r
    function REGetTransparent: Boolean;\r
    procedure RESetTransparent(const Value: Boolean);\r
    procedure RESetOnURL(const Index: Integer; const Value: TOnEvent);\r
    {$IFDEF F_P}\r
    function REGetOnURL(const Index: Integer): TOnEvent;\r
    {$ENDIF F_P}\r
    function REGetLangOptions(const Index: Integer): Boolean;\r
    procedure RESetLangOptions(const Index: Integer; const Value: Boolean);\r
    function LVGetItemImgIdx(Idx: Integer): Integer;\r
    procedure LVSetItemImgIdx(Idx: Integer; const Value: Integer);\r
    procedure SetFlat(const Value: Boolean);\r
    procedure SetOnMouseEnter(const Value: TOnEvent);\r
    procedure SetOnMouseLeave(const Value: TOnEvent);\r
    procedure EdSetTransparent(const Value: Boolean);\r
    procedure SetOnTestMouseOver(const Value: TOnTestMouseOver);\r
    function GetPages(Idx: Integer): PControl;\r
    function TCGetItemText(Idx: Integer): String;\r
    procedure TCSetItemText(Idx: Integer; const Value: String);\r
    function TCGetItemImgIDx(Idx: Integer): Integer;\r
    procedure TCSetItemImgIdx(Idx: Integer; const Value: Integer);\r
    function TCGetItemRect(Idx: Integer): TRect;\r
    function TVGetItemIdx(const Index: Integer): THandle;\r
    procedure TVSetItemIdx(const Index: Integer; const Value: THandle);\r
    function TVGetItemNext(Item: THandle; const Index: Integer): THandle;\r
    function TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect;\r
    function TVGetItemVisible(Item: THandle): Boolean;\r
    procedure TVSetITemVisible(Item: THandle; const Value: Boolean);\r
    function TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean;\r
    procedure TVSetItemStateFlg(Item: THandle; const Index: Integer;\r
      const Value: Boolean);\r
    function TVGetItemImage(Item: THandle; const Index: Integer): Integer;\r
    procedure TVSetItemImage(Item: THandle; const Index: Integer;\r
      const Value: Integer);\r
    function TVGetItemText(Item: THandle): String;\r
    procedure TVSetItemText(Item: THandle; const Value: String);\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    function TVGetItemTextW(Item: THandle): WideString;\r
    procedure TVSetItemTextW(Item: THandle; const Value: WideString);\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    function TV_GetItemHasChildren(Item: THandle): Boolean;\r
    procedure TV_SetItemHasChildren(Item: THandle; const Value: Boolean);\r
    function TV_GetItemChildCount(Item: THandle): Integer;\r
    function TVGetItemData(Item: THandle): Pointer;\r
    procedure TVSetItemData(Item: THandle; const Value: Pointer);\r
\r
    function GetToBeVisible: Boolean;\r
\r
    procedure SetAlphaBlend(const Value: Integer);\r
    procedure SetMaxProgress(const Index, Value: Integer);\r
    procedure SetDroppedWidth(const Value: Integer);\r
    function LVGetItemState(Idx: Integer): TListViewItemState;\r
    procedure LVSetItemState(Idx: Integer; const Value: TListViewItemState);\r
    function LVGetSttImgIdx(Idx: Integer): Integer;\r
    procedure LVSetSttImgIdx(Idx: Integer; const Value: Integer);\r
    function LVGetOvlImgIdx(Idx: Integer): Integer;\r
    procedure LVSetOvlImgIdx(Idx: Integer; const Value: Integer);\r
    function LVGetItemData(Idx: Integer): DWORD;\r
    procedure LVSetItemData(Idx: Integer; const Value: DWORD);\r
    function LVGetItemIndent(Idx: Integer): Integer;\r
    procedure LVSetItemIndent(Idx: Integer; const Value: Integer);\r
    procedure SetOnDeleteAllLVItems(const Value: TOnEvent);\r
    procedure SetOnDeleteLVItem(const Value: TOnDeleteLVItem);\r
    procedure SetOnEditLVItem(const Value: TOnEditLVItem);\r
    procedure SetOnLVData(const Value: TOnLVData);\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    procedure SetOnLVDataW(const Value: TOnLVDataW);\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    procedure SetOnColumnClick(const Value: TOnLVColumnClick);\r
    procedure SetOnDrawItem(const Value: TOnDrawItem);\r
    procedure SetOnMeasureItem(const Value: TOnMeasureItem);\r
\r
    procedure SetItemsCount(const Value: Integer);\r
\r
    function GetItemData(Idx: Integer): DWORD;\r
    procedure SetItemData(Idx: Integer; const Value: DWORD);\r
    function GetLVCurItem: Integer;\r
    procedure SetLVCurItem(const Value: Integer);\r
    procedure SetOnDropFiles(const Value: TOnDropFiles);\r
    procedure SetOnHide(const Value: TOnEvent);\r
    procedure SetOnShow(const Value: TOnEvent);\r
    procedure SetClientMargin(const Index, Value: Integer);\r
    {$IFDEF F_P}\r
    function GetClientMargin(const Index: Integer): Integer;\r
    {$ENDIF F_P}\r
    procedure SetOnPaint(const Value: TOnPaint);\r
    procedure SetOnEraseBkgnd(const Value: TOnPaint);\r
    procedure SetTVRightClickSelect(const Value: Boolean);\r
    procedure SetOnLVStateChange(const Value: TOnLVStateChange);\r
    procedure SetOnLVDelete(const Value: TOnLVDelete);\r
    procedure SetOnMove(const Value: TOnEvent);\r
    procedure SetColor1(const Value: TColor);\r
    procedure SetColor2(const Value: TColor);\r
    procedure SetGradientLayout(const Value: TGradientLayout);\r
    procedure SetGradientStyle(const Value: TGradientStyle);\r
    procedure SetDroppedDown(const Value: Boolean);\r
    function get_ClassName: String;\r
    procedure set_ClassName(const Value: String);\r
    procedure SetClsStyle( Value: DWord );\r
\r
    procedure SetStyle( Value: DWord );\r
    procedure SetExStyle( Value: DWord );\r
\r
    procedure SetCursor( Value: HCursor );\r
\r
    procedure SetIcon( Value: HIcon );\r
    procedure SetMenu( Value: HMenu );\r
    function GetCaption: String;\r
    procedure SetCaption( const Value: String );\r
\r
    procedure SetWindowState( Value: TWindowState );\r
    function GetWindowState: TWindowState;\r
\r
    procedure ApplyFont2Wnd;\r
    procedure DoClick;\r
\r
    function TBAddInsButtons( Idx: Integer; const Buttons: array of PChar; const BtnImgIdxArray: array\r
              of Integer ): Integer; stdcall;\r
    procedure SetBitBtnDrawMnemonic(const Value: Boolean);\r
    function GetBitBtnImgIdx: Integer;\r
    procedure SetBitBtnImgIdx(const Value: Integer);\r
    function GetBitBtnImageList: THandle;\r
    procedure SetBitBtnImageList(const Value: THandle);\r
\r
    function GetModal: Boolean;\r
    {$IFDEF USE_SETMODALRESULT}\r
    procedure SetModalResult( const Value: Integer );\r
    {$ENDIF}\r
\r
  protected\r
    fHandle: HWnd;\r
    fFocusHandle: HWnd;\r
    fClsStyle: DWord;\r
    fStyle: DWord;\r
    fExStyle: DWord;\r
    fCursor: HCursor;\r
    fCursorShared: Boolean;\r
    fIcon: HIcon;\r
    fIconShared: Boolean;\r
    fCaption: PChar; // it is now preferred to store Caption as PChar (null-\r
                     // terminated string), dynamically allocated in memory.\r
    fIgnoreWndCaption: Boolean;\r
\r
    fWindowState: TWindowState;\r
    fShowAction: Integer;\r
    fCanvas: PCanvas;\r
    fDefWndProc: Pointer;\r
    fNCDestroyed: Boolean;\r
\r
    FParent: PControl;\r
    //FTag: Integer;\r
    fEnabled: Boolean; // Caution!!! fVisible must follow fEnabled! ___\r
    fVisible: Boolean; //____________________________________________//\r
    fTabstop: Boolean;\r
    fTabOrder: Integer;\r
    fTextAlign: TTextAlign;\r
    fVerticalAlign: TVerticalAlign;\r
    fWordWrap: Boolean;\r
    fPreventResize: Boolean;\r
    fAlphaBlend: Integer;\r
    FDroppedWidth: Integer;\r
\r
    fChildren: PList;\r
    {* List of children. }\r
    fMDIClient: PControl;\r
    {* MDI client window control }\r
    fPass2DefProc: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
    {* MDI children list }\r
    fMDIChildren: PList;\r
    {* List of MDI children. It is filled for MDI client window. }\r
    fWndFunc: Pointer;\r
    {* Initially pointer to WndFunc. For MDI child window, points to DefMDIChildProc. }\r
    fExMsgProc: function( Applet: PControl; var Msg: TMsg ): Boolean;\r
    {* Additional message handler called directly from Applet.ProcessMessage.\r
       Used to call TranslateMDISysAccel API function for MDI application. }\r
    fMDIDestroying: Boolean;\r
    {* }\r
\r
    fTmpBrush: HBrush;\r
    {* Brush handle to return in response to some color set messages.\r
       Intended for internal use instead of Brush.Color if possible\r
       to avoid using it. }\r
    fTmpBrushColorRGB: TColor;\r
    { }\r
    fMembersCount: Integer;\r
    {* Memebers count is first used in XCustomControl to separate\r
       some internal child controls from common XControl.Children\r
       and make it invisible among Children[]. }\r
    fDrawCtrl1st: PControl;\r
    {* Child control to draw it first, i.e. foreground of others. }\r
    FCreating: Boolean;\r
    {* True, when creating of object is in progress. }\r
    fDestroying: Boolean;\r
    {* True, when destroying of the window is started. Made protected to\r
       be accessible in descending classes. }\r
    fMenu: HMenu;\r
    {* Usually used to store handle of attached main menu, but sometimes\r
       is used to store control ID (for standard GUI controls only). }\r
    fMenuObj: PObj;\r
    {* PMenu pointer to TMenu object. Freed automatically with entire\r
       chain of menu objects attached to a control (or form). }\r
{$IFNDEF NEW_MENU_ACCELL}\r
    fAccelTable: HAccel;\r
{$ENDIF}\r
    {* Handle of accelerator table created by menu(s). }\r
    fImageList: PImageList;\r
    {* Pointer to first private image list. Control can own several image,\r
       lists, linked to a chain of image list objects. All these image lists\r
       are released automatically, when control is destroyed. }\r
    fCtlImageListSml: PImageList;\r
    {* ImageList object (with small icons 16x16) to use with a control (e.g.,\r
       with ListView control).\r
       If not set, but control has a list of image list objects, last added\r
       image list with small icons is used automatically. }\r
    fCtlImageListNormal: PImageList;\r
    {* ImageList object (with big icons 32x32) to use with a control.\r
       If not set, last added image list with big icons is used. }\r
    fCtlImgListState: PImageList;\r
    {* ImageList object to use as a state image list (for ListView control). }\r
    fIsApplet: Boolean;\r
    {* True, if the object represent application taskbar button. }\r
    fIsForm: Boolean;\r
    {* True, if the object is form. }\r
    fIsMDIChild: Boolean;\r
    {* TRUE, if the object is MDI child form. }\r
    fIsControl: Boolean;\r
    {* True, if it is a control on form. }\r
    fIsStaticControl: Boolean;\r
    {* True, if it is static control with a caption. (To prevent flickering\r
       it in DoubleBuffered mode. }\r
    fIsCommonControl: Boolean;\r
    {* True, if it is common control. }\r
    fChangedPosSz: Byte;\r
    {* Flags of changing left (1), top (2), width (4) or height (8) }\r
    fCannotDoubleBuf: Boolean;\r
    {* True, if cannot set DoubleBuffered to True (RichEdit). }\r
    fUpdRgn: HRgn;\r
    fCollectUpdRgn: HRGN;\r
    fEraseUpdRgn: Boolean;\r
    fPaintDC: HDC;\r
    fDblBufBmp: HBitmap;\r
    {* Memory bitmap, used for DoubleBuffered painting. }\r
    fDblBufW, fDblBufH: Integer;\r
    {* Dimensions of fDblBufBmp. }\r
    fDblBufPainting: Boolean;\r
    fLookTabKeys: TTabKeys;\r
    fNotUpdate: Boolean;\r
    fDynHandlers: PList;\r
    fColumn: Integer;\r
    FSupressTab: Boolean;\r
    fUpdateCount: Integer;\r
    fPaintLater: Boolean;\r
    fOnLeave: TOnEvent;\r
    fEditing: Boolean;\r
    fAutoPopupMenu: PObj;\r
    fHelpContext: Integer;\r
\r
    // Order of following fields is important:\r
    //_______________________________________________________________________________________________\r
    fOnDynHandlers: TWindowFunc;                                                                   //\r
    fWndProcKeybd: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;         //\r
    fControlClick: procedure( Sender : PObj );                                                     //\r
    fControlClassName: PChar;                                                                      //\r
    fWindowed: Boolean;                                                                            //\r
    {* True, if control is windowed (or is a form). Now always True,                               //\r
       because KOL does not yet contain Graphic controls. }                                        //\r
    //                                                                                             //\r
    fCtlClsNameChg: Boolean;                                                                       //\r
    {* True, if control class name changed and memory is allocated to store it. }                  //\r
    fWndProcResizeFlicks: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;  //\r
    fGotoControl: function( Self_: PControl; Key: DWORD; CheckOnly: Boolean ): Boolean;            //\r
    fCtl3Dchild: Boolean;                                                                          //\r
    fCtl3D: Boolean;                                                                               //\r
    fTextColor: TColor;                                                                            //\r
    {* Color of text. Used instead of fFont.Color internally to                                    //\r
       avoid usage of Font object if user is not accessing and changing it. }                      //\r
    fFont: PGraphicTool;                                                                           //\r
    fColor: TColor;                                                                                //\r
    {* Color of control background. }                                                              //\r
    fBrush: PGraphicTool;                                                                          //\r
    fMargin: Integer;                                                                              //\r
    fBoundsRect: TRect;                                                                            //\r
    fClientTop, fClientBottom, fClientLeft, fClientRight: Integer;                                 //\r
    {* Store adjustment factor of ClientRect for some 'idiosincrasies' windows,                    //\r
       such as Groupbox or Tabcontrol. }                                                           //\r
    //_____________________________________________________________________________________________//\r
    // this is the end of fiels set, which order is important\r
\r
    fDoubleBuffered: Boolean;                                                                      //\r
    fTransparent: Boolean;                                                                         //\r
\r
    fOnMessage: TOnMessage;\r
    fOldOnMessage: TOnMessage;\r
\r
    fOnClick: TOnEvent;\r
    fRightClick: Boolean;\r
    fCurrentControl: PControl;\r
    fCreateVisible, fCreateHidden: Boolean;\r
    fRadio1st, fRadioLast : THandle;\r
    fDropDownProc: procedure( Sender : PObj );\r
    fDropped: Boolean;\r
    fCurIdxAtDrop: Integer;\r
    fPrevWndProc: Pointer;\r
    fClickDisabled: Byte;\r
    fCurItem, fCurIndex: Integer;\r
    FOnScroll: TOnScroll;\r
    FScrollLineDist: array[ 0..1 ] of Integer;\r
\r
    fDefaultBtn: Boolean;\r
    fCancelBtn: Boolean;\r
    fDefaultBtnCtl: PControl;\r
    fCancelBtnCtl: PControl;\r
    fAllBtnReturnClick: Boolean;\r
    fIgnoreDefault: Boolean;\r
\r
    fOnMouseDown: TOnMouse; // CAUTION!!! Order of mouse event handlers is important. ____\r
    fOnMouseUp: TOnMouse;                                                               //\r
    fOnMouseMove: TOnMouse;                                                             //\r
    fOnMouseDblClk: TOnMouse;                                                           //\r
    fOnMouseWheel: TOnMouse;     //_____________________________________________________//\r
\r
    fOldDefWndProc: Pointer;\r
\r
    fOnChange: TOnEvent;\r
    fOnEnter: TOnEvent;\r
\r
    FOnLVCustomDraw: TOnLVCustomDraw;\r
    FOnSBBeforeScroll: TOnSBBeforeScroll;\r
    FOnSBScroll: TOnSBScroll;\r
  protected\r
    procedure SetOnLVCustomDraw(const Value: TOnLVCustomDraw);\r
  public\r
    fCommandActions: TCommandActions;\r
  protected\r
    fOnChar: TOnChar;\r
    fOnKeyUp: TOnKey;\r
    fOnKeyDown: TOnKey;\r
\r
    fOnPaint: TOnPaint;\r
\r
    FMaxWidth: Integer;\r
    FMinWidth: Integer;\r
    FMaxHeight: Integer;\r
    FMinHeight: Integer;\r
    fShadowDeep: Integer;\r
    fStatusCtl: PControl;\r
    fStatusWnd: HWnd;\r
    fStatusTxt: PChar;\r
    fColor1: TColor;\r
    fColor2: TColor;\r
    fLVColCount: Integer;\r
    fLVOptions: TListViewOptions;\r
    fLVStyle: TListViewStyle;\r
    fOnEditLVITem: TOnEditLVItem;\r
    fLVTextBkColor: TColor;\r
    fLVItemHeight: Integer;\r
\r
    fOnDropDown: TOnEvent;\r
    fOnCloseUp: TOnEvent;\r
\r
    fModalResult: Integer;\r
    \r
    fModal: Integer;\r
    fModalForm: PControl;\r
\r
    FAlign: TControlAlign;\r
    fNotUseAlign: Boolean;\r
    fDragCallback: TOnDrag;\r
    fDragging: Boolean;\r
    fDragStartPos: TPoint;\r
    fMouseStartPos: TPoint;\r
    fSplitStartPos: TPoint;\r
    fSplitStartPos2: TPoint;\r
    fSplitStartSize: Integer;\r
    fSplitMinSize1, fSplitMinSize2: Integer;\r
    fOnSplit: TOnSplit;\r
    fSecondControl: PControl;\r
    fOnSelChange: TOnEvent;\r
    fTmpFont: PGraphicTool;\r
\r
    fRECharFormatRec: TCharFormat2;\r
    fREError: Integer;\r
    fREStream: PStream;\r
    fREStrLoadLen: DWORD;\r
    fREParaFmtRec: TParaFormat2;\r
    FOnResize: TOnEvent;\r
    fOnProgress: TOnEvent;\r
    fCharFmtDeltaSz: Integer;\r
    fParaFmtDeltaSz: Integer;\r
    fREOvr: Boolean;\r
    fReOvrDisable: Boolean;\r
    fOnREInsModeChg: TOnEvent;\r
    fREScrolling: Boolean;\r
    fUpdCount: Integer;\r
    fOnREOverURL: TOnEvent;\r
    fOnREURLClick: TOnEvent;\r
    fRECharArea: TRichFmtArea;\r
    fBitBtnOptions : TBitBtnOptions;\r
    fGlyphLayout : TGlyphLayout;\r
    fGlyphBitmap : HBitmap;\r
    fGlyphCount : Integer;\r
    fGlyphWidth, fGlyphHeight: Integer;\r
    fOnBitBtnDraw: TOnBitBtnDraw;\r
    fFlat: Boolean;\r
    fSizeRedraw: Boolean; {YS}\r
\r
    fOnMouseLeave: TOnEvent;\r
    fOnMouseEnter: TOnEvent;\r
    fOnTestMouseOver: TOnTestMouseOver;\r
\r
    fMouseInControl: Boolean;\r
    fRepeatInterval: Integer;\r
    fChecked: Boolean;\r
    fPrevFocusWnd: HWnd;\r
\r
    fOnTVBeginDrag: TOnTVBeginDrag;\r
    fOnTVBeginEdit: TOnTVBeginEdit;\r
    fOnTVEndEdit: TOnTVEndEdit;\r
    fOnTVExpanded: TOnTVExpanded;\r
    fOnTVExpanding: TOnTVExpanding;\r
    fOnTVDelete: TOnTVDelete;\r
\r
    fOnDeleteLVItem: TOnDeleteLVItem;\r
    fOnDeleteAllLVItems: TOnEvent;\r
    fOnLVData: TOnLVData;\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    fOnLVDataW: TOnLVDataW;\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    fOnCompareLVItems: TOnCompareLVItems;\r
    fOnColumnClick: TOnLVColumnClick;\r
    fOnDrawItem: TOnDrawItem;\r
    fOnMeasureItem: TOnMeasureItem;\r
    fREUrl: String;\r
    FMinimizeWnd: PControl;\r
    FFixWidth: Integer;\r
    FFixHeight: Integer;\r
    FOnDropFiles: TOnDropFiles;\r
    FOnHide: TOnEvent;\r
    FOnShow: TOnEvent;\r
    fOnEraseBkgnd: TOnPaint;\r
    fCustomData: Pointer;\r
    fCustomObj: PObj;\r
    fOnTVSelChanging: TOnTVSelChanging;\r
\r
    fOnClose: TOnEventAccept;\r
    fOnQueryEndSession: TOnEventAccept;\r
    fCloseQueryReason: TCloseQueryReason;\r
\r
    //----- order of following 3 events important: //\r
    fOnMinimize: TOnEvent;                         //\r
    fOnMaximize: TOnEvent;                         //\r
    fOnRestore: TOnEvent;                          //\r
    //---------------------------------------------//\r
\r
    //fCreateParamsExt: procedure( Self_: PControl; var Params: TCreateParams );\r
    fCreateWndExt: procedure( Sender: PControl );\r
\r
    fTBttCmd: PList;\r
    fTBttTxt: PStrList;\r
    fTBevents: PList; // events for TBAssignEvents\r
    fTBBtnImgWidth: Integer; // custom toolbar bitmap width\r
    FTBBtMinWidth: Integer;\r
    FTBBtMaxWidth: Integer;\r
    fGradientStyle: TGradientStyle;\r
    fGradientLayout: TGradientLayout;\r
    fVisibleWoParent: Boolean;\r
\r
\r
    fTVRightClickSelect: Boolean;\r
    FOnMove: TOnEvent;\r
    FOnLVStateChange: TOnLVStateChange;\r
    FOnLVDelete: TOnLVDelete;\r
    fAutoSize: procedure( Self_: PControl );\r
    fIsButton: Boolean;\r
    fSizeGrip: Boolean;\r
    fNotAvailable: Boolean;\r
    FPressedMnemonic: DWORD;\r
    FBitBtnDrawMnemonic: Boolean;\r
    FBitBtnGetCaption: function( Self_: PControl; const S: String ): String;\r
    FBitBtnExtDraw: procedure( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect;\r
                    const CapText, CapTxtOrig: String; Color: TColor );\r
    FTextShiftX, FTextShiftY: Integer;\r
    fNotifyChild: procedure( Self_, Child: PControl );\r
    fScrollChildren: procedure( Self_: PControl );\r
    fOnHelp: TOnHelp;\r
\r
    FOnDTPUserString: TDTParseInputEvent;\r
\r
    {$IFDEF USE_MHTOOLTIP}\r
    {$DEFINE var}\r
    {$I KOLMHToolTip}\r
    {$UNDEF var}\r
\r
    {$DEFINE function}\r
    {$I KOLMHToolTip}\r
    {$UNDEF function}\r
    {$ENDIF}\r
\r
    procedure Init; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
    procedure InitParented( AParent: PControl ); virtual;\r
    {* Initialization of visual object. }\r
    procedure DestroyChildren;\r
    {* Destroys children. Is called in destructor, and can be\r
       called in descending classes as earlier as needed to\r
       prevent problems of too late destroying of visuals. }\r
\r
    function GetParentWnd( NeedHandle: Boolean ): HWnd;\r
    {* Returns handle of parent window. }\r
    function GetParentWindow: HWnd;\r
    {* }\r
    procedure SetEnabled( Value: Boolean );\r
    {* Changes Enabled property value. Overriden here to change enabling\r
       status of a window. }\r
    function GetEnabled: Boolean;\r
    {* Returns True, if Enabled. Overriden here to obtain real window\r
       state. }\r
    procedure SetVisible( Value: Boolean );\r
    {* Sets Visible property value. Overriden here to change visibility\r
       of correspondent window. }\r
    procedure Set_Visible( Value: Boolean );\r
    {* }\r
    function GetVisible: Boolean;\r
    {* Returns True, if correspondent window is Visible. Overriden\r
       to get visibility of real window, not just value stored in object. }\r
    function Get_Visible: Boolean;\r
    {* Returns True, if correspondent window is Visible, for forms and applet,\r
       or if fVisible flag is set, for controls. }\r
    procedure SetCtlColor( Value: TColor );\r
    {* Sets TControl's Color property value. }\r
    procedure SetBoundsRect( const Value: TRect );\r
    {* Sets BoudsRect property value. }\r
    function GetBoundsRect: TRect;\r
    {* Returns bounding rectangle. }\r
    function GetIcon: HIcon;\r
    {* Returns Icon property. By default, if it is not set,\r
       returns Icon property of an Applet. }\r
\r
    procedure CreateSubclass( var Params: TCreateParams; ControlClassName: PChar );\r
    {* Can be used in descending classes to subclass window with given\r
       standard Windows ControlClassName - must be called after\r
       creating Params but before CreateWindow. Usually it is called\r
       in overriden method CreateParams after calling of the inherited one. }\r
\r
    function UpdateWndStyles: PControl;\r
    {* Updates fStyle, fExStyle, fClsStyle from window handle }\r
    procedure SetOnChar(const Value: TOnChar);\r
    {* }\r
    procedure SetOnKeyDown(const Value: TOnKey);\r
\r
    {* }\r
    procedure SetOnKeyUp(const Value: TOnKey);\r
    {* }\r
    procedure SetMouseDown(const Value: TOnMouse);\r
    {* }\r
    procedure SetMouseMove(const Value: TOnMouse);\r
    {* }\r
    procedure SetMouseUp(const Value: TOnMouse);\r
    {* }\r
    procedure SetMouseWheel(const Value: TOnMouse);\r
    {* }\r
    procedure SetMouseDblClk(const Value: TOnMouse);\r
    {* }\r
    procedure SetHelpContext( Value: Integer );\r
    {* }\r
    procedure SetOnTVDelete( const Value: TOnTVDelete );\r
    {* }\r
    procedure SetDefaultBtn(const Index: Integer; const Value: Boolean);\r
    {$IFDEF F_P}\r
    function GetDefaultBtn(const Index: Integer): Boolean;\r
    {$ENDIF F_P}\r
    function DefaultBtnProc( var Msg: TMsg; var Rslt: Integer ): Boolean;\r
    {* }\r
\r
    procedure SetDateTime( Value: TDateTime );\r
    function GetDateTime: TDateTime;\r
    procedure SetDateTimeRange( Value: TDateTimeRange );\r
    function GetDateTimeRange: TDateTimeRange;\r
    procedure SetDateTimePickerColor( Index: TDateTimePickerColor; Value: TColor );\r
    function GetDateTimePickerColor( Index: TDateTimePickerColor ): TColor;\r
    procedure SetDateTimeFormat( const Value: String );\r
\r
  public\r
    constructor CreateParented( AParent: PControl );\r
    {* Creates new instance of TControl object, calling InitParented }\r
    //FormPointer_DoNotUseItPlease_ItIsUsedByMCK: Pointer;\r
    { ^ no more needed }\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* Destroyes object. First of all, destructors for all children\r
       are called. }\r
\r
    function GetWindowHandle: HWnd;\r
    {* Returns window handle. If window is not yet created,\r
       method CreateWindow is called. }\r
    procedure CreateChildWindows;\r
    {* Enumerates all children recursively and calls CreateWindow for all\r
       of these. }\r
    property Parent: PControl read fParent write SetParent;\r
    {* Parent of TParent object. Also must be of TParent type or derived from TParent. }\r
    //property Tag: Integer read FTag write FTag; //--------- moved to TObj --------\r
    {* User-defined pointer, which can contain any data or reference to\r
       anywhere in memory (when used as a pointer).\r
    }\r
    function ChildIndex( Child: PControl ): Integer;\r
    {* Returns index of given child. }\r
    procedure MoveChild( Child: PControl; NewIdx: Integer );\r
    {* Moves given Child into new position. }\r
\r
    property Enabled: Boolean read GetEnabled write SetEnabled;\r
    {* Enabled usually used to decide if control can get keyboard focus\r
       or been clicked by mouse. }\r
    procedure EnableChildren( Enable, Recursive: Boolean );\r
    {* Enables (Enable = TRUE) or disables (Enable = FALSE) all the children\r
       of the control. If Recursive = TRUE then all the children of all the\r
       children are enabled or disabled recursively. }\r
    property Visible: Boolean read Get_Visible write SetVisible;\r
    {* Obvious. }\r
    property ToBeVisible: Boolean read GetToBeVisible;\r
    {* Returns True, if a control is supposed to be visible when its\r
       form is showing. Thus is, True is returned if either control\r
       is Visible or hidden, but marked with flag fCreateHidden. }\r
    property CreateVisible: Boolean read fCreateVisible write fCreateVisible;\r
    {* False by default. If You want your form to be created visible and\r
       flick due creation, set it to True. This does not affect size of\r
       executable anyway. }\r
    property Align: TControlAlign read FAlign write Set_Align;\r
    {* Align style of a control. If this property is not used in your\r
       application, there are no additional code added. Aligning of\r
       controls is made in KOL like in VCL. To align controls when\r
       initially create ones, use "transparent" function SetAlign\r
       ("transparent" means that it returns @Self as a result).\r
       |<br>\r
       Note, that it is better not to align combobox caClient, caLeft or\r
       caRight (better way is to place a panel with Border = 0 and\r
       EdgeStyle = esNone, align it as desired and to place a combobox on it\r
       aligning caTop or caBottom). Otherwise, big problems could be under\r
       Win9x/Me, and some delay could occur under any other systems.\r
       |<br> Do not attempt to align some kinds of controls (like combobox or\r
       toolbar) caLeft or caRight, this can cause infinite recursion in the\r
       application. }\r
    property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;\r
    {* Bounding rectangle of the visual. Coordinates are relative\r
       to top left corner of parent's ClientRect, or to top left corner\r
       of screen (for TForm). }\r
    property Left: Integer read GetLeft write SetLeft;\r
    {* Left horizontal position. }\r
    property Top: Integer read GetTop write SetTop;\r
    {* Top vertical position. }\r
    property Width: Integer read GetWidth write SetWidth;\r
    {* Width of TVisual object. }\r
    property Height: Integer read GetHeight write SetHeight;\r
    {* Height of TVisual object. }\r
\r
    property Position: TPoint read GetPosition write Set_Position;\r
    {* Represents top left position of the object. See also BoundsRect. }\r
    property MinWidth: Integer index 0\r
             {$IFDEF F_P}   read GetConstraint\r
             {$ELSE DELPHI} read FMinWidth\r
             {$ENDIF F_P/DELPHI} write SetConstraint;\r
    {* Minimal width constraint. }\r
    property MinHeight: Integer index 1\r
             {$IFDEF F_P}   read GetConstraint\r
             {$ELSE DELPHI} read FMinHeight\r
             {$ENDIF F_P/DELPHI} write SetConstraint;\r
    {* Minimal height constraint. }\r
    property MaxWidth: Integer index 2\r
             {$IFDEF F_P}   read GetConstraint\r
             {$ELSE DELPHI} read FMaxWidth\r
             {$ENDIF F_P/DELPHI} write SetConstraint;\r
    {* Maximal width constraint. }\r
    property MaxHeight: Integer index 3\r
             {$IFDEF F_P}   read GetConstraint\r
             {$ELSE DELPHI} read FMaxHeight\r
             {$ENDIF F_P/DELPHI} write SetConstraint;\r
    {* Maximal height constraint. }\r
\r
    function ClientRect: TRect;\r
    {* Client rectangle of TVisual. Contrary to VCL, for some\r
       classes (e.g., derived from XCustomControl, can be relative\r
       not to itself, but to top left corner of the BoundsRect\r
       rectangle. }\r
    property ClientWidth: Integer read GetClientWidth write SetClientWidth;\r
    {* Obvious. Accessing this property, program forces window latent creation. }\r
    property ClientHeight: Integer read GetClientHeight write SetClientHeight;\r
    {* Obvious. Accessing this property, program forces window latent creation. }\r
\r
    function ControlRect: TRect;\r
    {* Absolute bounding rectangle relatively to nearest\r
       Windowed parent client rectangle (at least to a form, but usually to\r
       a Parent).\r
       Useful while drawing on device context, provided by such\r
       Windowed parent. For form itself is the same as BoundsRect. }\r
    function ControlAtPos( X, Y: Integer; IgnoreDisabled: Boolean ): PControl;\r
    {* Searches TVisual at the given position (relatively to top left\r
       corner of the ClientRect). }\r
\r
    procedure Invalidate;\r
    {* Invalidates rectangle, occupied by the visual (but only if Showing =\r
       True). }\r
\r
    procedure InvalidateEx;\r
    {* Invalidates the window and all its children. }\r
    procedure InvalidateNC( Recursive: Boolean );\r
    {* Invalidates the window and all its children including non-client area. }\r
    procedure Update;\r
    {* Updates control's window and calls Update for all child controls. }\r
    procedure BeginUpdate;\r
    {* |<#treeview>\r
       |<#listview>\r
       |<#richedit>\r
       |<#memo>\r
       |<#listbox>\r
       Call this method to stop visual updates of the control until correspondent\r
       EndUpdate called (pairs BeginUpdate - EndUpdate can be nested). }\r
    procedure EndUpdate;\r
    {* See BeginUpdate. }\r
\r
    property Windowed: Boolean read fWindowed;\r
    {* Constantly returns True, if object is windowed (i.e. owns\r
        correspondent window handle). Otherwise, returns False.\r
        |<br>\r
        By now, all the controls are windowed (there are no controls in KOL, which are\r
        emulating window, acually belonging to Parent - like TGraphicControl\r
        in VCL). }\r
\r
    function HandleAllocated: Boolean;\r
    {* Returns True, if window handle is allocated. Has no sense for\r
       non-Windowed objects (but now, the KOL has no non-Windowed controls). }\r
    property MDIClient: PControl read fMDIClient;\r
    {* For MDI forms only: returns MDI client window control, containng all MDI\r
       children. Use this window to send specific messages to rule MDI children. }\r
\r
    property ChildCount: Integer read GetChildCount;//GetChildCountWOMembers;\r
    {* Returns number of commonly accessed child objects (without\r
       MembersCount). }\r
    property Children[ Idx: Integer ]: PControl read GetMembers;\r
    {* Child items of TVisual object. Property is reintroduced here\r
       to separate access to always visible Children[] from restricted\r
       a bit Members[]. }\r
    property MembersCount: Integer read FMembersCount;\r
    {* Returns number of "internal" child objects, which are\r
       not accessible through common Children[] property. }\r
    property Members[ Idx: Integer ]: PControl read GetMembers;\r
    {* Members and children array of the object (first from 0 to\r
       MembersCount-1 are Members[], and Children[] are followed by\r
       them. Usually You do not need to use this list. Use instead\r
       Children[0..ChildCount] property, Members[] is intended for\r
       internal needs of XCL (and in KOL by now Members and Children\r
       actually are the same properties). }\r
\r
    procedure PaintBackground( DC: HDC; Rect: PRect );\r
    {* Is called to paint background in given rectangle. This\r
       method is filling clipped area of the Rect rectangle with\r
       Color, but only if global event Global_OnPaintBkgnd is\r
       not assigned. If assigned, this one is called instead here.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       This method made public, so it can be called directly to\r
       fill some device context's rectangle. But remember, that\r
       independantly of Rect, top left corner of background piece\r
       will be located so, if drawing is occure into ControlRect\r
       rectangle. }\r
    property WindowedParent: PControl read fParent;\r
    {* Returns nearest windowed parent, the same as Parent. }\r
\r
    function ParentForm: PControl;\r
    {* |<#form>\r
       Returns parent form for a control (of @Self for form itself. }\r
    property ActiveControl: PControl read fCurrentControl write fCurrentControl;\r
    {* }\r
    function Client2Screen( const P: TPoint ): TPoint;\r
    {* Converts the client coordinates of a specified point to screen coordinates. }\r
    function Screen2Client( const P: TPoint ): TPoint;\r
    {* Converts screen coordinates of a specified point to client coordinates. }\r
    function CreateWindow: Boolean; virtual;\r
    {* |<#form>\r
       Creates correspondent window object. Returns True if success (if\r
       window is already created, False is returned). If applied to a form,\r
       all child controls also allocates handles that time.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       Call this method to ensure, that a hanle is allocated for a form,\r
       an application button or a control. (It is not necessary to do so in\r
       the most cases, even if You plan to work with control's handle directly.\r
       But immediately after creating the object, if You want to pass its\r
       handle to API function, this can be helpful). }\r
    procedure Close;\r
    {* |<#appbutton>\r
       |<#form>\r
       Closes window. If a window is the main form, this closes application,\r
       terminating it. Also it is possible to call Close method for Applet\r
       window to stop application. }\r
\r
    {$IFDEF USE_MHTOOLTIP}\r
    {$DEFINE public}\r
    {$I KOLMHToolTip}\r
    {$UNDEF public}\r
    {$ENDIF}\r
\r
    property Handle: HWnd read fHandle; //GetHandle;\r
    {* Returns descriptor of system window object. If window is not yet\r
       created, 0 is returned. To allocate handle, call CreateWindow method. }\r
\r
    property ParentWindow: HWnd read GetParentWindow;\r
    {* Returns handle of parent window (not TControl object, but system\r
       window object handle). }\r
    property ClsStyle: DWord read fClsStyle write SetClsStyle;\r
    {* Window class style. Available styles are:\r
       |<table border=0>\r
       |&L=<tr><td valign=top><font face=Fixedsys>%1</font></td><td>\r
       |&E=</td></tr>\r
       |&N=<br>&nbsp;&nbsp;&nbsp;\r
       <L CS_BYTEALIGNCLIENT> - Aligns the window's client area on the byte boundary\r
          (in the x direction) to enhance performance during\r
       drawing operations. <E>\r
       <L CS_BYTEALIGNWINDOW> - Aligns a window on a byte boundary (in the x\r
          direction). <E>\r
       <L CS_CLASSDC> - Allocates one device context to be shared by all\r
          windows in the class. <E>\r
       <L CS_DBLCLKS> - Sends double-click messages to the window\r
          procedure when the user double-clicks the mouse while the\r
          cursor is within a window belonging to the class. <E>\r
       <L CS_GLOBALCLASS> - Allows an application to create a window of\r
          the class regardless of the value of the hInstance parameter.\r
       <N> You can create a global class by creating\r
          the window class in a dynamic-link library (DLL) and listing the\r
          name of the DLL in the registry under specific keys. <E>\r
       <L CS_HREDRAW> - Redraws the entire window if a movement or\r
          size adjustment changes the width of the client area. <E>\r
       <L CS_NOCLOSE>  - Disables the Close command on the System menu. <E>\r
       <L CS_OWNDC> - Allocates a unique device context for each window\r
          in the class. <E>\r
       <L CS_PARENTDC> - Sets the clipping region of the child window to\r
          that of the parent window so that the child can draw on the parent. <E>\r
       <L CS_SAVEBITS> - Saves, as a bitmap, the portion of the screen\r
          image obscured by a window. Windows uses the saved bitmap to re-create\r
          the screen image when the window is removed. <E>\r
       <L CS_VREDRAW> - Redraws the entire window if a movement or size\r
          adjustment changes the height of the client area. <E>\r
       |</table> For more info, see Win32.hlp (keyword 'WndClass');\r
    }\r
\r
    property Style: DWord read fStyle write SetStyle;\r
    {* Window styles. Available styles are:\r
       |<table border=0>\r
       <L WS_BORDER>    Creates a window that has a thin-line border. <E>\r
       <L WS_CAPTION>   Creates a window that has a title bar (includes the\r
          WS_BORDER style). <E>\r
       <L WS_CHILD>     Creates a child window. This style cannot be used with\r
          the WS_POPUP style. <E>\r
       <L WS_CHILDWINDOW>       Same as the WS_CHILD style. <E>\r
       <L WS_CLIPCHILDREN>      Excludes the area occupied by child windows\r
          when drawing occurs within the parent window. This style is used\r
          when creating the parent window. <E>\r
       <L WS_CLIPSIBLINGS>      Clips child windows relative to each other;\r
          that is, when a particular child window receives a WM_PAINT message,\r
          the WS_CLIPSIBLINGS style clips all other overlapping child windows\r
          out of the region of the child window to be updated. If\r
          WS_CLIPSIBLINGS is not specified and child windows overlap, it is\r
          possible, when drawing within the client area of a child window,\r
          to draw within the client area of a neighboring child window. <E>\r
       <L WS_DISABLED>  Creates a window that is initially disabled. A\r
          disabled window cannot receive input from the user. <E>\r
       <L WS_DLGFRAME>  Creates a window that has a border of a style\r
          typically used with dialog boxes. A window with this style cannot\r
          have a title bar. <E>\r
       <L WS_GROUP>     Specifies the first control of a group of controls.\r
          The group consists of this first control and all  controls defined\r
          after it, up to the next control with the WS_GROUP style.\r
          The first control in each group usually has the WS_TABSTOP\r
          style so that the user can move from group to group. The user\r
          can subsequently change the keyboard focus from one control in\r
          the group to the next control in the group by using the direction\r
          keys. <E>\r
       <L WS_HSCROLL>   Creates a window that has a horizontal scroll bar. <E>\r
       <L WS_ICONIC>    Creates a window that is initially minimized. Same as\r
          the WS_MINIMIZE style. <E>\r
       <L WS_MAXIMIZE>  Creates a window that is initially maximized. <E>\r
       <L WS_MAXIMIZEBOX>       Creates a window that has a Maximize button.\r
          Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU\r
          style must also be specified. <E>\r
       <L WS_MINIMIZE>  Creates a window that is initially minimized.\r
          Same as the WS_ICONIC style. <E>\r
       <L WS_MINIMIZEBOX>       Creates a window that has a Minimize button.\r
          Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU\r
          style must also be specified. <E>\r
       <L WS_OVERLAPPED>        Creates an overlapped window. An overlapped\r
          window has a title bar and a border. Same as the WS_TILED style. <E>\r
       <L WS_OVERLAPPEDWINDOW>  Creates an overlapped window with the\r
          WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME, WS_MINIMIZEBOX,\r
          and WS_MAXIMIZEBOX styles. Same as the WS_TILEDWINDOW style. <E>\r
       <L WS_POPUP>     Creates a pop-up window. This style cannot be used with\r
          the WS_CHILD style. <E>\r
       <L WS_POPUPWINDOW>       Creates a pop-up window with WS_BORDER,\r
          WS_POPUP, and WS_SYSMENU styles. The WS_CAPTION and WS_POPUPWINDOW\r
          styles must be combined to make the window menu visible. <E>\r
       <L WS_SIZEBOX>   Creates a window that has a sizing border. Same as the\r
          WS_THICKFRAME style. <E>\r
       <L WS_SYSMENU>   Creates a window that has a window-menu on its title\r
          bar. The WS_CAPTION style must also be specified. <E>\r
       <L WS_TABSTOP>   Specifies a control that can receive the keyboard focus\r
          when the user presses the TAB key. Pressing the TAB key changes\r
          the keyboard focus to the next control with the WS_TABSTOP style. <E>\r
       <L WS_THICKFRAME>        Creates a window that has a sizing border.\r
          Same as the WS_SIZEBOX style. <E>\r
       <L WS_TILED>     Creates an overlapped window. An overlapped window has\r
          a title bar and a border. Same as the WS_OVERLAPPED style. <E>\r
       <L WS_TILEDWINDOW>       Creates an overlapped window with the\r
          WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME,\r
          WS_MINIMIZEBOX, and WS_MAXIMIZEBOX styles. Same as the\r
          WS_OVERLAPPEDWINDOW style. <E>\r
       <L WS_VISIBLE>   Creates a window that is initially visible. <E>\r
       <L WS_VSCROLL>   Creates a window that has a vertical scroll bar. <E>\r
       |</table>\r
       See also Win32.hlp (topic CreateWindow).\r
    }\r
    property ExStyle: DWord read fExStyle write SetExStyle;\r
    {* Extra window styles. Available flags are following:\r
       |<table border=0>\r
       <L WS_EX_ACCEPTFILES>    Specifies that a window created with this style\r
          accepts drag-drop files. <E>\r
       <L WS_EX_APPWINDOW>      Forces a top-level window onto the taskbar\r
          when the window is minimized. <E>\r
       <L WS_EX_CLIENTEDGE>     Specifies that a window has a border with a\r
          sunken edge. <E>\r
       <L WS_EX_CONTEXTHELP>    Includes a question mark in the title bar of\r
          the window. When the user clicks the question mark, the cursor\r
          changes to a question mark with a pointer. If the user then clicks\r
          a child window, the child receives a WM_HELP message. The child\r
          window should pass the message to the parent window procedure,\r
          which should call the WinHelp function using the HELP_WM_HELP\r
          command. The Help application displays a pop-up window that\r
          typically contains help for the child window.WS_EX_CONTEXTHELP\r
          cannot be used with the WS_MAXIMIZEBOX or WS_MINIMIZEBOX styles. <E>\r
       <L WS_EX_CONTROLPARENT> Allows the user to navigate among the child\r
          windows of the window by using the TAB key. <E>\r
       <L WS_EX_DLGMODALFRAME> Creates a window that has a double border;\r
          the window can, optionally, be created with a title bar by\r
          specifying the WS_CAPTION style in the dwStyle parameter. <E>\r
       <L WS_EX_LEFT>   Window has generic "left-aligned" properties. This\r
          is the default. <E>\r
       <L WS_EX_LEFTSCROLLBAR> If the shell language is Hebrew, Arabic, or\r
          another language that supports reading order alignment, the\r
          vertical scroll bar (if present) is to the left of the client\r
          area. For other languages, the style is ignored and not treated\r
          as an error. <E>\r
       <L WS_EX_LTRREADING>     The window text is displayed using Left to\r
          Right reading-order properties. This is the default. <E>\r
       <L WS_EX_MDICHILD>       Creates an MDI child window. <E>\r
       <L WS_EX_NOPARENTNOTIFY> Specifies that a child window created\r
          with this style does not send the WM_PARENTNOTIFY message to its\r
          parent window when it is created or destroyed. <E>\r
       <L WS_EX_OVERLAPPEDWINDOW>       Combines the WS_EX_CLIENTEDGE and\r
          WS_EX_WINDOWEDGE styles. <E>\r
       <L WS_EX_PALETTEWINDOW> Combines the WS_EX_WINDOWEDGE,\r
          WS_EX_TOOLWINDOW, and WS_EX_TOPMOST styles. <E>\r
       <L WS_EX_RIGHT> Window has generic "right-aligned" properties.\r
          This depends on the window class. This style has an effect only\r
          if the shell language is Hebrew, Arabic, or another language that\r
          supports reading order alignment; otherwise, the style is\r
          ignored and not treated as an error. <E>\r
       <L WS_EX_RIGHTSCROLLBAR> Vertical scroll bar (if present) is to the\r
          right of the client area. This is the default. <E>\r
       <L WS_EX_RTLREADING>     If the shell language is Hebrew, Arabic, or\r
          another language that supports reading order alignment, the\r
          window text is displayed using Right to Left reading-order\r
          properties. For other languages, the style is ignored and not\r
          treated as an error. <E>\r
       <L WS_EX_STATICEDGE>     Creates a window with a three-dimensional\r
          border style intended to be used for items that do not accept\r
          user input. <E>\r
       <L WS_EX_TOOLWINDOW>     Creates a tool window; that is, a window\r
          intended to be used as a floating toolbar. A tool window has\r
          a title bar that is shorter than a normal title bar, and the\r
          window title is drawn using a smaller font. A tool window does\r
          not appear in the taskbar or in the dialog that appears when\r
          the user presses ALT+TAB. <E>\r
       <L WS_EX_TOPMOST> Specifies that a window created with this style\r
          should be placed above all non-topmost windows and should stay\r
          above them, even when the window is deactivated. To add or remove\r
          this style, use the SetWindowPos function. <E>\r
       <L WS_EX_TRANSPARENT>    Specifies that a window created with this\r
          style is to be transparent. That is, any windows that are\r
          beneath the window are not obscured by the window. A window\r
          created with this style receives WM_PAINT messages only after\r
          all sibling windows beneath it have been updated. <E>\r
       <L WS_EX_WINDOWEDGE>     Specifies that a window has a border with\r
          a raised edge. <E>\r
       |</table>\r
       See also Win32.hlp (topic CreateWindowEx).\r
    }\r
\r
    property Cursor: HCursor read fCursor write SetCursor;\r
    {* Current cursor. For most of controls, sets initially to IDC_ARROW. See\r
       also ScreenCursor. }\r
    procedure CursorLoad( Inst: Integer; ResName: PChar );\r
    {* Loads Cursor from the resource. See also comments for Icon property. }\r
\r
    property Icon: HIcon read GetIcon write SetIcon;\r
    {* |<#appbutton>\r
       |<#form>\r
       Icon. By default, icon of the Applet is used. To load icon from the\r
       resource, use IconLoad or IconLoadCursor method - this is more correct, because\r
       in such case a special flag is set to prevent attempts to destroy\r
       shared icon object in the destructor of the control. }\r
\r
    procedure IconLoad( Inst: Integer; ResName: PChar );\r
    {* |<#appbutton>\r
       |<#form>\r
       See Icon property. }\r
    procedure IconLoadCursor( Inst: Integer; ResName: PChar );\r
    {* |<#appbutton>\r
       |<#form>\r
       Loads Icon from the cursor resource. See also Icon property. }\r
\r
\r
    property Menu: HMenu read fMenu write SetMenu;\r
\r
    {* Menu (or ID of control - for standard GUI controls). }\r
    property HelpContext: Integer read fHelpContext write SetHelpContext;\r
    {* Help context. }\r
    function AssignHelpContext( Context: Integer ): PControl;\r
    {* Assigns HelpContext and returns @ Self (can be used in initialization\r
       of a control in a chain of "transparent" calls). }\r
\r
    procedure CallHelp( Context: Integer; CtxCtl: PControl {; CtlID: Integer} );\r
    {* Method of a form or Applet. Call it to show help with the given context\r
       ID. If the Context = 0, help contents is displayed. By default,\r
       WinHelp is used. To allow using HtmlHelp, call AssignHtmlHelp global\r
       function. When WinHelp used, HelpPath variable can be assigned directly.\r
       If HelpPath variable is not assigned, application name\r
       (and path) is used, with extension replaced to '.hlp'. }\r
\r
    property HelpPath: String read GetHelpPath write SetHelpPath;\r
    {* Property of a form or an Applet. Change it to provide custom path to\r
       WinHelp format help file. If HtmlHelp used, call global procedure\r
       AssignHtmlHelp instead. }\r
\r
    property OnHelp: TOnHelp read fOnHelp write fOnHelp;\r
    {* An event of a form, it is called when F1 pressed or help topic requested\r
       by any other way. To prevent showing help, nullify Sender. Set Popup to\r
       TRUE to provide showing help in a pop-up window. It is also possible to\r
       change Context dynamically. }\r
\r
    property Caption: String read GetCaption write SetCaption;\r
    {* |<#appbutton>\r
       |<#form>\r
       |<#button>\r
       |<#bitbtn>\r
       |<#label>\r
       |<#wwlabel>\r
       |<#3dlabel>\r
       Caption of a window. For standard Windows buttons, labels and so on\r
       not a caption of a window, but text of the window. }\r
    property Text: String read GetCaption write SetCaption;\r
    {* |<#edit>\r
       |<#memo>\r
       The same as Caption. To make more convenient with Edit controls. For\r
       Rich Edit control, use property RE_Text. }\r
    property SelStart: Integer read GetSelStart write SetSelStart;\r
    {* |<#edit>\r
       |<#memo>\r
       |<#richedit>\r
       |<#listbox>\r
       |<#combo>\r
       Start of selection (editbox - character position, listbox and combobox -\r
       index of [the first] selected item). }\r
    property SelLength: Integer read GetSelLength write SetSelLength;\r
    {* |<#edit>\r
       |<#memo>\r
       |<#richedit>\r
       |<#listbox>\r
       |<#listview>\r
       Length of selection (editbox - number of characters selected, multiline\r
       listbox - number of items selected). }\r
\r
    property Selection: String read GetSelection write SetSelection;\r
    {* |<#edit>\r
       |<#memo>\r
       |<#richedit>\r
       Selected text (editbox, richedit) as string. Can be useful to replace\r
       selection. For rich edit, use RE_Text[ reText, TRUE ], if you want to\r
       read correctly characters from another locale then ANSI only. }\r
    procedure SelectAll;\r
    {* |<#edit>\r
       |<#memo>\r
       |<#richedit>\r
       Makes all the text in editbox or RichEdit, or all items in listbox\r
       selected. }\r
\r
    procedure ReplaceSelection( const Value: String; aCanUndo: Boolean );\r
    {* |<#edit>\r
       |<#memo>\r
       |<#richedit>\r
       Replaces selection (in edit, RichEdit). Unlike assigning new value\r
       to Selection property, it is possible to specify, if operation can\r
       be undone. }\r
\r
    procedure DeleteLines( FromLine, ToLine: Integer );\r
    {* |<#edit>\r
       |<#memo>\r
       |<#richedit>\r
       Deletes lines from FromLine to ToLine (inclusively, i.e. 0 to 0 deletes\r
       one line with index 0). Current selection is restored as possible. }\r
    property CurIndex: Integer read GetCurIndex write SetCurIndex;\r
    {* |<#listbox>\r
       |<#combo>\r
       |<#toolbar>\r
       Index of current item (for listbox, combobox) or button index pressed\r
       or dropped down (for toolbar button, and only in appropriate event\r
       handler call).\r
       |<br>\r
       You cannot use it to set or remove a selection in a multiple-selection\r
       list box, so you should set option loNoExtendSel to true.\r
       |<br>\r
       In OnClick event handler, CurIndex has not yet changed. Use OnSelChange\r
       to respond to selection changes. }\r
\r
    property Count: Integer read GetItemsCount write SetItemsCount;\r
    {* |<#listbox>\r
       |<#combo>\r
       |<#listview>\r
       |<#treeview>\r
       |<#edit>\r
       |<#memo>\r
       |<#richedit>\r
       |<#toolbar>\r
       Number of items (listbox, combobox, listview) or lines (multiline\r
       editbox, richedit control) or buttons (toolbar). It is possible to\r
       assign a value to this property only for listbox control with loNoData\r
       style and for list view control with lvoOwnerData style (virtual list\r
       box and list view). }\r
\r
    property Items[ Idx: Integer ]: String read GetItems write SetItems;\r
    {* |<#edit>\r
       |<#listbox>\r
       |<#combo>\r
       |<#memo>\r
       |<#richedit>\r
       Obvious. Used with editboxes, listbox, combobox. With list view, use\r
       property LVItems instead. }\r
\r
    function Item2Pos( ItemIdx: Integer ): Integer;\r
    {* |<#edit>\r
       |<#memo>\r
       Only for edit controls: converts line index to character position. }\r
    function Pos2Item( Pos: Integer ): Integer;\r
    {* |<#edit>\r
       |<#memo>\r
       Only for edit controls: converts character position to line index. }\r
\r
    function EditTabChar: PControl;\r
    {* |<#edit>\r
       |<#memo>\r
       Call this method (once) to provide insertion of tab character (code #9)\r
       when tab key is pressed on keyboard. }\r
\r
    function IndexOf( const S: String ): Integer;\r
    {* |<#listbox>\r
       |<#combobox>\r
       |<#tabcontrol>\r
       Works for the most of control types, though some of those\r
       have its own methods to search given item. If a control is not\r
       list box or combobox, item is finding by enumerating all\r
       the Items one by one. See also SearchFor method. }\r
    function SearchFor( const S: String; StartAfter: Integer; Partial: Boolean ): Integer;\r
    {* |<#listbox>\r
       |<#combobox>\r
       |<#tabcontrol>\r
       Works for the most of control types, though some of those\r
       have its own methods to search given item. If a control is not\r
       list box or combobox, item is finding by enumerating all\r
       the Items one by one. See also IndexOf method. }\r
\r
\r
    property ItemSelected[ ItemIdx: Integer ]: Boolean read GetItemSelected write SetItemSelected;\r
    {* |<#edit>\r
       |<#memo>\r
       |<#listbox>\r
       |<#combo>\r
       Returns True, if a line (in editbox) or an item (in listbox, combobox) is\r
       selected.\r
       Can be set only for listboxes. For listboxes, which are not multiselect, and\r
       for combo lists, it is possible only to set to True, to change selection. }\r
\r
    property ItemData[ Idx: Integer ]: DWORD read GetItemData write SetItemData;\r
    {* |<#listbox>\r
       |<#combo>\r
       Access to user-defined data, associated with the item of a list box and\r
       combo box. }\r
    property OnDropDown: TOnEvent read fOnDropDown write fOnDropDown;\r
    {* |<#combo>\r
       |<#toolbar>\r
       Is called when combobox is dropped down (or drop-down button of\r
       toolbar is pressed - see also OnTBDropDown). }\r
    property OnCloseUp: TOnEvent read fOnCloseUp write fOnCloseUp;\r
    {* |<#combo>\r
       Is called when combobox is closed up. When drop down list is closed\r
       because user pressed "Escape" key, previous selection is restored.\r
       To test if it is so, call GetKeyState( VK_ESCAPE ) and check, if\r
       negative value is returned (i.e. Escape key is pressed when event\r
       handler is calling). }\r
    property DroppedWidth: Integer read FDroppedWidth write SetDroppedWidth;\r
    {* |<#combo>\r
       Allows to change width of dropped down items list for combobox (only!)\r
       control. }\r
    property DroppedDown: Boolean read fDropped write SetDroppedDown;\r
    {* |<#combo>\r
       Dropped down state for combo box. Set it to TRUE or FALSE to change\r
       dropped down state. }\r
    procedure AddDirList( const Filemask: String; Attrs: DWORD );\r
    {* |<#listbox>\r
       |<#combo>\r
       Can be used only with listbox and combobox - to add directory list items,\r
       filtered by given Filemask (can contain wildcards) and Attrs. Following\r
       flags can be combined in Attrs:\r
       |<table border=0>\r
       |&L=<tr><td>%1</td><td>\r
       <L DDL_ARCHIVE> Include archived files. <E>\r
       <L DDL_DIRECTORY> Includes subdirectories. Subdirectory names are\r
          enclosed in square brackets ([ ]). <E>\r
       <L DDL_DRIVES> Includes drives. Drives are listed in the form [-x-],\r
          where x is the drive letter. <E>\r
       <L DDL_EXCLUSIVE> Includes only files with the specified attributes.\r
          By default, read-write files are listed even if DDL_READWRITE is\r
          not specified. Also, this flag needed to list directories only,\r
          etc. <E>\r
       <L DDL_HIDDEN> Includes hidden files. <E>\r
       <L DDL_READONLY> Includes read-only files. <E>\r
       <L DDL_READWRITE> Includes read-write files with no additional\r
          attributes. <E>\r
       <L DDL_SYSTEM> Includes system files. <E>\r
       </table>\r
       If the listbox is sorted, directory items will be sorted (alpabetically). }\r
    property OnBitBtnDraw: TOnBitBtnDraw read fOnBitBtnDraw write fOnBitBtnDraw;\r
    {* |<#bitbtn>\r
       Special event for BitBtn. Using it, it is possible to provide\r
       additional effects, such as highlighting button text (by changing\r
       its Font and other properties). If the handler returns True, it is\r
       supposed that it made all drawing and there are no further drawing\r
       occure. }\r
    property BitBtnDrawMnemonic: Boolean read FBitBtnDrawMnemonic write SetBitBtnDrawMnemonic;\r
    {* |<#bitbtn>\r
       Set this property to TRUE to provide correct drawing of bit btn control\r
       caption with '&' characters (to remove such characters, and underline\r
       follow ones). }\r
    property TextShiftX: Integer read fTextShiftX write fTextShiftX;\r
    {* |<#bitbtn>\r
       Horizontal shift for bitbtn text when the bitbtn is pressed. }\r
    property TextShiftY: Integer read fTextShiftY write fTextShiftY;\r
    {* |<#bitbtn>\r
       Vertical shift for bitbtn text when the bitbtn is pressed. }\r
    property BitBtnImgIdx: Integer read GetBitBtnImgIdx write SetBitBtnImgIdx;\r
    {* |<#bitbtn>\r
       BitBtn image index for the first image in list view, used as bitbtn\r
       image. It is used only in case when BitBtn is created with bboImageList\r
       option. }\r
    property BitBtnImgList: THandle read GetBitBtnImageList write SetBitBtnImageList;\r
    {* |<#bitbtn>\r
       BitBtn Image list. Assign image list handle to change it. }\r
\r
    function SetButtonIcon( aIcon: HIcon ): PControl;\r
    {* |<#button>\r
       Sets up button icon image and changes its styles. Returns button itself. }\r
    function SetButtonBitmap( aBmp: HBitmap ): PControl;\r
    {* |<#button>\r
       Sets up button icon image and changes its styles. Returns button itself. }\r
\r
    property OnMeasureItem: TOnMeasureItem read fOnMeasureItem write SetOnMeasureItem;\r
    {* |<#combo>\r
       |<#listbox>\r
       |<#listview>\r
       This event is called for owner-drawn controls, such as list box, combo box,\r
       list view with appropriate owner-drawn style. For fixed item height controls\r
       (list box with loOwnerDrawFixed style, combobox with coOwnerDrawFixed and\r
       list view with lvoOwnerDrawFixed option) this event is called once. For\r
       list box with loOwnerDrawVariable style and for combobox with coOwnerDrawVariable\r
       style this event is called for every item. }\r
\r
    property DefaultBtn: Boolean index 13\r
             {$IFDEF F_P}   read GetDefaultBtn\r
             {$ELSE DELPHI} read fDefaultBtn\r
             {$ENDIF F_P/DELPHI} write SetDefaultBtn;\r
    {* |<#button>\r
       |<#bitbtn>\r
       Set this property to true to make control clicked when ENTER key is pressed.\r
       This property uses OnMessage event of the parent form, storing it into\r
       fOldOnMessage field and calling in chain. So, assign default button\r
       after setting OnMessage event for the form. }\r
    property CancelBtn: Boolean index 27\r
             {$IFDEF F_P}   read GetDefaultBtn\r
             {$ELSE DELPHI} read fCancelBtn\r
             {$ENDIF F_P/DELPHI} write SetDefaultBtn;\r
    {* |<#button>\r
       |<#bitbtn>\r
       Set this property to true to make control clicked when escape key is pressed.\r
       This property uses OnMessage event of the parent form, storing it into\r
       fOldOnMessage field and calling in chain. So, assign cancel button\r
       after setting OnMessage event for the form. }\r
    function AllBtnReturnClick: PControl;\r
    {* Call this method for a form or any its control to provide clicking\r
       a focused button when ENTER pressed. By default, a button can be clicked\r
       only by SPACE key from the keyboard, or by mouse. }\r
    property IgnoreDefault: Boolean read fIgnoreDefault write fIgnoreDefault;\r
    {* Change this property to TRUE to ignore default button reaction on\r
       press ENTER key when a focus is grabbed of the control. Default\r
       value is different for different controls. By default, DefaultBtn\r
       ignored in memo, richedit (even if read-only). }\r
\r
\r
    property Color: TColor read fColor write SetCtlColor;\r
    {* Property Color is one of the most common for all visual\r
       elements (like form, control etc.) Please note, that standard GUI button\r
       can not change its color and the most characteristics of the Font. Also,\r
       standard button can not become Transparent. Use bitbtn for such purposes.\r
       Also, changing Color property for some kinds of control has no effect (rich edit,\r
       list view, tree view, etc.). To solve this, use native (for such controls)\r
       color property, or call Perform method with appropriate message to set the\r
       background color. }\r
    property Font: PGraphicTool read GetFont;\r
    {* If the Font property is not accessed, correspondent TGraphicTool object\r
       is not created and its methods are not included into executable. Leaving\r
       properties Font and Brush untouched can economy executable size a lot. }\r
    property Brush: PGraphicTool read GetBrush;\r
    {* If not accessed, correspondent TGraphicTool object is not created\r
       and its methods are not referenced. See also note on Font property. }\r
\r
    property Ctl3D: Boolean read fCtl3D write SetCtl3D;\r
    {* Inheritable from parent controls to child ones. }\r
\r
    procedure Show;\r
    {* |<#appbutton>\r
       |<#form>\r
       Makes control visible and activates it. }\r
    function ShowModal: Integer;\r
    {* |<#form>\r
       Can be used only with a forms to show it modal. See also global function\r
       ShowMsgModal.\r
       |<br>\r
       To use a form as a modal, it is possible to make it either auto-created\r
       or dynamically created. For a first case, You (may be prefer to hide a\r
       form after showing it as a modal:\r
       !\r
       !  procedure TForm1.Button1Click( Sender: PObj );\r
       !  begin\r
       !    Form2.Form.ShowModal;\r
       !    Form2.Form.Hide;\r
       !  end;\r
       !\r
       Another way is to create modal form just before showing it (this economies\r
       system resources):\r
       !\r
       !  procedure TForm1.Button1Click( Sender: PObj );\r
       !  begin\r
       !    NewForm2( Form2, Applet );\r
       !    Form2.Form.ShowModal;\r
       !    Form2.Form.Free; // Never call Form2.Free or Form2.Form.Close\r
       !  end;               // but always Form2.Form.Free; (!)\r
       !\r
       In samples above, You certainly can place any wished code before and after\r
       calling ShowModal method.\r
       |<br>\r
       Do not forget that if You have more than a single form in your project,\r
       separate Applet object should be used.\r
       |<br>\r
       See also ShowModalEx.\r
       }\r
    function ShowModalParented( const AParent: PControl ): Integer;\r
    {* by Alexander Pravdin. The same as ShowModal, but with a certain\r
       form as a parent. }\r
    function ShowModalEx: Integer;\r
    {* The same as ShowModal, but all the windows of current thread are\r
       disabled while showing form modal. This is useful if KOL form from\r
       a DLL is used modally in non-KOL application. }\r
    property ModalResult: Integer read fModalResult write\r
    {$IFDEF USE_SETMODALRESULT}\r
    SetModalResult;\r
    {$ELSE}\r
    fModalResult;\r
    {$ENDIF}\r
    {* |<#form>\r
       Modal result. Set it to value<>0 to stop modal dialog. By agreement,\r
       value 1 corresponds 'OK', 2 - 'Cancel'. But it is totally by decision\r
       of yours how to interpret this value. }\r
    property Modal: Boolean read GetModal;\r
    {* |<#form>\r
       TRUE, if the form is shown modal. }\r
    property ModalForm: PControl read fModalForm write fModalForm;\r
    {* |<#form>\r
       |<#appbutton>\r
       Form currently shown modal from this form or from Applet. }\r
\r
    procedure Hide;\r
    {* |<#appbutton>\r
       |<#form>\r
       Makes control hidden. }\r
    property OnShow: TOnEvent read FOnShow write SetOnShow;\r
    {* Is called when a control or form is to be shown. This event is not fired\r
       for a form, if its WindowState initially is set to wsMaximized or\r
       wsMinimized. This behaviour is by design (the window does not receive\r
       WM_SHOW message in such case). }\r
    property OnHide: TOnEvent read FOnHide write SetOnHide;\r
    {* Is called when a control or form becomes hidden. }\r
    property WindowState: TWindowState read GetWindowState write SetWindowState;\r
    {* |<#form>\r
       Window state. }\r
\r
    property Canvas: PCanvas read GetCanvas;\r
    {* |<#paintbox>\r
       Placeholder for Canvas: PCanvas. But in KOL, it is possible to\r
       create applets without canvases at all. To do so, avoid using\r
       Canvas and use DC directly (which is passed in OnPaint event). }\r
    function CallDefWndProc( var Msg: TMsg ): Integer;\r
    {* Function to be called in WndProc method to redirect message handling\r
       to default window procedure. }\r
    function DoSetFocus: Boolean;\r
    {* Sets focus for Enabled window. Returns True, if success. }\r
\r
    procedure MinimizeNormalAnimated;\r
    {* |<#form>\r
       Apply this method to a main form (not to another form or Applet,\r
       even when separate Applet control is not used and main form matches it!).\r
       This provides normal animated visual minimization for the application.\r
       It therefore has no effect, if animation during minimize/resore is\r
       turned off by user. }\r
\r
    property OnMessage: TOnMessage read fOnMessage write fOnMessage;\r
    {* |<#appbutton>\r
       |<#form>\r
       Is called for every message processed by TControl object. And for\r
       Applet window, this event is called also for all messages, handled by\r
       all its child windows (forms). }\r
\r
    function IsMainWindow: Boolean;\r
    {* |<#appbutton>\r
       |<#form>\r
       Returns True, if a window is the main in application (created first\r
       after the Applet, or matches the Applet). }\r
    property IsApplet: Boolean read FIsApplet;\r
    {* Returns true, if the control is created using NewApplet (or CreateApplet).\r
    }\r
    property IsForm: Boolean read fIsForm;\r
    {* Returns True, if the object is form window. }\r
    property IsMDIChild: Boolean read fIsMDIChild;\r
    {* Returns TRUE, if the object is MDI child form. In such case, IsForm also\r
       returns TRUE. }\r
    property IsControl: Boolean read fIsControl;\r
    {* Returns True, is the control is control (not form or applet). }\r
    property IsButton: Boolean read fIsButton;\r
    {* Returns True, if the control is button-like or containing buttons (button,\r
       bitbtn, checkbox, radiobox, toolbar). }\r
\r
    function ProcessMessage: Boolean;\r
    {* |<#appbutton>\r
       Processes one message. See also ProcessMessages. }\r
\r
    procedure ProcessMessages;\r
    {* |<#appbutton>\r
       Processes pending messages during long cycle of calculation,\r
       allowing to window to be repainted if needed and to respond to other\r
       messages. But if there are no such messages, your application can be\r
       stopped until such one appear in messages queue. To prevent such\r
       situation, use method ProcessPendingMessages instead. }\r
\r
    procedure ProcessMessagesEx;\r
    {* Version of ProcessMessages, which works always correctly, even if\r
       the application is minimized or background. }\r
\r
    procedure ProcessPendingMessages;\r
    {* |<#appbutton>\r
       Similar to ProcessMessages, but without waiting of\r
       message in messages queue. I.e., if there are no pending\r
       messages, this method immediately returns control to your\r
       code. This method is better to call during long cycle of\r
       calculation (then ProcessMessages). }\r
    procedure ProcessPaintMessages;\r
    {* }\r
    function WndProc( var Msg: TMsg ): Integer; virtual;\r
    {* Responds to all Windows messages, posted (sended) to the\r
       window, before all other proceeding. You can override it in\r
       derived controls, but in KOL there are several other ways\r
       to control message flow of existing controls without deriving\r
       another costom controls for only such purposes. See OnMessage,\r
       AttachProc.  }\r
    property HasBorder: Boolean read GetHasBorder write SetHasBorder;\r
    {* |<#form>\r
       Obvious. Form-aware. }\r
\r
    property HasCaption: Boolean read GetHasCaption write SetHasCaption;\r
    {* |<#form>\r
       Obvious. Form-aware. }\r
    property CanResize: Boolean read GetCanResize write SetCanResize;\r
    {* |<#form>\r
       Obvious. Form-aware. }\r
    property StayOnTop: Boolean read GetStayOnTop write SetStayOnTop;\r
    {* |<#form>\r
       Obvious. Form-aware, but can be applied to controls. }\r
    property Border: Integer read fMargin write fMargin;\r
    {* |<#form>\r
       Distance between edges and child controls and between child\r
       controls by default (if methods PlaceRight, PlaceDown, PlaceUnder,\r
       ResizeParent, ResizeParentRight, ResizeParentBottom are called).\r
       |<br>\r
       Originally was named Margin, now I recommend to use the name 'Border' to\r
       avoid confusion with MarginTop, MarginBottom, MarginLeft and\r
       MarginRight properties.\r
       |<br>\r
       Initial value is always 2. Border property is used in realigning\r
       child controls (when its Align property is not caNone), and value\r
       of this property determines size of borders between edges of children\r
       and its parent and between aligned controls too.\r
       |<br>\r
       See also properties MarginLeft, MarginRight, MarginTop, MarginBottom. }\r
    function SetBorder( Value: Integer ): PControl;\r
    {* Assigns new Border value, and returns @ Self. }\r
\r
    property Margin: Integer read fMargin write fMargin;\r
    {* |<#form>\r
       Old name for property Border. }\r
\r
    property MarginTop: Integer index 1\r
             {$IFDEF F_P}   read GetClientMargin\r
             {$ELSE DELPHI} read fClientTop\r
             {$ENDIF F_P/DELPHI} write SetClientMargin;\r
    {* Additional distance between true window client top and logical top of\r
       client rectangle. This value is added to Top of rectangle, returning\r
       by property ClientRect. Together with other margins and property Border,\r
       this property allows to change view of form for case, that Align property\r
       is used to align controls on parent (it is possible to provide some\r
       distance from child controls to its parent, and between child controls.\r
       |<br>\r
       Originally this property was introduced to compensate incorrect\r
       ClientRect property, calculated for some types of controls.\r
       |<br>\r
       See also properties Border, MarginBottom, MarginLeft, MarginRight. }\r
    property MarginBottom: Integer index 2\r
             {$IFDEF F_P}   read GetClientMargin\r
             {$ELSE DELPHI} read fClientBottom\r
             {$ENDIF F_P/DELPHI} write SetClientMargin;\r
    {* The same as MarginTop, but a distance between true window Bottom of\r
       client rectangle and logical bottom one. Take in attention, that this value\r
       should be POSITIVE to make logical bottom edge located above true edge.\r
       |<br>\r
       See also properties Border, MarginTop, MarginLeft, MarginRight. }\r
    property MarginLeft: Integer index 3\r
             {$IFDEF F_P}   read GetClientMargin\r
             {$ELSE DELPHI} read fClientLeft\r
             {$ENDIF F_P/DELPHI} write SetClientMargin;\r
    {* The same as MarginTop, but a distance between true window Left of\r
       client rectangle and logical left edge.\r
       |<br>\r
       See also properties Border, MarginTop, MarginRight, MarginBottom. }\r
    property MarginRight: Integer index 4\r
             {$IFDEF F_P}   read GetClientMargin\r
             {$ELSE DELPHI} read fClientRight\r
             {$ENDIF F_P/DELPHI} write SetClientMargin;\r
    {* The same as MarginLeft, but a distance between true window Right of\r
       client rectangle and logical bottom one. Take in attention, that this value\r
       should be POSITIVE to make logical right edge located left of true edge.\r
       |<br>\r
       See also properties Border, MarginTop, MarginLeft, MarginBottom. }\r
\r
    property Tabstop: Boolean read fTabstop write fTabstop;\r
    {* True, if control can be focused using tabulating between controls.\r
       Set it to False to make control unavailable for keyboard, but only\r
       for mouse. }\r
\r
    property TabOrder: Integer read fTabOrder write SetTabOrder;\r
    {* Order of tabulating of controls. Initially, TabOrder is equal to\r
       creation order of controls. If TabOrder changed, TabOrder of\r
       all controls with not less value of one is shifted up. To place\r
       control before another, assign TabOrder of one to another.\r
       For example:\r
       !             Button1.TabOrder := EditBox1.TabOrder;\r
       In code above, Button1 is placed just before EditBox1 in tabulating\r
       order (value of TabOrder of EditBox1 is incremented, as well as\r
       for all follow controls). }\r
\r
    property Focused: Boolean read GetFocused write SetFocused;\r
    {* True, if the control is current on form (but check also, what form\r
       itself is focused). For form it is True, if the form is active (i.e.\r
       it is foreground and capture keyboard). Set this value to True to make\r
       control current and focused (if applicable). }\r
\r
    function BringToFront: PControl;\r
    {* Changes z-order of the control, bringing it to the topmost level. }\r
    function SendToBack: PControl;\r
    {* Changes z-order of the control, sending it to the back of siblings. }\r
    property TextAlign: TTextAlign read GetTextAlign write SetTextAlign;\r
    {* |<#label>\r
       |<#panel>\r
       |<#button>\r
       |<#bitbtn>\r
       |<#edit>\r
       |<#memo>\r
       Text horizontal alignment. Applicable to labels, buttons,\r
       multi-line edit boxes, panels. }\r
    property VerticalAlign: TVerticalAlign read GetVerticalAlign write SetVerticalAlign;\r
    {* |<#button>\r
       |<#label>\r
       |<#panel>\r
       Text vertical alignment. Applicable to buttons, labels and panels. }\r
    property WordWrap: Boolean read fWordWrap;\r
    {* TRUE, if this is a label, created using NewWordWrapLabel. }\r
    property ShadowDeep: Integer read FShadowDeep write SetShadowDeep;\r
    {* |<#3dlabel>\r
       Deep of a shadow (for label effect only, created calling NewLabelEffect). }\r
\r
    property CannotDoubleBuf: Boolean read fCannotDoubleBuf write fCannotDoubleBuf;\r
    {* }\r
    property DoubleBuffered: Boolean read fDoubleBuffered write SetDoubleBuffered;\r
    {* Set it to true for some controls, which are flickering in repainting\r
       (like label effect). Slow, and requires additional code. This property\r
       is inherited by all child controls.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       Note: RichEdit control can not become DoubleBuffered. }\r
    //function IsSelfOrParentDblBuf: Boolean;\r
    {* Returns true, if DoubleBuffered or one of parents is DoubleBuffered. }\r
    function DblBufTopParent: PControl;\r
    {* Returns the topmost DoubleBuffered Parent control. }\r
    property Transparent: Boolean read fTransparent write SetTransparent;\r
    {* Set it to true to get special effects. Transparency also uses\r
       DoubleBuffered and inherited by child controls.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       Please note, that some controls can not be shown properly, when\r
       Transparent is set to True for it. If You want to make edit control\r
       transparent (e.g., over gradient filled panel), handle its OnChanged\r
       property and call there Invalidate to provide repainting of edit\r
       control content. Note also, that for RichEdit control property\r
       Transparent has no effect (as well as DoubleBuffered). But special\r
       property RE_Transparent is designed especially for RichEdit control\r
       (it works fine, but with great number of flicks while resizing\r
       of a control). Another note is about Edit control. To allow editing\r
       of transparent edit box, it is necessary to invalidate it for\r
       every pressed character. Or, use Ed_Transparent property instead. }\r
\r
    property Ed_Transparent: Boolean read fTransparent write EdSetTransparent;\r
    {* |<#edit>\r
       |<#memo>\r
       Use this property for editbox to make it really Transparent. Remember,\r
       that though Transparent property is inherited by child controls from\r
       its parent, this is not so for Ed_Transparent. So, it is necessary to\r
       set Ed_Transparent to True for every edit control explicitly. }\r
    property AlphaBlend: Integer read fAlphaBlend write SetAlphaBlend;\r
    {* |<#form>\r
       If assigned to 0..254, makes window (form or control) semi-transparent\r
       (Win2K only).\r
       |<br>\r
       Depending on value assigned, it is possible to adjust transparency\r
       level ( 0 - totally transparent, 255 - totally opaque).  }\r
\r
    property LookTabKeys: TTabKeys read fLookTabKeys write fLookTabKeys;\r
    {* Set of keys which can be used as tabulation keys in a control. }\r
    procedure GotoControl( Key: DWORD );\r
    {* |<#form>\r
       Emulates tabulation key press w/o sending message to current control.\r
       Can be applied to a form or to any its control. If VK_TAB is used,\r
       state of shift kay is checked in: if it is pressed, tabulate is in\r
       backward direction. }\r
    property SubClassName: String read get_ClassName write set_ClassName;\r
    {* Name of window class - unique for every window class\r
       in every run session of a program. }\r
\r
    property OnClose: TOnEventAccept read fOnClose write fOnClose;\r
    {* |<#form>\r
       |<#applet>\r
       Called before closing the window. It is possible to set Accept\r
       parameter to False to prevent closing the window. This event events\r
       is not called when windows session is finishing (to handle this\r
       event, handle WM_QUERYENDSESSION message, or assign OnQueryEndSession\r
       event to another or the same event handler). }\r
\r
    property OnQueryEndSession: TOnEventAccept read fOnQueryEndSession write SetOnQueryEndSession;\r
    {* |<#form>\r
       |<#applet>\r
       Called when WM_QUERYENDSESSION message come in. It is possible to set Accept\r
       parameter to False to prevent closing the window (in such case session ending\r
       is halted). It is possible to check CloseQueryReason property to find out,\r
       why event occur. }\r
    property CloseQueryReason: TCloseQueryReason read fCloseQueryReason;\r
    {* Reason why OnClose or OnQueryEndSession called. }\r
    property OnMinimize: TOnEvent index 0\r
             {$IFDEF F_P}   read GetOnMinMaxRestore\r
             {$ELSE DELPHI} read fOnMinimize\r
             {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;\r
    {* |<#form>\r
       Called when window is minimized. }\r
    property OnMaximize: TOnEvent index 8\r
             {$IFDEF F_P}   read GetOnMinMaxRestore\r
             {$ELSE DELPHI} read fOnMaximize\r
             {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;\r
    {* |<#form>\r
       Called when window is maximized. }\r
    property OnRestore: TOnEvent index 16\r
             {$IFDEF F_P}   read GetOnMinMaxRestore\r
             {$ELSE DELPHI} read fOnRestore\r
             {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;\r
    {* |<#form>\r
       Called when window is restored from minimized or maximized state. }\r
\r
    property UpdateRgn: HRgn read fUpdRgn;\r
    {* A handle of update region. Valid only in OnPaint method. You\r
       can use it to improve painting (for speed), if necessary. When\r
       UpdateRgn is obtained in response to WM_PAINT message, value\r
       of the property EraseBackground is used to pass it to the API\r
       function GetUpdateRgn. If UpdateRgn = 0, this means that entire\r
       window should be repainted. Otherwise, You (e.g.) can check\r
       if the rectangle is in clipping region using API function\r
       RectInRegion. }\r
\r
    property EraseBackground: Boolean read fEraseUpdRgn write fEraseUpdRgn;\r
    {* This value is used to pass it to the API function GetUpdateRgn,\r
       when UpadateRgn property is obtained first in responce to WM_PAINT\r
       message. If EraseBackground is set to True, system is responsible\r
       for erasing background of update region before painting. If not\r
       (default), the entire region invalidated should be painted by your\r
       event handler. }\r
\r
    property OnPaint: TOnPaint read fOnPaint write SetOnPaint;\r
    {* Event to set to override standard control painting. Can be applied\r
       to any control (though originally was designed only for paintbox\r
       control). When an event handler is called, it is possible to use\r
       UpdateRgn to examine what parts of window require painting to\r
       improve performance of the painting operation. }\r
\r
\r
    property OnEraseBkgnd: TOnPaint read fOnEraseBkgnd write SetOnEraseBkgnd;\r
    {* This event allows to override erasing window background in response\r
       to WM_ERASEBKGND message. This allows to add some decorations to\r
       standard controls without overriding its painting in total.\r
       Note: When erase background, remember, that property ClientRect can\r
       return not true client rectangle of the window - use GetClientRect\r
       API function instead. For example:\r
    !\r
    !var BkBmp: HBitmap;\r
    !\r
    !procedure TForm1.KOLForm1FormCreate(Sender: PObj);\r
    !begin\r
    !  Toolbar1.OnEraseBkgnd := DecorateToolbar;\r
    !  BkBmp := LoadBitmap( hInstance, 'BK1' );\r
    !end;\r
    !\r
    !procedure TForm1.DecorateToolbar(Sender: PControl; DC: HDC);\r
    !var CR: TRect;\r
    !begin\r
    !  GetClientRect( Sender.Handle, CR );\r
    !  Sender.Canvas.Brush.BrushBitmap := BkBmp;\r
    !  Sender.Canvas.FillRect( CR );\r
    !end;\r
    !\r
     }\r
\r
\r
    property OnClick: TOnEvent read fOnClick write fOnClick;\r
    {* |<#button>\r
       |<#checkbox>\r
       |<#radiobox>\r
       |<#toolbar>\r
       Called on click at control. For buttons, checkboxes and radioboxes\r
       is called regadless if control clicked by mouse or keyboard. For toolbar,\r
       the same event is used for all toolbar buttons and toolbar itself.\r
       To determine which toolbar button is clicked, check CurIndex property.\r
       And note, that all the buttons including separator buttons are enumerated\r
       starting from 0. Though images are stored (and prepared) only for\r
       non-separator buttons. And to determine, if toolbar button was clicked\r
       with right mouse button, check RightClick property. }\r
    property RightClick: Boolean read fRightClick;\r
    {* |<#toolbar>\r
       |<#listview>\r
       Use this property to determine which mouse button was clicked\r
       (applicable to toolbar in the OnClick event handler). }\r
    property OnEnter: TOnEvent read fOnEnter write fOnEnter;\r
    {* Called when control receives focus. }\r
    property OnLeave: TOnEvent read fOnLeave write fOnLeave;\r
    {* Called when control looses focus. }\r
    property OnChange: TOnEvent read fOnChange write fOnChange;\r
    {* |<#edit>\r
       |<#memo>\r
       |<#listbox>\r
       |<#combo>\r
       |<#tabcontrol>\r
       Called when edit control is changed, or selection in listbox or\r
       current index in combobox is changed (but if OnSelChanged assigned,\r
       the last is called for change selection). To respond to check/uncheck\r
       checkbox or radiobox events, use OnClick instead. }\r
    property OnSelChange: TOnEvent read fOnSelChange write fOnSelChange;\r
    {* |<#richedit>\r
       |<#listbox>\r
       |<#combo>\r
       |<#treeview>\r
       Called for rich edit control, listbox, combobox or treeview when current selection\r
       (range, or current item) is changed. If not assigned, but OnChange is\r
       assigned, OnChange is called instead. }\r
    property OnResize: TOnEvent read FOnResize write SetOnResize;\r
    {* Called whenever control receives message WM_SIZE (thus is, if\r
       control is resized. }\r
    property OnMove: TOnEvent read FOnMove write SetOnMove;\r
    {* Called whenever control receives message WM_MOVE (i.e. when control is\r
       moved over its parent). }\r
\r
    property MinSizePrev: Integer read fSplitMinSize1 write fSplitMinSize1;\r
    {* |<#splitter>\r
       Minimal allowed (while dragging splitter) size of previous control\r
       for splitter (see NewSplitter). }\r
    property SplitMinSize1: Integer read fSplitMinSize1 write fSplitMinSize1;\r
    {* The same as MinSizePrev. }\r
    property MinSizeNext: Integer read fSplitMinSize2 write fSplitMinSize2;\r
    {* |<#splitter>\r
       Minimal allowed (while dragging splitter) size of the rest of parent\r
       of splitter or of SecondControl (see NewSplitter). }\r
    property SplitMinSize2: Integer read fSplitMinSize2 write fSplitMinSize2;\r
    {* The same as MinSizeNext. }\r
    property SecondControl: PControl read fSecondControl write fSecondControl;\r
    {* |<#splitter>\r
       Second control to check (while dragging splitter) if its size not less\r
       than SplitMinSize2 (see NewSplitter). By default, second control is\r
       not necessary, and needed only in rare case when SecondControl can not\r
       be determined automatically to restrict splitter right (bottom) position. }\r
    property OnSplit: TOnSplit read fOnSplit write fOnSplit;\r
    {* |<#splitter>\r
       Called when splitter control is dragging - to allow for\r
       your event handler to decide if to accept new size of\r
       left (top) control, and new size of the rest area of parent. }\r
    property Dragging: Boolean read FDragging;\r
    {* |<#splitter>\r
       True, if splitter control is dragging now by user with left\r
       mouse button. Also, this property can be used to detect if the control\r
       is dragging with mouse (after calling DragStartEx method). }\r
    procedure DragStart;\r
    {* Call this method for a form or control to drag it with left mouse button,\r
       when mouse left button is already down. Dragging is stopped when left mouse\r
       button is released. See also DragStartEx, DragStopEx. }\r
    procedure DragStartEx;\r
    {* Call this method to start dragging the form by mouse. To stop\r
       dragging, call DragStopEx method. (Tip: to detect mouse up event,\r
       use OnMouseUp event of the dragging control). This method can be used\r
       to move any control with the mouse, not only entire form. State of\r
       mouse button is not significant. Determine dragging state of the control\r
       checking its Dragging property. }\r
    procedure DragStopEx;\r
    {* Call this method to stop dragging the form (started by DragStopEx). }\r
    procedure DragItem( OnDrag: TOnDrag );\r
    {* Starts dragging something with mouse. During the process,\r
       callback function OnDrag is called, which allows to control\r
       drop target, change cursor shape, etc. }\r
\r
    property OnKeyDown: TOnKey read fOnKeyDown write SetOnKeyDown;\r
    {* Obvious. }\r
    property OnKeyUp: TOnKey read fOnKeyUp write SetOnKeyUp;\r
    {* Obvious. }\r
    property OnChar: TOnChar read fOnChar write SetOnChar;\r
    {* Obvious. }\r
\r
    property OnMouseDown: TOnMouse read fOnMouseDown write SetMouseDown;\r
    {* Obvious. }\r
    property OnMouseUp: TOnMouse read fOnMouseUp write SetMouseUp;\r
    {* Obvious. }\r
    property OnMouseMove: TOnMouse read fOnMouseMove write SetMouseMove;\r
    {* Obvious. }\r
    property OnMouseDblClk: TOnMouse read fOnMouseDblClk write SetMouseDblClk;\r
    {* Obvious. }\r
    property OnMouseWheel: TOnMouse read fOnMouseWheel write SetMouseWheel;\r
    {* Obvious. }\r
\r
    property OnMouseEnter: TOnEvent read fOnMouseEnter write SetOnMouseEnter;\r
    {* Is called when mouse is entered into control. See also OnMouseLeave. }\r
    property OnMouseLeave: TOnEvent read fOnMouseLeave write SetOnMouseLeave;\r
    {* Is called when mouse is leaved control. If this event is assigned,\r
       then mouse is captured on mouse enter event to handle all other\r
       mouse events until mouse cursor leaves the control. }\r
    property OnTestMouseOver: TOnTestMouseOver read fOnTestMouseOver write SetOnTestMouseOver;\r
    {* |<#bitbtn>\r
       Special event, which allows to extend OnMouseEnter / OnMouseLeave\r
       (and also Flat property for BitBtn control). If a handler is assigned\r
       to this event, actual testing whether mouse is in control or not,\r
       is occuring in the handler. So, it is possible to simulate more\r
       careful hot tracking for controls with non-rectangular shape (such\r
       as glyphed BitBtn control). }\r
\r
    property MouseInControl: Boolean read fMouseInControl;\r
    {* |<#bitbtn>\r
       This property can return True only if OnMouseEnter / OnMouseLeave\r
       event handlers are set for a control (or, for BitBtn, property Flat\r
       is set to True. Otherwise, False is returned always. }\r
\r
    property Flat: Boolean read fFlat write SetFlat;\r
    {* |<#bitbtn>\r
       Set it to True for BitBtn, to provide either flat border for a button\r
       or availability of "highlighting" (correspondent to glyph index 4).\r
       |<br>\r
       Note: this can work incorrectly a bit under win95 without comctl32.dll\r
       updated. Therefore, application will launch. To enforce correct working\r
       even under Win95, use your own timer, which event handler checks for\r
       mouse over bitbtn control, e.g.:\r
       !    procedure TForm1.Timer1Timer(Sender: PObj);\r
       !    var P: TPoint;\r
       !    begin\r
       !      if not BitBtn1.MouseInControl then Exit;\r
       !      GetCursorPos( P );\r
       !      P := BitBtn1.Screen2Client( P );\r
       !      if not PtInRect( BitBtn1.ClientRect, P ) then\r
       !      begin\r
       !        BitBtn1.Flat := FALSE;\r
       !        BitBtn1.Flat := TRUE;\r
       !      end;\r
       !    end;\r
    }\r
    property RepeatInterval: Integer read fRepeatInterval write fRepeatInterval;\r
    {* |<#bitbtn>\r
       If this property is set to non-zero, it is interpreted (for BitBtn\r
       only) as an interval in milliseconds between repeat button down events,\r
       which are generated after first mouse or button click and until\r
       button is released. Though, if the button is pressed with keyboard (with\r
       space key), RepeatInterval value is ignored and frequency of repeatitive\r
       clicking is determined by user keyboard settings only. }\r
    function LikeSpeedButton: PControl;\r
    {* |<#button>\r
       |<#bitbtn>\r
       Transparent method (returns control itself). Makes button not focusable. }\r
\r
    function Add( const S: String ): Integer;\r
    {* |<#listbox>\r
       |<#combo>\r
       Only for listbox and combobox. }\r
\r
    function Insert( Idx: Integer; const S: String ): Integer;\r
    {* |<#listbox>\r
       |<#combo>\r
       Only for listbox and combobox. }\r
    procedure Delete( Idx: Integer );\r
    {* |<#listbox>\r
       |<#combo>\r
       Only for listbox and combobox. }\r
    procedure Clear;\r
    {* Clears object content. Has different sense for different controls.\r
       E.g., for label, editbox, button and other simple controls it\r
       assigns empty string to Caption property. For listbox, combobox,\r
       listview it deletes all items. For toolbar, it deletes all buttons.\r
       Et so on. }\r
\r
    property Progress: Integer index ((PBM_SETPOS or $8000) shl 16) or PBM_GETPOS\r
                               read GetIntVal write SetIntVal;\r
    {* |<#progressbar>\r
       Only for ProgressBar. }\r
    property MaxProgress: Integer index ((PBM_SETRANGE32 or $8000) shl 16) or PBM_GETRANGE\r
                               read GetIntVal write SetMaxProgress;\r
    {* |<#progressbar>\r
       Only for ProgressBar. 100 is the default value. }\r
    property ProgressColor: TColor read fTextColor write SetProgressColor;\r
    {* |<#progressbar>\r
       Only for ProgressBar. }\r
    property ProgressBkColor: TColor read fColor write SetCtlColor; //SetProgressBkColor;\r
    {* |<#progressbar>\r
       Obsolete. Now the same as Color. }\r
\r
    property StatusText[ Idx: Integer ]: PChar read GetStatusText write SetStatusText;\r
    {* |<#form>\r
       Only for forms to set/retrieve status text to/from given status panel.\r
       Panels are enumerated from 0 to 254, 255 is to indicate simple\r
       status bar. Size grip in right bottom corner of status window is\r
       displayed only if form still CanResize.\r
       |<br>\r
       When a status text is set first time, status bar window is created\r
       (always aligned to bottom), and form is resizing to preset client height.\r
       While status bar is showing, client height value is returned without\r
       height of status bar. To remove status bar, call RemoveStatus method for\r
       a form.\r
       |<br>\r
       By default, text is left-aligned within the specified part of a status\r
       window. You can embed tab characters (#9) in the text to center or\r
       right-align it. Text to the right of a single tab character is centered,\r
       and text to the right of a second tab character is right-aligned.\r
       |<br>\r
       If You use separate status bar onto several panels, these automatically\r
       align its widths to the same value (width divided to number of panels).\r
       To adjust status panel widths for every panel, use property StatusPanelRightX.\r
    }\r
    property SimpleStatusText: PChar index 255 read GetStatusText write SetStatusText;\r
    {* |<#form>\r
       Only for forms to set/retrive status text to/from simple status bar.\r
       Size grip in right bottom corner of status window is displayed only\r
       if form CanResize.\r
       |<br>\r
       When status text set first time, (simple) status bar window is created\r
       (always aligned to bottom), and form is resizing to preset client height.\r
       While status bar is showing, client height value is returned without\r
       height of status bar. To remove status bar, call RemoveStatus method for\r
       a form.\r
       |<br>\r
       By default, text is left-aligned within the specified part of a status\r
       window. You can embed tab characters (#9) in the text to center or\r
       right-align it. Text to the right of a single tab character is centered,\r
       and text to the right of a second tab character is right-aligned.\r
    }\r
    property StatusCtl: PControl read fStatusCtl;\r
    {* Pointer to Status bar control. To "create" child controls on\r
       the status bar, first create it as a child of form, for instance, and\r
       then change its property Parent, e.g.:\r
       ! var Progress1: PControl;\r
       ! ...\r
       ! Progress1 := NewProgressBar( Form1 );\r
       ! Progress1.Parent := Form1.StatusCtl;\r
       (If you use MCK, code should be another a bit, and in this case it is\r
       possible to create and adjust the control at design-time, and at run-time\r
       change its parent control. E.g. (Progress1 is created at run-time here too):\r
       ! Progress1 := NewProgressBar( Form );\r
       ! Progress1.Parent := Form.StatusCtl;\r
       ).\r
       Do not forget to provide StatusCtl to be existing first (e.g. assign\r
       one-space string to SimpleStatusText property of the form, for MCK do\r
       so using Object Inspector).\r
       }\r
    property SizeGrip: Boolean read fSizeGrip write fSizeGrip;\r
    {* Size grip for status bar. Has effect only before creating window. }\r
\r
    procedure RemoveStatus;\r
    {* |<#form>\r
       Call it to remove status bar from a form (created in result of assigning\r
       value(s) to StatusText[], SimpleStatusText properties). When status bar is\r
       removed, form is resized to preset client height. }\r
    function StatusPanelCount: Integer;\r
    {* |<#form>\r
       Returns number of status panels defined in status bar. }\r
    property StatusPanelRightX[ Idx: Integer ]: Integer read GetStatusPanelX write SetStatusPanelX;\r
    {* |<#form>\r
       Use this property to adjust status panel right edges (if the status bar is\r
       divided onto several subpanels). If the right edge for the last panel is\r
       set to -1 (by default) it is expanded to the right edge of a form window.\r
       Otherwise, status bar can be shorter then form width. }\r
    property StatusWindow: HWND read fStatusWnd;\r
    {* |<#form>\r
       Provided for case if You want to use API direct message sending to\r
       status bar. }\r
\r
    property Color1: TColor read fColor1 write SetColor1;\r
    {* |<#gradient>\r
       Top line color for GradientPanel. }\r
    property Color2: TColor read fColor2 write SetColor2;\r
    {* |<#gradient>\r
       |<#3Dlabel>\r
       Bottom line color for GradientPanel, or shadow color for LabelEffect.\r
       (If clNone, shadow color for LabelEffect is calculated as a mix bitween\r
       TextColor and clBlack). }\r
    property GradientStyle: TGradientStyle read FGradientStyle write SetGradientStyle;\r
    {* |<#gradient>\r
       Styles other then gsVertical and gsHorizontal has effect only for\r
       gradient panel, created by NewGradientPanelEx. }\r
    property GradientLayout: TGradientLayout read FGradientLayout write SetGradientLayout;\r
    {* |<#gradient>\r
       Has only effect for gradient panel, created by NewGradientPanelEx.\r
       Ignored for styles gsVertical and gsHorizontal. }\r
\r
    //======== Image lists (for ListView, TreeView, ToolBar and TabControl):\r
    property ImageListSmall: PImageList index 16 read GetImgListIdx write SetImgListIdx;\r
    {* |<#listview>\r
       Image list with small icons used with List View control. If not set,\r
       last added (i.e. created with a control as an owner) image list with\r
       small icons is used. }\r
    property ImageListNormal: PImageList index 32 read GetImgListIdx write SetImgListIdx;\r
    {* |<#listview>\r
       |<#treeview>\r
       |<#tabcontrol>\r
       |<#bitbtn>\r
       Image list with normal size icons used with List View control (or with\r
       icons for BitBtn, TreeView, ToolBar or TabControl). If not set,\r
       last added (i.e. created with a control as an owner) image list is used.\r
       }\r
    property ImageListState: PImageList index 0 read GetImgListIdx write SetImgListIdx;\r
    {* |<#listview>\r
       |<#treeview>\r
       Image list used as a state images list for ListView or TreeView control. }\r
\r
    //========\r
    function SetUnicode( Unicode: Boolean ): PControl;\r
    {* |<#listview>\r
       |<#treeview>\r
       |<#tabcontrol>\r
       Sets control as Unicode or not. The control itself is returned as for\r
       other "transparent" functions. A conditional define UNICODE_CTRLS must\r
       be added to a project to provide handling unicode messages. }\r
\r
    //======== TabControl-specific properties and methods:\r
    property Pages[ Idx: Integer ]: PControl read GetPages;\r
    {* |<#tabcontrol>\r
       Returns controls, which can be used as parent for controls, placed on\r
       different pages of a tab control. Use it like in follows example:\r
       | Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' );\r
       To find number of pages available, check out Count property of the tab\r
       control. Pages are enumerated from 0 to Count - 1, as usual. }\r
    property TC_Pages[ Idx: Integer ]: PControl read GetPages;\r
    {* |<#tabcontrol>\r
       The same as above. }\r
    function TC_Insert( Idx: Integer; const TabText: String; TabImgIdx: Integer ): PControl;\r
    {* |<#tabcontrol>\r
       Inserts new tab before given, returns correspondent page control\r
       (which can be used as a parent for controls to place on the page). }\r
    procedure TC_Delete( Idx: Integer );\r
    {* |<#tabcontrol>\r
       Removes tab from tab control, destroying all its child controls. }\r
    property TC_Items[ Idx: Integer ]: String read TCGetItemText write TCSetItemText;\r
    {* |<#tabcontrol>\r
       Text, displayed on tab control tabs. }\r
    property TC_Images[ Idx: Integer ]: Integer read TCGetItemImgIDx write TCSetItemImgIdx;\r
    {* |<#tabcontrol>\r
       Image index for a tab in tab control. }\r
    property TC_ItemRect[ Idx: Integer ]: TRect read TCGetItemRect;\r
    {* |<#tabcontrol>\r
       Item rectangle for a tab in tab control. }\r
    procedure TC_SetPadding( cx, cy: Integer );\r
    {* |<#tabcontrol>\r
       Sets space padding around tab text in a tab of tab control. }\r
    function TC_TabAtPos( x, y: Integer ): Integer;\r
    {* |<#tabcontrol>\r
       Returns index of tab, found at the given position (relative to\r
       a client rectangle of tab control). If no tabs found at the\r
       position, -1 is returned. }\r
    function TC_DisplayRect: TRect;\r
    {* |<#tabcontrol>\r
       Returns rectangle, occupied by a page rather then tab. }\r
    function TC_IndexOf(const S: String): Integer;\r
    {* |<#tabcontrol>\r
       By Mr Brdo. Index of page by its Caption. }\r
    function TC_SearchFor(const S: String; StartAfter: Integer; Partial: Boolean): Integer;\r
    {* |<#tabcontrol>\r
       By Mr Brdo. Index of page by its Caption. }\r
\r
    //======== ListView style and options:\r
    property LVStyle: TListViewStyle read fLVStyle write SetLVStyle;\r
    {* |<#listview>\r
       ListView style of view. Can be changed at run time. }\r
\r
    property LVOptions: TListViewOptions read fLVOptions write SetLVOptions;\r
    {* |<#listview>\r
       ListView options. Can be changed at run time. }\r
\r
    property LVTextColor: TColor index LVM_GETTEXTCOLOR\r
             {$IFDEF F_P}   read LVGetColorByIdx\r
             {$ELSE DELPHI} read fTextColor\r
             {$ENDIF F_P/DELPHI} write LVSetColorByIdx;\r
    {* |<#listview>\r
       ListView text color. Use it instead of TextColor. }\r
    property LVTextBkColor: TColor index LVM_GETTEXTBKCOLOR\r
             {$IFDEF F_P}   read LVGetColorByIdx\r
             {$ELSE DELPHI} read fLVTextBkColor\r
             {$ENDIF F_P/DELPHI} write LVSetColorByIdx;\r
    {* |<#listview>\r
       ListView background color for text. }\r
    property LVBkColor: TColor read fColor write SetCtlColor; //LVSetBkColor;\r
    {* |<#listview>\r
       ListView background color.  Use it instead of Color. }\r
\r
    //======== List View columns handling:\r
    property LVColCount: Integer read fLVColCount;\r
    {* |<#listview>\r
       ListView (additional) column count. Value 0 means that there are\r
       no columns (single item text / icon is used). If You want\r
       to provide several columns, first call LVColAdd to "insert" column 0,\r
       i.e. to provide header text for first column (with index 0).\r
       If there are no column, nothing will be shown in lvsDetail /\r
       lvsDetailNoHeader view style. }\r
    procedure LVColAdd( const aText: String; aalign: TTextAlign; aWidth: Integer );\r
    {* |<#listview>\r
       Adds new column. Pass 'width' <= 0 to provide default column width.\r
       'text' is a column header text. }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    procedure LVColAddW( const aText: WideString; aalign: TTextAlign; aWidth: Integer );\r
    {* |<#listview>\r
       Adds new column (unicode version). }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    procedure LVColInsert( ColIdx: Integer; const aText: String; aAlign: TTextAlign; aWidth: Integer );\r
    {* |<#listview>\r
       Inserts new column at the Idx position (1-based column index). }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    procedure LVColInsertW( ColIdx: Integer; const aText: WideString; aAlign: TTextAlign; aWidth: Integer );\r
    {* |<#listview>\r
       Inserts new column at the Idx position (1-based column index). }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    procedure LVColDelete( ColIdx: Integer );\r
    {* |<#listview>\r
       Deletes column from List View }\r
    property LVColWidth[ Item: Integer ]: Integer index LVM_GETCOLUMNWIDTH\r
             read GetItemVal write SetItemVal;\r
    {* |<#listview>\r
       Retrieves or changes column width. For lvsList view style, the same width\r
       is returned for all columns (ColIdx is ignored). It is possible to use\r
       special values to assign to a property:\r
       |<br> LVSCW_AUTOSIZE - Automatically sizes the column\r
       |<br> LVSCW_AUTOSIZE_USEHEADER - Automatically sizes the column to fit\r
       the header text\r
       |<br>\r
       To set coumn width in lvsList view mode, column index must be -1\r
       (and Width to set must be in range 0..32767 always). }\r
    property LVColText[ Idx: Integer ]: String read GetLVColText write SetLVColText;\r
    {* |<#listview>\r
       Allows to get/change column header text at run time. }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    property LVColTextW[ Idx: Integer ]: WideString read GetLVColTextW write SetLVColTextW;\r
    {* |<#listview>\r
       Allows to get/change column header text at run time. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    property LVColAlign[ Idx: Integer ]: TTextAlign read GetLVColalign write SetLVColalign;\r
    {* |<#listview>\r
       Column text aligning. }\r
    property LVColImage[ Idx: Integer ]: Integer index LVCF_IMAGE or (24 shl 16) read GetLVColEx write SetLVColEx;\r
    {* |<#listview>\r
       Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to\r
       set an image for list view column itself from the ImageListSmall.\r
    }\r
    property LVColOrder[ Idx: Integer ]: Integer index LVCF_ORDER or (28 shl 16) read GetLVColEx write SetLVColEx;\r
    {* |<#listview>\r
       Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to\r
       set visual order of the list view column from the ImageListSmall.\r
       This value does not affect the index, by which the column is still\r
       accessible in the column array.\r
    }\r
\r
    //======== List View items handling:\r
    property LVCount: Integer read GetItemsCount write SetItemsCount;\r
    {* |<#listview>\r
       Returns item count for ListView control. It is possible to use Count\r
       property instead when obtaining of item count is needed only. But this this\r
       property allows also to set actual count of list view items when a list\r
       view is virtual. }\r
\r
    property LVCurItem: Integer read GetLVCurItem write SetLVCurItem;\r
    {* |<#listview>\r
       Returns first selected item index in a list view. See also LVNextSelected\r
       and LVNextItem functions. }\r
\r
    function LVNextItem( IdxPrev: Integer; Attrs: DWORD ): Integer;\r
    {* |<#listview>\r
       Returns an index of the next after IdxPrev item with given attributes in\r
       the list view. }\r
    function LVNextSelected( IdxPrev: Integer ): Integer;\r
    {* |<#listview>\r
       Returns an index of next (after IdxPrev) selected item in a list view. }\r
\r
    function LVAdd( const aText: String; ImgIdx: Integer; State: TListViewItemState;\r
                     StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer;\r
    {* |<#listview>\r
       Adds new line to the end of ListView control. Only content of item itself\r
       is set (aText, ImgIdx). To change other column text and attributes of\r
       item added, use appropriate properties / methods ().\r
       |<br>\r
       Returns an index of added item.\r
       |<br>\r
       There is no Unicode version defined, use LVItemAddW instead. }\r
    function LVItemAdd( const aText: String ): Integer;\r
    {* |<#listview>\r
       Adds an item to the end of list view. Returns an index of the item added. }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    function LVItemAddW( const aText: WideString ): Integer;\r
    {* |<#listview>\r
       Adds an item to the end of list view. Returns an index of the item added. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    function LVInsert( Idx: Integer; const aText: String; ImgIdx: Integer;\r
              State: TListViewItemState;  StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer;\r
    {* |<#listview>\r
       Inserts new line before line with index Idx in ListView control. Only\r
       content of item itself is set (aText, ImgIdx). To change other column\r
       text and attributes of item added, use appropriate properties / methods ().\r
       if ImgIdx = I_IMAGECALLBACK, event handler OnGetLVItemImgIdx is responsible\r
       for returning image index for an item ( /// not implemented yet /// )\r
       Pass StateImgIdx and OverlayImgIdx = 0 (ignored in that case) or 1..15 to\r
       use correspondent icon from ImageListState image list.\r
       |<br> Returns an index of item inserted.\r
       |<br> There is no unicode version of this method, use LVItemInsertW. }\r
    function LVItemInsert( Idx: Integer; const aText: String ): Integer;\r
    {* |<#listview>\r
       Inserts an item to Idx position. }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    function LVItemInsertW( Idx: Integer; const aText: WideString ): Integer;\r
    {* |<#listview>\r
       Inserts an item to Idx position. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
\r
    procedure LVDelete( Idx: Integer );\r
    {* |<#listview>\r
       Deletes item of ListView with subitems (full row - in lvsDetail view style. }\r
    procedure LVSetItem( Idx, Col: Integer; const aText: String; ImgIdx: Integer;\r
              State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; Data: DWORD );\r
    {* |<#listview>\r
       Use this method to set item data and item columns data for ListView control.\r
       It is possible to pass I_SKIP as ImgIdx, StateImgIdx, OverlayImgIdx values to\r
       skip setting this fields. But all other are set always. Like in LVInsert /\r
       LVAdd, ImgIdx can be I_IMAGECALLBACK to determine that image will be\r
       retrieved in OnGetItemImgIdx event handler when needed.\r
       |<br>\r
       If this method is called to set data for column > 0, parameters ImgIdx and\r
       Data are ignored anyway.\r
       |<br> There is no unicode version of this method, use other methods\r
       to set up listed properties separately using correspondent W-functions. }\r
\r
    property LVItemState[ Idx: Integer ]: TListViewItemState read LVGetItemState write LVSetItemState;\r
    {* |<#listview>\r
       Access to list view item states set [lvisBlend, lvisHighlight, lvisFocus,\r
       lvisSelect]. When assign new value to the property, it is possible to use\r
       special index value -1 to change state for all items for a list view\r
       (but only when lvoMultiselect style is applied to the list view, otherwise\r
       index -1 is referring to the last item of the list view). }\r
\r
    property LVItemIndent[ Idx: Integer ]: Integer read LVGetItemIndent write LVSetItemIndent;\r
    {* Item indentation. Indentation is calculated as this value multiplied to\r
       image list ImgWidth value (Image list must be applied to list view).\r
       Note: indentation supported only if IE3.0 or higher installed. }\r
    property LVItemStateImgIdx[ Idx: Integer ]: Integer read LVGetSttImgIdx write LVSetSttImgIdx;\r
    {* |<#listview>\r
       Access to state image of the item. Use index -1 to assign the same state\r
       image index to all items of the list view at once (fast).\r
       Option lvoCheckBoxes just means, that control itself creates special inner\r
       image list for two state images. Later it is possible to examine checked\r
       state for items or set checked state programmatically by changing\r
       LVItemStateImgIdx[ ] property. Value 1 corresponds to unchecked state,\r
       2 to checked. Value 0 allows to remove checkbox at all. So, to check all\r
       added items by default (e.g.), do following:\r
       ! ListView1.LVItemStateImgIdx[ -1 ] := 2;\r
       |<br>Use 1-based index of the image\r
       in image list ImageListState. Value 0 reserved to use as "no state image".\r
       Values 1..15 can be used only - this is the Windows restriction on\r
       state images. }\r
    property LVItemOverlayImgIdx[ Idx: Integer ]: Integer read LVGetOvlImgIdx write LVSetOvlImgIdx;\r
    {* |<#listview>\r
       Access to overlay image of the item. Use index -1 to assign the same\r
       overlay image to all items of the list view at once (fast). }\r
    property LVItemData[ Idx: Integer ]: DWORD read LVGetItemData write LVSetItemData;\r
    {* |<#listview>\r
       Access to user defined data, assiciated with the item of the list view. }\r
    procedure LVSelectAll;\r
    {* |<#listview>\r
       Call this method to select all the items of the list view control. }\r
    property LVSelCount: Integer read GetSelLength write SetSelLength;\r
    {* |<#listview>\r
       Returns number of items selected in listview. }\r
    property LVItemImageIndex[ Idx: Integer ]: Integer read LVGetItemImgIdx write LVSetItemImgIdx;\r
    {* |<#listview>\r
       Image index of items in listview. When an item is created (using LVItemAdd\r
       or LVItemInsert), image index 0 is set by default (not -1 like in VCL!). }\r
    property LVItems[ Idx, Col: Integer ]: String read LVGetItemText write LVSetItemText;\r
    {* |<#listview>\r
       Access to List View item text. }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    property LVItemsW[ Idx, Col: Integer ]: WideString read LVGetItemTextW write LVSetItemTextW;\r
    {* |<#listview>\r
       Access to List View item text. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    function LVItemRect( Idx: Integer; Part: TGetLVItemPart ): TRect;\r
    {* |<#listview>\r
       Returns rectangle occupied by given item part(s) in ListView window.\r
       Empty rectangle is returned, if the item is not viewing currently. }\r
    function LVSubItemRect( Idx, ColIdx: Integer ): TRect;\r
    {* |<#listview>\r
       Returns rectangle occupied by given item's subitem in ListView window,\r
       in lvsDetail or lvsDetailNoHeader style. Empty rectangle (0,0,0,0) is\r
       returned if the item is not viewing currently. Left or/and right bounds\r
       of the rectangle returned can be outbound item rectangle if only a part\r
       of the subitem is visible or the subitem is not visible in the item,\r
       which is visible itself. }\r
    property LVItemPos[ Idx: Integer ]: TPoint read LVGetItemPos write LVSetItemPos;\r
    {* |<#listview>\r
       Position of List View item (can be changed in icon or small icon view). }\r
    function LVItemAtPos( X, Y: Integer ): Integer;\r
    {* |<#listview>\r
       Return index of item at the given position. }\r
    function LVItemAtPosEx( X, Y: Integer; var Where: TWherePosLVItem ): Integer;\r
    {* |<#listview>\r
       Retrieves index of item and sets in Where, what part of item is under\r
       given coordinates. If there are no items at the specified position,\r
       -1 is returned. }\r
    procedure LVMakeVisible( Item: Integer; PartiallyOK: Boolean );\r
    {* |<#listview>\r
       Makes listview item visible. Ignred when Item passed < 0. }\r
    procedure LVEditItemLabel( Idx: Integer );\r
    {* |<#listview>\r
       Begins in-place editing of item label (first column text). }\r
    procedure LVSort;\r
    {* |<#listview>\r
       Initiates sorting of list view items. This sorting procedure is available only\r
       for Win2K, WinNT4 with IE5, Win98 or Win95 with IE5. See also LVSortData. }\r
    procedure LVSortData;\r
    {* |<#listview>\r
       Initiates sorting of list view items. This sorting procedure is always available\r
       in Windows95/98, NT/2000. But OnCompareLVItems procedure receives not indexes of\r
       items compared but its Data field associated instead. }\r
    procedure LVSortColumn( Idx: Integer );\r
    {* |<#listview>\r
       This is a method to simplify sort by column. Just call it in your OnColumnClick\r
       event passing column index and enjoy with your list view sorted automatically\r
       when column header is clicked. Requieres Windows2000 or Winows98, not supported\r
       under WinNT 4.0 and below and under Windows95.\r
       |<br>\r
       Either lvoSortAscending or lvoSortDescending option must be set in\r
       LVOptions, otherwise no sorting is performed. }\r
    function LVIndexOf( const S: String ): Integer;\r
    {* Returns first list view item index with caption matching S.\r
       The same as LVSearchFor( S, -1, FALSE ). }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    function LVIndexOfW( const S: WideString ): Integer;\r
    {* Returns first list view item index with caption matching S.\r
       The same as LVSearchForW( S, -1, FALSE ). }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    function LVSearchFor( const S: String; StartAfter: Integer; Partial: Boolean ): Integer;\r
    {* Searches an item with Caption equal to S (or starting from S, if Partial = TRUE).\r
       Searching is started after an item specified by StartAfter parameter. }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    function LVSearchForW( const S: WideString; StartAfter: Integer; Partial: Boolean ): Integer;\r
    {* Searches an item with Caption equal to S (or starting from S, if Partial = TRUE).\r
       Searching is started after an item specified by StartAfter parameter. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
\r
    //======== List view page:\r
    property LVTopItem: Integer index LVM_GETTOPINDEX read GetIntVal; //LVGetTopItem;\r
    {* |<#listview>\r
       Returns index of topmost visible item of ListView in lvsList view style. }\r
    property LVPerPage: Integer index LVM_GETCOUNTPERPAGE read GetIntVal; //LVGetPerPage;\r
    {* |<#listview>\r
       Returns the number of fully-visible items if successful. If the current\r
       view is icon or small icon view, the return value is the total number\r
       of items in the list view control. }\r
\r
    //======== List View specific events:\r
    property OnEndEditLVItem: TOnEditLVItem read fOnEditLVITem write SetOnEditLVItem;\r
    {* |<#listview>\r
       Called when edit of an item label in ListView control finished. Return\r
       True to accept new label text, or false - to not accept it (item label\r
       will not be changed). If handler not set to an event, all changes are\r
       accepted. }\r
\r
    property OnDeleteLVItem: TOnDeleteLVItem read fOnDeleteLVItem write SetOnDeleteLVItem;\r
    {* |<#listview>\r
       Called for every deleted list view item. }\r
    property OnDeleteAllLVItems: TOnEvent read fOnDeleteAllLVItems write SetOnDeleteAllLVItems;\r
    {* |<#listview>\r
       Called when all the items of the list view control are to be deleted. If after\r
       returning from this event handler event OnDeleteLVItem is yet assigned,\r
       an event OnDeleteLVItem will be called for every deleted item. }\r
    property OnLVData: TOnLVData read fOnLVData write SetOnLVData;\r
    {* |<#listview>\r
       Called to provide virtual list view with actual data. To use list view as\r
       virtaul list view, define also lvsOwnerData style and set Count property\r
       to actual row count of the list view. This manner of working with list view\r
       control can greatly improve performance of an application when working with\r
       huge data sets represented in listview control. }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    property OnLVDataW: TOnLVDataW read fOnLVDataW write SetOnLVDataW;\r
    {* |<#listview>\r
       The same as OnLVData, but for unicode version of the list view allows\r
       to return WideString text in the event handler. Though for unicode list\r
       view it is still possible to use ordinary event OnLVData, it is\r
       very recommended to use this event istead. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
\r
    property OnCompareLVItems: TOnCompareLVItems read fOnCompareLVItems write fOnCompareLVItems;\r
    {* |<#listview>\r
       Event to compare two list view items during sort operation (initiated by\r
       LVSort method call). Do not send any messages to the list view control\r
       while it is sorting - results can be unpredictable! }\r
    property OnColumnClick: TOnLVColumnClick read fOnColumnClick write SetOnColumnClick;\r
    {* |<#listview>\r
       This event handler is called when column of the list view control is clicked.\r
       You can use this event to initiate sorting of list view items by this column. }\r
    property OnLVStateChange: TOnLVStateChange read FOnLVStateChange write SetOnLVStateChange;\r
    {* |<#listview>\r
       This event occure when an item or items range in list view control are\r
       changing its state (e.g. selected or unselected). }\r
    property OnLVDelete: TOnLVDelete read FOnLVDelete write SetOnLVDelete;\r
    {* |<#listview>\r
       This event is called when an item is deleted in the listview.\r
       Do not add, delete, or rearrange items in the list view while processing\r
       this notification. }\r
    property OnDrawItem: TOnDrawItem read fOnDrawItem write SetOnDrawItem;\r
    {* |<#listview>\r
       |<#listbox>\r
       |<#combo>\r
       This event can be used to implemet custom drawing for list view, list box, dropped\r
       list of a combobox. For a list view, custom drawing using this event is possible\r
       only in lvsDetail and lvsDetailNoHeader styles, and OnDrawItem is called to draw\r
       entire row at once only. See also OnLVCustomDraw event. }\r
\r
    property OnLVCustomDraw: TOnLVCustomDraw read FOnLVCustomDraw write SetOnLVCustomDraw;\r
    {* |<#listview>\r
       Custom draw event for listview. For every item to be drawn, this event\r
       can be called several times during a single drawing cycle - depending on\r
       a result, returned by an event handler. Stage can have one of following\r
       values:\r
       |<pre>\r
       CDDS_PREERASE\r
       CDDS_POSTERASE\r
       CDDS_ITEMPREERASE\r
       CDDS_PREPAINT\r
       CDDS_ITEMPREPAINT\r
       CDDS_ITEM\r
       CDDS_SUBITEM + CDDS_ITEMPREPAINT\r
       CDDS_SUBITEM + CDDS_ITEMPOSTPAINT\r
       CDDS_ITEMPOSTPAINT\r
       CDDS_POSTPAINT\r
       </pre>\r
       When called, see on Stage to get know, on what stage the event is\r
       activated. And depend on the stage and on what you want to paint,\r
       return a value as a result, which instructs the system, if to use\r
       default drawing on this (and follows) stage(s) for the item, and if\r
       to notify further about different stages of drawing the item during\r
       this drawing cycle. Possible values to return are:\r
       |<pre>\r
       CDRF_DODEFAULT - perform default drawing. Do not notify further for this\r
                      item (subitem) (or for entire listview, if called with\r
                      flag CDDS_ITEM reset - ?);\r
       CDRF_NOTIFYITEMDRAW - return this value, when the event is called the\r
                      first time in a cycle of drawing, with ItemIdx = -1 and\r
                      flag CDDS_ITEM reset in Stage parameter;\r
       CDRF_NOTIFYPOSTERASE - usually can be used to provide default erasing,\r
                      if you want to perform drawing immediately after that;\r
       CDRF_NOTIFYPOSTPAINT - return this value to provide calling the event\r
                      after performing default drawing. Useful when you wish\r
                      redraw only a part of the (sub)item;\r
       CDRF_SKIPDEFAULT - return this value to inform the system that all\r
                      drawing is done and system should not peform any more\r
                      drawing for the (sub)item during this drawing cycle.\r
       CDRF_NEWFONT - informs the system, that font is changed and default\r
                      drawing should be performed with changed font;\r
       |</pre>\r
       If you want to get notifications for each subitem, do not use option\r
       lvoOwnerDrawFixed, because such style prevents system from notifying\r
       the application for each subitem to be drawn in the listview and only\r
       notifications will be sent about entire items.\r
       |<br>\r
       See also NM_CUSTOMDRAW in API Help.\r
    }\r
\r
    procedure Set_LVItemHeight(Value: Integer);\r
    function SetLVItemHeight(Value: Integer): PControl;\r
    property LVItemHeight: Integer read fLVItemHeight write Set_LVItemHeight;\r
\r
\r
    //======== TreeView specific properties and methods:\r
    function TVInsert( nParent, nAfter: THandle; const Txt: String ): THandle;\r
    {* |<#treeview>\r
       Inserts item to a tree view. If nParent is 0 or TVI_ROOT, the item is\r
       inserted at the root of tree view. It is possible to pass following special\r
       values as nAfter parameter:\r
       |<pre>\r
       TVI_FIRST        Inserts the item at the beginning of the list.\r
       TVI_LAST         Inserts the item at the end of the list.\r
       TVI_SORT         Inserts the item into the list in alphabetical order.\r
       |</pre> }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    function TVInsertW( nParent, nAfter: THandle; const Txt: WideString ): THandle;\r
    {* |<#treeview>\r
       Inserts item to a tree view. If nParent is 0 or TVI_ROOT, the item is\r
       inserted at the root of tree view. It is possible to pass following special\r
       values as nAfter parameter:\r
       |<pre>\r
       TVI_FIRST        Inserts the item at the beginning of the list.\r
       TVI_LAST         Inserts the item at the end of the list.\r
       TVI_SORT         Inserts the item into the list in alphabetical order.\r
       |</pre><br>\r
       This version of the method is Unicode. The tree view control should be\r
       set up as unicode control calling Perform( TVM_SETUNICODEFORMAT, 1, 0 ),\r
       and conditional symbol UNICODE_CTRLS must be defined to provide event\r
       handling for such kind of tree view (and other Unicode) controls. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    procedure TVDelete( Item: THandle );\r
    {* |<#treeview>\r
       Removes an item from the tree view. If value TVI_ROOT is passed, all items\r
       are removed. }\r
\r
    property TVSelected: THandle index TVGN_CARET read TVGetItemIdx write TVSetItemIdx;\r
    {* |<#treeview>\r
       Returns or sets currently selected item handle in tree view. }\r
\r
    property TVDropHilighted: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx;\r
    {* |<#treeview>\r
       Returns or sets item, which is currently highlighted as a drop target. }\r
    property TVDropHilited: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx;\r
    {* The same as TVDropHilighted. }\r
    property TVFirstVisible: THandle index TVGN_FIRSTVISIBLE read TVGetItemIdx write TVSetItemIdx;\r
    {* |<#treeview>\r
       Returns or sets given item to top of tree view. }\r
\r
    property TVIndent: Integer index TVM_GETINDENT read GetIntVal write SetIntVal;\r
    {* |<#treeview>\r
       The amount, in pixels, that child items are indented relative to their\r
       parent items. }\r
    property TVVisibleCount: Integer index TVM_GETVISIBLECOUNT read GetIntVal;\r
    {* |<#treeview>\r
       Returns number of fully (not partially) visible items in tree view. }\r
\r
    property TVRoot: THandle index TVGN_ROOT read TVGetItemIdx;\r
    {* |<#treeview>\r
       Returns handle of root item in tree view (or 0, if tree is empty). }\r
    property TVItemChild[ Item: THandle ]: THandle index TVGN_CHILD read TVGetItemNext;\r
    {* |<#treeview>\r
       Returns first child item for given one. }\r
    property TVItemHasChildren[ Item: THandle ]: Boolean read TV_GetItemHasChildren write TV_SetItemHasChildren;\r
    {* |<#treeview>\r
       TRUE, if an Item has children. Set this value to true if you want to\r
       force [+] sign appearing left from the node, even if there are no\r
       subnodes added to the node yet. }\r
    property TVItemChildCount[ Item: THandle ]: Integer read TV_GetItemChildCount;\r
    {* |<#treeview>\r
       Returns number of node child items in tree view.\r
    }\r
    property TVItemNext[ Item: THandle ]: THandle index TVGN_NEXT read TVGetItemNext;\r
    {* |<#treeview>\r
       Returns next sibling item handle for given one (or 0, if passed item is\r
       the last child for its parent node). }\r
    property TVItemPrevious[ Item: THandle ]: THandle index TVGN_PREVIOUS read TVGetItemNext;\r
    {* |<#treeview>\r
       Returns previous sibling item (or 0, if the is no such item). }\r
    property TVItemNextVisible[ Item: THandle ]: THandle index TVGN_NEXTVISIBLE read TVGetItemNext;\r
    {* |<#treeview>\r
       Returns next visible item (passed item must be visible too, to determine,\r
       if it is really visible, use property TVItemRect or TVItemVisible. }\r
    property TVItemPreviousVisible[ Item: THandle ]: THandle index TVGN_PREVIOUSVISIBLE read TVGetItemNext;\r
    {* |<#treeview>\r
       Returns previous visible item. }\r
    property TVItemParent[ Item: THandle ]: THandle index TVGN_PARENT read TVGetItemNext;\r
    {* |<#treeview>\r
       Returns parent item for given one (or 0 for root item). }\r
\r
    property TVItemText[ Item: THandle ]: String read TVGetItemText write TVSetItemText;\r
    {* |<#treeview>\r
       Text of tree view item. }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    property TVItemTextW[ Item: THandle ]: WideString read TVGetItemTextW write TVSetItemTextW;\r
    {* |<#treeview>\r
       Text of tree view item. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    function TVItemPath( Item: THandle; Delimiter: Char ): String;\r
    {* |<#treeview>\r
       Returns full path from the root item to given item. Path is calculated\r
       as a concatenation of all parent nodes text strings, separated by\r
       given delimiter character.\r
       |<br>Please note, that returned path has no trailing delimiter, this\r
       character is only separating different parts of the path.\r
       |<br>If Item is not specified ( =0 ), path is returned\r
       for Selected item. }\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    function TVItemPathW( Item: THandle; Delimiter: WideChar ): WideString;\r
    {* |<#treeview>\r
       Returns full path from the root item to given item. Path is calculated\r
       as a concatenation of all parent nodes text strings, separated by\r
       given delimiter character. If Item is not specified ( =0 ), path is returned\r
       for Selected item. }\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
\r
    property TVItemRect[ Item: THandle; TextOnly: Boolean ]: TRect read TVGetItemRect;\r
    {* |<#treeview>\r
       Returns rectangle, occupied by an item in tree view. }\r
\r
    property TVItemVisible[ Item: THandle ]: Boolean read TVGetItemVisible write TVSetITemVisible;\r
    {* |<#treeview>\r
       Returs True, if item is visible in tree view. It is also possible to\r
       assign True to this property to ensure that a tree view item is visible\r
       (if False is assigned, this does nothing). }\r
    function TVItemAtPos( x, y: Integer; var Where: DWORD ): THandle;\r
    {* |<#treeview>\r
       Returns handle of item found at specified position (relative to upper left\r
       corener of client area of the tree view). If no item found, 0 is returned.\r
       Variable Where receives additional flags combination, describing more\r
       detailed, on which part of item or tree view given point is located,\r
       such as:\r
       |<pre>\r
       TVHT_ABOVE              Above the client area\r
       TVHT_BELOW              Below the client area\r
       TVHT_NOWHERE            In the client area, but below the last item\r
       TVHT_ONITEM             On the bitmap or label associated with an item\r
       TVHT_ONITEMBUTTON       On the button associated with an item\r
       TVHT_ONITEMICON         On the bitmap associated with an item\r
       TVHT_ONITEMINDENT       In the indentation associated with an item\r
       TVHT_ONITEMLABEL        On the label (string) associated with an item\r
       TVHT_ONITEMRIGHT        In the area to the right of an item\r
       TVHT_ONITEMSTATEICON    On the state icon for a tree-view item that is in a user-defined state\r
       TVHT_TOLEFT             To the right of the client area\r
       TVHT_TORIGHT            To the left of the client area\r
       |</pre> }\r
\r
    property TVRightClickSelect: Boolean read fTVRightClickSelect write SetTVRightClickSelect;\r
    {* |<#treeview>\r
       Set this property to True to allow change selection to an item, clicked with right mouse button. }\r
    property TVEditing: Boolean read fEditing;\r
    {* |<#treeview>\r
       Returns True, if tree view control is editing its item label. }\r
\r
    property TVItemBold[ Item: THandle ]: Boolean index TVIS_BOLD read TVGetItemStateFlg write TVSetItemStateFlg;\r
    {* |<#treeview>\r
       True, if item is bold. }\r
    property TVItemCut[ Item: THandle ]: Boolean index TVIS_CUT read TVGetITemStateFlg write TVSetItemStateFlg;\r
    {* |<#treeview>\r
       True, if item is selected as part of "cut and paste" operation. }\r
    property TVItemDropHighlighted[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg;\r
    {* |<#treeview>\r
       True, if item is selected as drop target. }\r
    property TVItemDropHilited[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg;\r
    {* The same as TVItemDropHighlighted. }\r
    property TVItemExpanded[ Item: THandle ]: Boolean index TVIS_EXPANDED read TVGetITemStateFlg; // write TVSetItemStateFlg;\r
    {* |<#treeview>\r
       True, if item's list of child items is currently expanded. To change\r
       expanded state, use method TVExpand. }\r
    property TVItemExpandedOnce[ Item: THandle ]: Boolean index TVIS_EXPANDEDONCE read TVGetITemStateFlg; // write TVSetItemStateFlg;\r
    {* |<#treeview>\r
       True, if item's list of child items has been expanded at least once. }\r
    property TVItemSelected[ Item: THandle ]: Boolean index TVIS_SELECTED read TVGetITemStateFlg write TVSetItemStateFlg;\r
    {* |<#treeview>\r
       True, if item is selected. }\r
\r
    procedure TVExpand( Item: THandle; Flags: DWORD );\r
    {* |<#treeview>\r
       Call it to expand/collapse item's child nodes. Possible values for Flags\r
       parameter are:\r
       <pre>\r
       TVE_COLLAPSE         Collapses the list.\r
       TVE_COLLAPSERESET    Collapses the list and removes the child items. Note\r
                            that TVE_COLLAPSE must also be specified.\r
       TVE_EXPAND           Expands the list.\r
       TVE_TOGGLE           Collapses the list if it is currently expanded or\r
                            expands it if it is currently collapsed.\r
       </pre>\r
       }\r
    procedure TVSort( N: THandle );\r
    {* |<#treeview>\r
       By Alex Mokrov. Sorts treeview. If N = 0, entire treeview is sorted.\r
       Otherwise, children of the given node only.\r
    }\r
\r
    property TVItemImage[ Item: THandle ]: Integer index TVIF_IMAGE read TVGetItemImage write TVSetItemImage;\r
    {* |<#treeview>\r
       Image index for an item of tree view. To tell that there are no image\r
       set, use index -2 (value -1 is reserved for callback image). }\r
    property TVItemSelImg[ Item: THandle ]: Integer index TVIF_SELECTEDIMAGE read TVGetItemImage write TVSetItemImage;\r
    {* |<#treeview>\r
       Image index for an item of tree view in selected state. Use value -2 to\r
       provide no image, -1 used for callback image. }\r
    property TVItemOverlay[ Item: THandle ]: Integer index TVIS_OVERLAYMASK or $80000\r
                             read TVGetItemImage write TVSetItemImage;\r
    {* |<#treeview>\r
       Overlay image index for an item in tree view. }\r
    property TVItemStateImg[ Item: THandle ]: Integer index TVIS_STATEIMAGEMASK or $C0000\r
                              read TVGetItemImage write TVSetItemImage;\r
    {* |<#treeview>\r
       State image index for an item in tree view. Use 1-based index of the image\r
       in image list ImageListState. Value 0 reserved to use as "no state image".\r
       Values 1..15 can be used only - this is the Windows restriction on\r
       state images. }\r
\r
    property TVItemData[ Item: THandle ]: Pointer read TVGetItemData write TVSetItemData;\r
    {* |<#treeview>\r
       Stores any program-defined pointer with the item. }\r
    procedure TVEditItem( Item: THandle );\r
    {* |<#treeview>\r
       Begins editing given item label in tree view. }\r
    procedure TVStopEdit( Cancel: Boolean );\r
    {* |<#treeview>\r
       Ends editing item label, started by user or explicitly by TVEditItem method. }\r
\r
    property OnTVBeginDrag: TOnTVBeginDrag read fOnTVBeginDrag write fOnTVBeginDrag;\r
    {* |<#treeview>\r
       Is called for tree view, when its item is to be dragging. }\r
    property OnTVBeginEdit: TOnTVBeginEdit read fOnTVBeginEdit write fOnTVBeginEdit;\r
    {* |<#treeview>\r
       Is called for tree view, when its item label is to be editing. }\r
    property OnTVEndEdit: TOnTVEndEdit read fOnTVEndEdit write fOnTVEndEdit;\r
    {* |<#treeview>\r
       Is called when item label is edited. It is possible to cancel\r
       edit, returning False as a result. }\r
    property OnTVExpanding: TOnTVExpanding read fOnTVExpanding write fOnTVExpanding;\r
    {* |<#treeview>\r
       Is called just before expanding/collapsing item. It is possible to\r
       return False to prevent expanding item. }\r
    property OnTVExpanded: TOnTVExpanded read fOnTVExpanded write fOnTVExpanded;\r
    {* |<#treeview>\r
       Is called after expanding/collapsing item children. }\r
    property OnTVDelete: TOnTVDelete read fOnTVDelete write SetOnTVDelete;\r
    {* |<#treeview>\r
       Is called just before deleting item. You may use this event to free\r
       resources, associated with an item (see TVItemData property). }\r
    //----------------- by Sergey Shisminzev:\r
    property OnTVSelChanging: TOnTVSelChanging read fOnTVSelChanging write fOnTVSelChanging;\r
    {* |<#treeview>\r
       Is called before changing the selection. The handler can return FALSE\r
       to prevent changing the selection. }\r
    //--------------------------------------\r
\r
    //======== Toolbar specific methods:\r
    procedure TBAddBitmap( Bitmap: HBitmap );\r
    {* |<#toolbar>\r
       Adds bitmaps to a toolbar. You can pass special values as Bitmap to\r
       add one of predefined system button images bitmaps:\r
       |<br> THandle(-1) to add standard small icons,\r
       |<br> THandle(-2) to add standard large icons,\r
       |<br> THandle(-5) to add standard small view icons,\r
       |<br> THandle(-6) to add standard large view icons,\r
       |<br> THandle(-9) to add standard small view icons,\r
       |<br> THandle(-10) to add standard large view icons,\r
       (in that case use following values as indexes to the standard and view\r
       bitmaps:\r
       |<br>\r
       STD_COPY, STD_CUT, STD_DELETE, STD_FILENEW, STD_FILEOPEN, STD_FILESAVE,\r
       STD_FIND, STD_HELP, STD_PASTE, STD_PRINT, STD_PRINTPRE, STD_PROPERTIES,\r
       STD_REDO, STD_REPLACE, STD_UNDO,\r
       |<br>\r
       VIEW_LARGEICONS, VIEW_SMALLICONS,\r
       VIEW_LIST, VIEW_DETAILS, VIEW_SORTNAME, VIEW_SORTSIZE, VIEW_SORTDATE,\r
       VIEW_SORTTYPE (use it as parameters BtnImgIdxArray in TBAddButtons or\r
       TBInsertButtons methods, and in assigning value to TBButtonImage[ ]\r
       property).\r
       Added bitmaps have indeces starting from previous count of images\r
       (as these are appended to existing - if any).\r
       |<br>\r
       Note, that if You add your own (custom) bitmap, it is not transparent.\r
       Do not assume that clSilver is always equal to clBtnFace. Use API\r
       function CreateMappedBitmap to load bitmap from resource and map\r
       desired colors as you wish (e.g., convert clTeal to clBtnFace). Or,\r
       call defined in KOL function LoadMappedBitmap to do the same more easy.\r
       Unfortunately, resource identifier for bitmap to pass it to LoadMappedBitmap\r
       or to CreateMappedBitmap seems must be integer, so it is necessary to\r
       create rc-file manually and compile using Borland Resource Compiler to\r
       figure it out. }\r
\r
\r
    function TBAddButtons( const Buttons: array of PChar; const BtnImgIdxArray: array\r
              of Integer ): Integer;\r
    {* |<#toolbar>\r
       Adds buttons to toolbar. Last string in Buttons array *must* be empty\r
       ('' or nil), so to add buttons without text, pass ' ' string (one space\r
       char). It is not necessary to provide image indexes for all\r
       buttons (it is sufficient to assign index for first button only).\r
       But in place, correspondent to separator button (defined by string '-'),\r
       any integer must be passed to assign follow image indexes correctly.\r
       See example.\r
       |*Toolbar adding buttons sample.\r
       Code below shows how to call TBAddButtons method to add two buttons with\r
       a separator between these buttons. idxNew and idxOld are integer\r
       expressions assigning image indexes to buttons 'New' and 'Old'. This\r
       indexes are zero-based and refer to bitmap images, added earlier (either\r
       in creating toolbar by call of NewToolbar or later in call of TBAddBitmap).\r
       !\r
       !     TBAddButtons( [ '&New', '-', '&Old', '' ], [ idxNew, 0, idxOld ] );\r
       !\r
       |*\r
       To add check buttons, use prefix '+' or '-' in button definition\r
       string. If next character is '!', such buttons are grouped to a\r
       radio-group. Also, it is possible to use '^' prefix (must be first) to\r
       define button with small drop-down section (use also OnTBDropDown event\r
       to respond to clicking drop down section of such buttons).\r
       |<br>\r
       This function returns command id for first added button (other\r
       id's can be calculated incrementing the result by one for each\r
       button, except separators, which have no command id).\r
       |<br>\r
       Note: for static toolbar (single in application and created\r
       once) ids are started from value 100. }\r
\r
    function TBInsertButtons( BeforeIdx: Integer; Buttons: array of PChar;\r
             BtnImgIdxArray: array of Integer ): Integer;\r
    {* |<#toolbar>\r
       Inserts buttons before button with given index on toolbar. Returns\r
       command identifier for first button inserted (other can be calculated\r
       incrementing returned value needed times. See also TBAddButtons. }\r
\r
    procedure TBDeleteButton( BtnID: Integer );\r
    {* |<#toolbar>\r
       Deletes single button given by its command id. To delete separator,\r
       use TBDeleteBtnByIdx instead. }\r
\r
    procedure TBDeleteBtnByIdx( Idx: Integer );\r
    {* |<#toolbar>\r
       Deletes single button given by its index in toolbar (not by command ID). }\r
\r
    procedure TBAssignEvents( BtnID: Integer; Events: array of TOnToolbarButtonClick );\r
    {* |<#toolbar>\r
       Allows to assign separate OnClick events for every toolbar button.\r
       BtnID should be toolbar button ID or index of the first button to\r
       assign event. If it is an ID, events are assigned to buttons in\r
       creation order. Otherwise, events are assigned in placement order.\r
       Anyway, separator buttons are not skipped, so pass at least nil for such\r
       button as an event.\r
       |<br>\r
       Please note, that though not all buttons should exist before\r
       assigning events to it, therefore at least the first button\r
       (specified by BtnID) must be already added before calling TBAssignEvents. }\r
\r
    procedure TBResetImgIdx( BtnID, BtnCount: Integer );\r
    {* |<#toolbar>\r
       Resets image index for BtnCount buttons starting from BtnID. }\r
\r
    property CurItem: Integer read fCurItem;\r
    {* |<#toolbar>\r
       For toolbar, in OnClick event this property can be used to determine\r
       which button was clicked (100-based button id in toolbar). It is also\r
       possible to use CurIndex property (zero-based) for this purpose as\r
       well, but do not assume, that CurItem always equal to CurIndex+100.\r
       At least, it is possible to call TBItem2Index function to convert\r
       button ID to its index in toolbar.\r
       |<br>\r
       In case, when button (or toolbar itself) is clicked using right\r
       mouse button, CurItem and CurIndex are always set to -1. To further\r
       determine which button was clicked, get mouse coordinates on screen,\r
       apply Screen2Client method of toolbar control to it and then use\r
       TBButtonAtPos function to determine which button was under cursor.\r
    }\r
\r
    property TBButtonCount: Integer read GetItemsCount; //TBGetButtonCount;\r
    {* |<#toolbar>\r
       Returns count of buttons on toolbar. The same as Count. }\r
\r
    property TBBtnImgWidth: Integer read fTBBtnImgWidth write fTBBtnImgWidth;\r
    {* |<#toolbar>\r
       Custom toolbar buttons width. Set it before assigning buttons bitmap.\r
       Changing this property after assigning the bitmap has no effect. }\r
\r
    function TBItem2Index( BtnID: Integer ): Integer;\r
    {* |<#toolbar>\r
       Converts button command id to button index for tool bar. }\r
\r
    function TBIndex2Item( Idx: Integer ): Integer;\r
    {* |<#toolbar>\r
       Converts toolbar button index to its command ID. }\r
\r
    property TBButtonEnabled[ BtnID: Integer ]: Boolean index TB_ENABLEBUTTON\r
             read TBGetBtnStt write TBSetBtnStt;\r
    {* |<#toolbar>\r
       Obvious. }\r
\r
    property TBButtonVisible[ BtnID: Integer ]: Boolean read TBGetButtonVisible\r
                              write TBSetButtonVisible;\r
    {* |<#toolbar>\r
       Allows to hide/show some of toolbar buttons. }\r
\r
    property TBButtonChecked[ BtnID: Integer ]: Boolean index TB_CHECKBUTTON\r
             read TBGetBtnStt write TBSetBtnStt;\r
    {* |<#toolbar>\r
       Allows to determine 'checked' state of a button (e.g., radio-button),\r
       and to check it programmatically. }\r
\r
    property TBButtonMarked[ BtnID: Integer ]: Boolean index TB_MARKBUTTON\r
             read TBGetBtnStt write TBSetBtnStt;\r
    {* |<#toolbar>\r
       Returns True if toolbar button is marked (highlighted). Allows to\r
       highlight buttons assigning True to this value. }\r
\r
    property TBButtonPressed[ BtnID: Integer ]: Boolean index TB_PRESSBUTTON\r
             read TBGetBtnStt write TBSetBtnStt;\r
    {* |<#toolbar>\r
       Allows to detrmine if toolbar button (given by its command ID) pressed,\r
       and press/unpress it programmatically. }\r
\r
    property TBButtonText[ BtnID: Integer ]: String read TBGetButtonText write TBSetButtonText;\r
    {* |<#toolbar>\r
       Obtains toolbar button text and allows to change it. Be sure that text\r
       is not empty for all buttons, if You want for it to be shown (if at least\r
       one button has empty text, no text labels will be shown at all). At\r
       least set it to ' ' for buttons, which You do not want to show labels,\r
       if You want from other ones to have it. }\r
\r
    property TBButtonImage[ BtnID: Integer ]: Integer read TBGetBtnImgIdx write TBSetBtnImgIdx;\r
    {* |<#toolbar>\r
       Allows to access/change button image. }\r
\r
    property TBButtonRect[ BtnID: Integer ]: TRect read TBGetButtonRect;\r
    {* |<#toolbar>\r
       Obtains rectangle occupied by toolbar button in toolbar window.\r
       (It is not possible to obtain rectangle for buttons, currently\r
       not visible). }\r
\r
    property TBButtonWidth[ BtnID: Integer ]: Integer read TBGetBtnWidth write TBSetBtnWidth;\r
    {* |<#toolbar>\r
       Allows to obtain / change toolbar button width. }\r
\r
    property TBButtonsMinWidth: Integer index 0\r
             {$IFDEF F_P}   read TBGetBtMinMaxWidth\r
             {$ELSE DELPHI} read FTBBtMinWidth\r
             {$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth;\r
    {* |<#toolbar>\r
       Allows to set minimal width for all toolbar buttons. }\r
    property TBButtonsMaxWidth: Integer index 1\r
             {$IFDEF F_P}   read TBGetBtMinMaxWidth\r
             {$ELSE DELPHI} read FTBBtMaxWidth\r
             {$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth;\r
    {* |<#toolbar>\r
       Allows to set maximal width for all toolbar buttons. }\r
\r
    function TBButtonAtPos( X, Y: Integer ): Integer;\r
    {* |<#toolbar>\r
       Returns command ID of button at the given position on toolbar,\r
       or -1, if there are no button at the position. Value 0 is returned\r
       for separators. }\r
\r
    function TBBtnIdxAtPos( X, Y: Integer ): Integer;\r
    {* |<#toolbar>\r
       Returns index of button at the given position on toolbar.\r
       This also can be index of separator button. -1 is returned if\r
       there are no buttons found at the position. }\r
\r
    property TBRows: Integer read TBGetRows write TBSetRows;\r
    {* |<#toolbar>\r
       Returns number of rows for toolbar and allows to try to set\r
       desired number of rows (but system can set another number of\r
       rows in some cases). This property has no effect if tboWrapable\r
       style not present in Options when toolbar is created. }\r
\r
    procedure TBSetTooltips( BtnID1st: Integer; Tooltips: array of PChar );\r
    {* |<#toolbar>\r
       Allows to assign tooltips to several buttons. Until this procedure\r
       is not called, tooltips list is not created and no code is added\r
       to executable. This method of tooltips maintainance for toolbar buttons\r
       is useful both for static and dynamic toolbars (meaning "dynamic" -\r
       toolbars with buttons, deleted and inserted at run-time). }\r
\r
    property OnTBDropDown: TOnEvent read fOnDropDown write fOnDropDown;\r
    {* |<#toolbar>\r
       This event is called for drop down buttons, when user click drop part\r
       of drop down button. To determine for which button event is called,\r
       look at CurItem or CurIndex property. It is also possible to use\r
       common (with combobox) property OnDropDown. }\r
\r
    property OnTBClick: TOnEvent read fOnClick write fOnClick;\r
    {* |<#toolbar>\r
       The same as OnClick. }\r
\r
    //================== RichEdit specific: ==================\r
\r
    property MaxTextSize: DWORD read GetMaxTextSize write SetMaxTextSize;\r
    {* |<#richedit>\r
       This property valid also for simple edit control, not only for RichEdit.\r
       But for usual edit control, maximum text size available is 32K. For\r
       RichEdit, limit is 4Gb. By default, RichEdit is limited to\r
       32767 bytes (to set maximum size available to 2Gb, assign MaxInt value\r
       to a property). Also, to get current text size of RichEdit, use property\r
       TextSize or RE_TextSize[ ]. }\r
    property TextSize: Integer read GetTextSize;\r
    {* |<#richedit>\r
       Common for edit and rich edit controls property, which returns size of\r
       text in edit control. Also, for any other control (or form, or applet\r
       window) returns size (in characters) of Caption or Text (what is, the\r
       same property actually). }\r
    property RE_TextSize[ Units: TRichTextSize ]: Integer read REGetTextSize;\r
    {* |<#richedit>\r
       For RichEdit control, it returns text size, measured in desired units\r
       (rtsChars - characters, including OLE objects, counted as a single\r
       character; rtsBytes - presize length of text image (if it would be stored\r
       in file or stream). Please note, that for RichEdit1.0, only size in\r
       characters can be obtained. }\r
    function RE_TextSizePrecise: Integer;\r
    {* |<#richedit>\r
       By Savva. Returns length of rich edit text. }\r
\r
    property RE_CharFmtArea: TRichFmtArea read fRECharArea write fRECharArea;\r
    {* |<#richedit>\r
       By default, this property is raSelection. Changing it, You determine in\r
       for which area characters format is applyed, when changing\r
       character formatting properties below (not paragraph formatting).\r
       |&A=<a href=#RE_CharFmtArea target=main>%0</a>\r
    }\r
    property RE_CharFormat: TCharFormat read REGetCharformat write RESetCharFormat;\r
    {* |<#richedit>\r
       In differ to follow properties, which allow to control certain formatting\r
       attributes, this property provides low level access for formatting current\r
       character area (see RE_CharFmtArea). It returns TCharFormat structure,\r
       filled in with formatting attributes, and by assigning another value to\r
       this property You can change desired attributes as You wish. Even if\r
       RichEdit1.0 is used, TCharFormat2 is returned (but extended fields are\r
       ignored for RichEdit1.0). }\r
    property RE_Font: PGraphicTool read REGetFont write RESetFont;\r
    {* |<#richedit>\r
       Font of the first character in current selection (when retrieve).\r
       When set (or subproperties of RE_Font are set), all font attributes are\r
       applied to entire <A area>. To apply only needed attributes, use another\r
       properties: RE_FmtBold, RE_FmtItalic, RE_FmtStrikeout, RE_FmtUnderline,\r
       RE_FmtName, etc.\r
       |<br>\r
       Note, that font size is measured in twips, which is about 1/10 of pixel. }\r
    property RE_FmtBold: Boolean index CFM_BOLD read REGetFontEffects write RESetFontEffect;\r
    {* |<#richedit>\r
       Formatting flag. When retrieve, returns True, if fsBold style RE_Font.FontStyle\r
       is valid for a first character in the selection. When set, changes fsBold\r
       style (True - set, False - reset) for all characters in <A area>. }\r
    property RE_FmtBoldValid: Boolean index CFM_BOLD read REGetFontMask;\r
    {* }\r
    property RE_FmtItalic: Boolean index CFM_ITALIC read REGetFontEffects write RESetFontEffect;\r
    {* |<#richedit>\r
       Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsItalic\r
       style valid for the first character of the selection, and when set, changes\r
       only fsItalic style for an <A area>. }\r
    property RE_FmtItalicValid: Boolean index CFM_ITALIC read REGetFontMask;\r
    {* }\r
    property RE_FmtStrikeout: Boolean index CFM_STRIKEOUT read REGetFontEffects write RESetFontEffect;\r
    {* |<#richedit>\r
       Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsStrikeout\r
       style valid for the first selected character, and when set, changes only\r
       fsStrikeout style for an <A area>. }\r
    property RE_FmtStrikeoutValid: Boolean index CFM_STRIKEOUT read REGetFontMask;\r
    {* }\r
    property RE_FmtUnderline: Boolean index CFM_UNDERLINE read REGetFontEffects write RESetFontEffect;\r
    {* |<#richedit>\r
       Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsUnderline\r
       style valid for the first selected character, and when set, changes\r
       fsUnderline style for an <A area>. }\r
    property RE_FmtUnderlineValid: Boolean index CFM_UNDERLINE read REGetFontMask;\r
    {* }\r
    property RE_FmtUnderlineStyle: TRichUnderline\r
             read REGetUnderlineEx write RESetUnderlineEx;\r
    {* |<#richedit>\r
       Extended underline style. To check, if this property is valid for\r
       entire selection, examine RE_FmtUnderlineValid value. }\r
    property RE_FmtProtected: Boolean index CFM_PROTECTED read REGetFontEffects write RESetFontEffect;\r
    {* |<#richedit>\r
       Formatting flag. When retrieving, shows, is the first character of the selection\r
       is protected from changing it by user (True) or not (False). To get know,\r
       if retrived value is valid for entire selection, check the property\r
       RE_FmtProtectedValid. When set, makes all characters in <A area> protected (\r
       True) or not (False). }\r
    property RE_FmtProtectedValid: Boolean index CFM_PROTECTED read REGetFontMask;\r
    {* |<#richedit>\r
       True, if property RE_FmtProtected is valid for entire selection, when\r
       retrieving it. }\r
    property RE_FmtHidden: Boolean index CFM_HIDDEN read REGetFontEffects write RESetFontEffect;\r
    {* |<#richedit>\r
       For RichEdit3.0, makes text hidden (not displayed). }\r
    property RE_FmtHiddenValid: Boolean index CFM_HIDDEN read REGetFontMask;\r
    {* |<#richedit>\r
       Returns True, if RE_FmtHidden style is valid for entire selection. }\r
\r
    property RE_FmtLink: Boolean index $20 {CFM_LINK} read REGetFontEffects write RESetFontEffect;\r
    {* |<#richedit>\r
       Returns True, if the first selected character is a part of link (URL). }\r
       // by Sergey Shisminzev\r
\r
    property RE_FmtLinkValid: Boolean index $20 {CFM_LINK} read REGetFontMask;\r
    {* }\r
    property RE_FmtFontSize: Integer index (12 shl 16) or CFM_SIZE read REGetFontAttr write RESetFontAttr;\r
    {* |<#richedit>\r
       Formatting value: font size, in twips (1/1440 of an inch, or 1/20 of a\r
       printer's point, or about 1/10 of pixel). When retrieving, returns\r
       RE_Font.FontHeight.\r
       When set, changes font size for entire <A area> (but does not change\r
       other font attributes). }\r
    property RE_FmtFontSizeValid: Boolean read REGetFontSizeValid;\r
    {* |<#richedit>\r
       Returns True, if property RE_FmtFontSize is valid for entire selection,\r
       when retrieving it. }\r
    //property RE_FmtBackColor: Integer index (62 shl 16) or CFM_BACKCOLOR read REGetFontAttr write RESetFontAttr1;\r
    {* |<#richedit>\r
       Background color for an <A area>. }\r
    //property RE_FmtBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontEffect;\r
    {* |<#richedit>\r
       True, if RE_FmtBackColor valid for entire <A area>. }\r
    property RE_FmtAutoBackColor: Boolean index CFM_BACKCOLOR read REGetFontEffects write RESetFontEffect;\r
    {* |<#richedit>\r
       True, when automatic back color is used. }\r
    property RE_FmtAutoBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask;\r
    {* }\r
    property RE_FmtFontColor: Integer index (20 shl 16) or CFM_COLOR read REGetFontAttr write RESetFontAttr1;\r
    {* |<#richedit>\r
       Formatting value (font color). When retrieving, returns RE_Font.Color.\r
       When set, changes font color for entire <A area> (but does not change\r
       other font attributes). }\r
    property RE_FmtFontColorValid: Boolean index CFM_COLOR read REGetFontMask;\r
    {* |<#richedit>\r
       Returns True, if property RE_FmtFontColor valid for entire selection,\r
       when retrieving it. }\r
    property RE_FmtAutoColor: Boolean index CFM_COLOR read REGetFontEffects write RESetFontEffect;\r
    {* |<#richedit>\r
       True, when automatic text color is used (in such case, RE_FmtFontColor\r
       assignment is ignored for current area). }\r
    property RE_FmtAutoColorValid: Boolean index CFM_COLOR read REGetFontMask;\r
    {* }\r
    property RE_FmtBackColor: Integer index (64 shl 16) or CFM_BACKCOLOR read REGetFontAttr write RESetFontAttr1;\r
    {* |<#richedit>\r
       Formatting value (back color). Only available for Rich Edit 2.0 and higher.\r
       When set, changes background color for entire <A area> (but does not change\r
       other font attributes). }\r
    property RE_FmtBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask;\r
    {* }\r
    property RE_FmtFontOffset: Integer index (16 shl 16) or CFM_OFFSET read REGetFontAttr write RESetFontAttr;\r
    {* |<#richedit>\r
       Formatting value (font vertical offset from baseline, positive values\r
       correspond to subscript). When retrieving, returns offset for first\r
       character in the selection. When set, changes font offset for entire\r
       <A area>. To get know, is retrieved value valid for entire selction,\r
       check RE_FmtFontOffsetValid property. }\r
    property RE_FmtFontOffsetValid: Boolean index CFM_OFFSET read REGetFontMask;\r
    {* |<#richedit>\r
       Returns True, if property RE_FmtFontOffset is valid for entire selection,\r
       when retrieving it. }\r
    property RE_FmtFontCharset: Integer index (25 shl 16) or CFM_CHARSET read REGetFontAttr write RESetFontAttr;\r
    {* |<#richedit>\r
       Returns charset for first character in current selection, when retrieved\r
       (and to get know, if this value is valid for entire selection, check\r
       property RE_FmtFontCharsetValid). When set, changes charset for all\r
       characters in <A area>, but does not alter other formatting attributes. }\r
    property RE_FmtFontCharsetValid: Boolean index CFM_CHARSET read REGetFontMask;\r
    {* |<#richedit>\r
       Returns True, only if rerieved property RE_FmtFontCharset is valid for\r
       entire selection. }\r
    property RE_FmtFontName: String read REGetFontName write RESetFontName;\r
    {* |<#richedit>\r
       Returns font face name for first character in the selection, when retrieved,\r
       and sets font name for entire <A area>, wnen assigned to (without\r
       changing of other formatting attributes). To get know, if retrived\r
       font name valid for entire selection, examine property RE_FmtFontNameValid. }\r
    property RE_FmtFontNameValid: Boolean index CFM_FACE read REGetFontMask;\r
    {* |<#richedit>\r
       Returns True, only if the font name is the same for entire selection,\r
       thus is, if rerieved property value RE_FmtFontName is valid for entire\r
       selection. }\r
\r
    property RE_ParaFmt: TParaFormat read REGetParaFmt write RESetParaFmt;\r
    {* |<#richedit>\r
       Allows to retrieve or set paragraph formatting attributes for currently\r
       selected paragraph(s) in RichEdit control. See also following properties,\r
       which allow to do the same for certain paragraph format attributes\r
       separately. }\r
    property RE_TextAlign: TRichTextAlign read REGetTextAlign write RESetTextAlign;\r
    {* |<#richedit>\r
       Returns text alignment for current selection and allows to change it\r
       (without changing other formatting attributes). }\r
    property RE_TextAlignValid: Boolean index PFM_ALIGNMENT read REGetParaAttrValid;\r
    {* |<#richedit>\r
       Returns True, if property RE_TextAlign is valid for entire selection. If\r
       False, it is concerning only start of selection. }\r
    property RE_Numbering: Boolean read REGetNumbering write RESetNumbering;\r
    {* |<#richedit>\r
       Returns True, if selected text is numbered (or has style of list with\r
       bullets). To get / change numbering style, see properties\r
       RE_NumStyle and RE_NumBrackets. }\r
    property RE_NumStyle: TRichNumbering read REGetNumStyle write RESetNumStyle;\r
    {* |<#richedit>\r
       Advanced numbering style, such as rnArabic etc. If You use it, do not\r
       change RE_Numbering property simultaneously - this can cause changing\r
       style to rnBullets only. }\r
    property RE_NumStart: Integer read REGetNumStart write RESetNumStart;\r
    {* |<#richedit>\r
       Starting number for advanced numbering style. If this property is not\r
       set, numbering is starting by default from 0. For rnLRoman and rnURoman\r
       this cause, that first item has no number to be shown (ancient Roman\r
       people did not invent '0'). }\r
    property RE_NumBrackets: TRichNumBrackets read REGetNumBrackets write RESetNumBrackets;\r
    {* |<#richedit>\r
       Brackets style for advanced numbering. rnbPlain is default\r
       brackets style, and every time, when RE_NumStyle is changed,\r
       RE_NumBrackets is reset to rnbPlain. }\r
    property RE_NumTab: Integer read REGetNumTab write RESetNumTab;\r
    {* |<#richedit>\r
       Tab between start of number and start of paragraph text. If too small too\r
       view number, number is not displayed. (Default value seems to be sufficient\r
       though). }\r
    property RE_NumberingValid: Boolean index PFM_NUMBERING read REGetParaAttrValid;\r
    {* |<#richedit>\r
       Returns True, if RE_Numbering, RE_NumStyle, RE_NumBrackets, RE_NumTab,\r
       RE_NumStart properties are valid for entire selection. }\r
    property RE_Level: Integer read REGetLevel;\r
    {* |<#richedit>\r
       Outline level (for numbering paragraphs?). Read only. }\r
    property RE_SpaceBefore: Integer index 0 or PFM_SPACEBEFORE read REGetSpacing write RESetSpacing;\r
    {* |<#richedit>\r
       Spacing before paragraph. }\r
    property RE_SpaceBeforeValid: Boolean index PFM_SPACEBEFORE read REGetParaAttrValid;\r
    {* |<#richedit>\r
       True, if RE_SpaceBefore value is valid for all selected paragraph (if\r
       False, this value is valid only for first paragraph. }\r
    property RE_SpaceAfter: Integer index 4 or PFM_SPACEAFTER read REGetSpacing write RESetSpacing;\r
    {* |<#richedit>\r
       Spacing after paragraph. }\r
    property RE_SpaceAfterValid: Boolean index PFM_SPACEAFTER read REGetParaAttrValid;\r
    {* |<#richedit>\r
       True, only if RE_SpaceAfter value is valid for all selected paragraphs. }\r
    property RE_LineSpacing: Integer index 8 or PFM_LINESPACING read REGetSpacing write RESetSpacing;\r
    {* |<#richedit>\r
       Linespacing in paragraph (this value is based on RE_SpacingRule property). }\r
    property RE_SpacingRule: Integer read REGetSpacingRule write RESetSpacingRule;\r
    {* |<#richedit>\r
       Linespacing rule. Do not know what is it. }\r
    property RE_LineSpacingValid: Boolean index PFM_LINESPACING read REGetParaAttrValid;\r
    {* |<#richedit>\r
       True, only if RE_LineSpacing and RE_SpacingRule values are valid for\r
       entire selection. }\r
    property RE_Indent: Integer index (20 shl 16) or PFM_OFFSET read REGetParaAttr write RESetParaAttr;\r
    {* |<#richedit>\r
       Returns left indentation for paragraph in current selection and allows\r
       to change it (without changing other formatting attributes). }\r
    property RE_IndentValid: Boolean index PFM_OFFSET read REGetParaAttrValid;\r
    {* |<#richedit>\r
       Returns True, if RE_Indent property is valid for entire selection. }\r
    property RE_StartIndent: Integer index (12 shl 16) or PFM_OFFSETINDENT read REGetParaAttr write RESetParaAttr;\r
    {* |<#richedit>\r
       Returns left indentation for first line in paragraph for current\r
       selection, and allows to change it (without changing other formatting\r
       attributes). }\r
    property RE_StartIndentValid: Boolean read REGetStartIndentValid;\r
    {* |<#richedit>\r
       Returns True, if property RE_StartIndent is valid for entire selection. }\r
    property RE_RightIndent: Integer index (16 shl 16) or PFM_RIGHTINDENT read REGetParaAttr write RESetParaAttr;\r
    {* |<#richedit>\r
       Returns right indent for paragraph in current selection, and allow to\r
       change it (without changing other formatting attributes). }\r
    property RE_RightIndentValid: Boolean index PFM_RIGHTINDENT read REGetParaAttrValid;\r
    {* |<#richedit>\r
       Returns True, if property RE_RightIndent is valid for entire selection only. }\r
    property RE_TabCount: Integer read REGetTabCount write RESetTabCount;\r
    {* |<#richedit>\r
       Number of tab stops in current selection. This value can not be set greater\r
       then MAX_TAB_COUNT (32). }\r
    property RE_Tabs[ Idx: Integer ]: Integer read REGetTabs write RESetTabs;\r
    {* |<#richedit>\r
       Tab stops for RichEdit control. }\r
    property RE_TabsValid: Boolean index PFM_TABSTOPS read REGetParaAttrValid;\r
    {* |<#richedit>\r
       Returns True, if properties RE_Tabs[ ] and RE_TabCount are valid for\r
       entire selection. }\r
\r
\r
    // following does not work now :\r
    property RE_BorderWidth[ Side: TBorderEdge ]: Integer index 2 read REGetBorder write RESetBorder;\r
    { * |<#richedit>\r
       Border width. }\r
    property RE_BorderSpace[ Side: TBorderEdge ]: Integer index 0 read REGetBorder write RESetBorder;\r
    { * |<#richedit>\r
       Border space. }\r
    property RE_BorderStyle[ Side: TBorderEdge ]: Integer index 4 read REGetBorder write RESetBorder;\r
    { * |<#richedit>\r
       Border style. }\r
    property RE_BorderValid: Boolean index PFM_BORDER read REGetParaAttrValid;\r
    { * |<#richedit>\r
       Returns True, if border style, space and width are the same for all\r
       paragraphs in selection. }\r
    property RE_Table: Boolean index $C000 read REGetParaEffect write RESetParaEffect;\r
    { * |<#richedit>\r
       True, if current paragraph is a part of table (row, cell or cell end).\r
       seems working as read only property. }\r
    // end of experiment section\r
\r
    function RE_FmtStandard: PControl;\r
    {* |<#richedit>\r
       "Transparent" method (returns @Self as a result), which (when called)\r
       provides "standard" keyboard interface for formatting Rich text (just\r
       call this method, for example:\r
       !    RichEd1 := NewRichEdit( Panel1, [ ] ).SetAlign( caClient ).RE_FmtStandard;\r
       Following keys will be maintained additionally:\r
       |<pre>\r
       CTRL+I - switch "Italic",\r
       CTRL+B - switch "Bold",\r
       CTRL+U - switch "Underline",\r
       CTRL+SHIFT+U - swith underline type\r
                    and turn underline on (note, that some of underline styles\r
                    can not be shown properly in RichEdit v2.0 and lower,\r
                    though RichEdit2.0 stores data successfully).\r
       CTRL+O - switch "StrikeOut",\r
       CTRL+'gray+' - increase font size,\r
       CTRL+'gray-' - decrease font size,\r
       CTRL+SHIFT+'gray+' - superscript,\r
       CTRL+SHIFT+'gray-' - subscript.\r
       CTRL+SHIFT+Z - ReDo\r
       |</pre>\r
       And, though following standard formatting keys are provided by RichEdit\r
       control itself in Windows2000, some of these are not functioning\r
       automatically in earlier Windows versions, even for RichEdit2.0. So,\r
       functionality of some of these (marked with (*) ) are added here too:\r
       |<pre>\r
       CTRL+L - align paragraph left,           (*)\r
       CTRL+R - align paragraph right,          (*)\r
       CTRL+E - align paragraph center,         (*)\r
       CTRL+A - select all,                     (*)\r
       double-click on word - select word,\r
       CTRL+Right - to next word,\r
       CTRL+Left - to previous word,\r
       CTRL+Home - to the beginning of text,\r
       CTRL+End - to the end of text.\r
       CTRL+Z - UnDo\r
       |</pre>\r
       If You originally assign some (plain) text to Text property, switching "underline"\r
       can also change other font attributes, e.g., "bold" - if fsBold style is\r
       in default Font. To prevent such behavior, select entire text first (see\r
       SelectAll) and make assignment to RE_Font property, e.g.:\r
       !        RichEd1.SelectAll;\r
       !        RichEd1.RE_Font := RichEd1.RE_Font;\r
       !        RichEd1.SelLength := 0;\r
       |<br>\r
       And, some other notices about formatting. Please remember, that only True\r
       Type fonts can be succefully scaled and transformed to get desired effects\r
       (e.g., bold). By default, RichEdit uses System font face name, which can\r
       even have problems with fsBold style. Please remember also, that assigning\r
       RE_Font to RE_Font just initializying formatting attributes, making all\r
       those valid in entire text, but does not change font attributes. To use\r
       True Type font, directly assign face name You wish, e.g.:\r
       !        RichEd1.SelectAll;\r
       !        RichEd1.RE_Font := RichEd1.RE_Font;\r
       !        RichEd1.RE_Font.FontName := 'Arial';\r
       !        RichEd1.SelLength := 0;\r
    }\r
    property RE_AutoKeyboard: Boolean index 1 read REGetLangOptions write RESetLangOptions;\r
    {* |<#richedit>\r
       True if autokeyboard on (lovely "feature" of automatic switching keyboard\r
       language when caret is over another language text). For older RichEdit,\r
       is 'on' always, for newest - 'off' by default. }\r
\r
    property RE_OverwriteMode: Boolean read REGetOverwite write RESetOverwrite;\r
    {* |<#richedit>\r
       This property allows to control insert/overwrite mode. First, to examine, if\r
       insert or overwrite mode is current (but it is necessary either to\r
       access this property, at least once, immediately after creating RichEdit\r
       control, or to assign event OnRE_InsOvrMode_Change to your handler).\r
       Second, to set desired mode programmatically - by assigning value to\r
       this property (You also have to initialize monitoring procedure by either\r
       reading RE_OverwriteMode property or assigning handler to event\r
       OnRE_InsOvrMode_Change immediately following RichEdit control creation). }\r
    property OnRE_InsOvrMode_Change: TOnEvent read fOnREInsModeChg write fOnREInsModeChg;\r
    {* |<#richedit>\r
       This event is called, whenever key INSERT is pressed in control (and for\r
       RichEdit, this means, that insert mode is changed). }\r
    property RE_DisableOverwriteChange: Boolean read fReOvrDisable write RESetOvrDisable;\r
    {* |<#richedit>\r
       It is possible to disable switching between "insert" and "overwrite" mode\r
       by user (therefore, event OnRE_InsOvrMode_Change continue works, but it\r
       just called when key INSERT is pressed, though RE_OverwriteMode property\r
       is not actually changed if switching is disabled). }\r
\r
    function RE_LoadFromStream( Stream: PStream; Length: Integer;\r
                                Format: TRETextFormat; SelectionOnly: Boolean ): Boolean;\r
    {* |<#richedit>\r
       Use this method rather then assignment to RE_Text property, if\r
       source is stored in file or stream (to minimize resources during\r
       loading of RichEdit content). Data is loading starting from current\r
       position in stream and no more then Length bytes are loaded (use -1\r
       value to load to the end of stream). Loaded data replaces entire\r
       content of RichEdit control, or selection only, depending on SelectionOnly\r
       flag.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       If You want to provide progress (e.g. in form of progress bar), assign\r
       OnProgress event to your handler - and to examine current position of\r
       loading, read TSream.Position property of soiurce stream). }\r
    function RE_SaveToStream( Stream: PStream; Format: TRETextFormat; SelectionOnly: Boolean ): Boolean;\r
    {* |<#richedit>\r
       Use this method rather then RE_TextProperty to store data to file\r
       or stream (to minimize resources during saving of RichEdit content).\r
       Data is saving starting from current position in a stream (until\r
       end of RichEdit data). If SelectionOnly flag is True, only selected\r
       part of RichEdit text is saved.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       Like for RE_LoadFromStream, it is possible to assign your method to\r
       OnProgress event (but to calculate progress of save-to-stream operation,\r
       compare current stream position with RE_Size[ rsBytes ] property\r
       value). }\r
\r
    property OnProgress: TOnEvent read fOnProgress write fOnProgress;\r
    {* |<#richedit>\r
       This event is called during RE_SaveToStream, RE_LoadFromStream (and also\r
       during RE_SaveToFile, RE_LoadFromFile and while accessing or changing\r
       RE_Text property). To calculate relative progress, it is possible to\r
       examine current position in stream/file with its total size while reading,\r
       or with rich edit text size, while writing (property RE_TextSize[ rsBytes ]).\r
    }\r
    function RE_LoadFromFile( const Filename: String; Format: TRETextFormat;\r
             SelectionOnly: Boolean ): Boolean;\r
    {* |<#richedit>\r
       Use this method rather then other assignments to RE_Text property,\r
       if a source for RichEdit is the file. See also RE_LoadFromStream. }\r
    function RE_SaveToFile( const Filename: String; Format: TRETextFormat;\r
             SelectionOnly: Boolean ): Boolean;\r
    {* |<#richedit>\r
       Use this method rather then other similar, if You want to store\r
       entire content of RichEdit or selection only of RichEdit to a file. }\r
\r
    property RE_Text[ Format: TRETextFormat; SelectionOnly: Boolean ]: String read REReadText write REWriteText;\r
    {* |<#richedit>\r
       This property allows to get / replace content of RichEdit control\r
       (entire text or selection only). Using different formats, it is\r
       possible to exclude or replace undesired formatting information\r
       (see TRETextFormat specification). To get or replace entire text\r
       in reText mode (plain text only), it is possible to use habitual\r
       for edit controls Text property.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       Note: it is possible to append text to the end of RichEdit control\r
       using method Add, but only if property RE_Text is accessed at least\r
       once:\r
       !               RichEdit1.RE_Text[ reText, True ];\r
       (This line can be written immediatelly after creating RichEdit control). }\r
\r
    procedure RE_Append( const S: String; ACanUndo: Boolean );\r
    {* }\r
    procedure RE_InsertRTF( const S: String );\r
    {* }\r
    property RE_Error: Integer read fREError;\r
    {* |<#richedit>\r
       Contains error code, if access to RE_Text failed. }\r
\r
    procedure RE_HideSelection( aHide: Boolean );\r
    {* |<#richedit>\r
       Allows to hide / show selection in RichEdit. }\r
\r
    function RE_SearchText( const Value: String; MatchCase, WholeWord, ScanForward: Boolean;\r
                            SearchFrom, SearchTo: Integer ): Integer;\r
    {* |<#richedit>\r
       Searches given string starting from SearchFrom position up to SearchTo\r
       position (to the end of text, if SearchTo is -1). Returns zero-based\r
       character position of the next match, or -1 if there are no more matches.\r
       To search in bacward direction, set ScanForward to False, and pass\r
       SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). }\r
\r
    property RE_AutoURLDetect: Boolean read REGetAutoURLDetect write RESetAutoURLDetect;\r
    {* |<#richedit>\r
       If set to True, automatically detects URLs (and highlights it with\r
       blue color, applying fsItalic and fsUnderline font styles (while\r
       typing and loading). Default value is False. Note: if event OnRE_URLClick\r
       or event OnRE_OverURL are set, property RE_AutoURLDetect is set to True\r
       automatically. }\r
\r
    property RE_URL: String read fREUrl;\r
    {* |<#richedit>\r
       Detected URL (valid in OnRE_OverURL and OnRE_URLClick event handlers). }\r
    property OnRE_OverURL: TOnEvent index 0\r
             {$IFDEF F_P}   read REGetOnURL\r
             {$ELSE DELPHI} read fOnREOverURL\r
             {$ENDIF F_P/DELPHI} write RESetOnURL;\r
    {* |<#richedit>\r
       Is called when mouse is moving over URL. This can be used to set\r
       cursor, for example, depending on type of URL (to determine URL type\r
       read property RE_URL). }\r
    property OnRE_URLClick: TOnEvent index 8\r
             {$IFDEF F_P}   read REGetOnURL\r
             {$ELSE DELPHI} read fOnREURLClick\r
             {$ENDIF F_P/DELPHI} write RESetOnURL;\r
    {* |<#richedit>\r
       Is called when click on URL detected. }\r
\r
    //property RE_SelectionBar: Boolean read REGetSelectionBar write RESetSelectionBar;\r
    //{* ??? - don't know that is this... }\r
    function RE_NoOLEDragDrop: PControl;\r
    {* |<#richedit>\r
       Just prevents drop OLE objects to the rich edit control. Seems not\r
       working for some cases. }\r
\r
    //function RE_Wyswig: PControl;\r
\r
    function RE_Bottomless: PControl;\r
    // not finished\r
\r
    property RE_Transparent: Boolean read REGetTransparent write RESetTransparent;\r
    {* |<#richedit>\r
       Use this property to make richedit control transparent, instead of\r
       Ed_Transparent or Transparent. But do not place such transparent\r
       richedit control directly on form - it can be draw incorrectly when\r
       form is activated and rich editr control is not current active control.\r
       Use at least panel as a parent instead.\r
       }\r
\r
    //========== both for Edit and RichEdit: =====================\r
    function CanUndo: Boolean;\r
    {* |<#richedit>\r
       |<#edit>\r
       |<#memo>\r
       Returns True, if the edit (or RichEdit) control can correctly process\r
       the EM_UNDO message. }\r
    procedure EmptyUndoBuffer;\r
    {* |<#richedit>\r
       |<#edit>\r
       |<#memo>\r
       Reset the undo flag of an edit control, preventing undoing all previous\r
       changes. }\r
    function Undo: Boolean;\r
    {* |<#richedit>\r
       |<#edit>\r
       |<#memo>\r
       For a single-line edit control, the return value is always TRUE. For a\r
       multiline edit control and RichEdit control, the return value is TRUE if\r
       the undo operation is successful, or FALSE if the undo operation fails. }\r
\r
    function RE_Redo: Boolean;\r
    {* |<#richedit>\r
       Only for RichEdit control: Returns True if successful. }\r
\r
    //----------------------------------------------------------------------\r
    // DateTimePicker\r
    property OnDTPUserString: TDTParseInputEvent read FOnDTPUserString\r
             write FOnDTPUserString;\r
    {* Special event to parse input from the application. Option dtpoParseInput\r
       must be set when control is created. }\r
    property DateTime: TDateTime read GetDateTime write SetDateTime;\r
    {* DateTime for DateTimePicker control only. }\r
    property Date: TDateTime read GetDate write SetDate;\r
    {* Date only for DateTimePicker control only. }\r
    property Time: TDateTime read GetTime write SetTime;\r
    {* Time only for DateTimePicker control only. }\r
    property DateTimeRange: TDateTimeRange read GetDateTimeRange\r
      write SetDateTimeRange;\r
    {* DateTimePicker range. If first date in the agrument assigned is NAN,\r
       minimum system allowed value is used as the left bound, and if the second is\r
       NAN, maximum system allowed is used as the right one. }\r
    property DateTimePickerColors[ Index: TDateTimePickerColor ]: TColor\r
      read GetDateTimePickerColor write SetDateTimePickerColor;\r
    property DateTimeFormat: String write SetDateTimeFormat;\r
\r
\r
    //----------------------------------------------------------------------\r
\r
    //----------------------------------------------------------------------\r
    // ScrollBar\r
    property SBMin: Longint read fSBMinMax.X write SetSBMin;\r
    property SBMax: Longint read fSBMinMax.Y write SetSBMax;\r
    property SBMinMax: TPoint read fSBMinMax write SetSBMinMax;\r
    property SBPosition: Integer read fSBPosition write SetSBPosition;\r
    property SBPageSize: Integer read fSBPageSize write SetSBPageSize;\r
\r
    property OnSBBeforeScroll: TOnSBBeforeScroll read FOnSBBeforeScroll write FOnSBBeforeScroll;\r
    property OnSBScroll: TOnSBScroll read FOnSBScroll write FOnSBScroll;\r
\r
    function SBSetScrollInfo(const SI: TScrollInfo): Integer;\r
    function SBGetScrollInfo(var SI: TScrollInfo): Boolean;\r
    function GetSBMinMax: TPoint;\r
    function GetSBPageSize: Integer;\r
    function GetSBPosition: Integer;\r
    //----------------------------------------------------------------------\r
\r
\r
    // "Through", or "transparent" methods to simplify initial\r
    // adjustment of controls and make non-visual designing of\r
    // forms more easy. All these functions return @Self as a\r
    // result, so, it is possible to use such methods immediately\r
    // in constructing statement, concatenating it with dots, e.g.:\r
    //\r
    // NewButton( MyForm, 'Click here' ).PlaceUnder.ResizeParentBottom;\r
    //\r
    function PlaceRight: PControl;\r
    {* Places control right (to previously created on the same parent). }\r
    function PlaceDown: PControl;\r
    {* Places control below (to previously created on the same parent).\r
       Left position is not changed (thus is, kept equal to Parent.Margin). }\r
    function PlaceUnder: PControl;\r
    {* Places control below (to previously created one, aligning its\r
       Left position to Left position of previous control). }\r
    function SetSize( W, H: Integer ): PControl;\r
\r
    {* Changes size of a control. If W or H less or equal to 0,\r
       correspondent size is not changed. }\r
    function Size( W, H: Integer ): PControl;\r
    {* Like SetSize, but provides automatic resizing of parent control\r
       (recursively). Especially useful for aligned controls. }\r
    function SetClientSize( W, H: Integer ): PControl;\r
    {* Like SetSize, but works setting W = ClientWidth, H = ClientHeight.\r
       Use this method for forms, which can not be resized (dialogs). }\r
\r
    function AutoSize( AutoSzOn: Boolean ): PControl;\r
\r
    {* Determines if to autosize control (like label, button, etc.) }\r
    function IsAutoSize: Boolean;\r
    {* TRUE, if a control is autosizing. }\r
    function AlignLeft( P: PControl ): PControl;\r
    {* assigns Left := P.Left }\r
    function AlignTop( P: PControl ): PControl;\r
    {* assigns Top := P.Top }\r
    function ResizeParent: PControl;\r
    {* Resizes parent, calling ResizeParentRight and ResizeParentBottom. }\r
    function ResizeParentRight: PControl;\r
    {* Resizes parent right edge (Margin of parent is added to right\r
       coordinate of a control). If called second time (for the same\r
       parent), resizes only for increasing of right edge of parent. }\r
\r
    function ResizeParentBottom: PControl;\r
    {* Resizes parent bottom edge (Margin of parent is added to\r
       bottom coordinate of a control). }\r
    function CenterOnParent: PControl;\r
    {* Centers control on parent, or if applied to a form, centers\r
       form on screen. }\r
\r
    function Shift( dX, dY : Integer ): PControl;\r
    {* Moves control respectively to current position (Left := Left + dX,\r
       Top := Top + dY). }\r
    function SetPosition( X, Y: Integer ): PControl;\r
    {* Moves control directly to the specified position. }\r
\r
    function Tabulate: PControl;\r
    {* Call it once for form/applet to provide tabulation between controls on\r
       form/on all forms using TAB / SHIFT+TAB and arrow keys. }\r
    function TabulateEx: PControl;\r
    {* Call it once for form/applet to provide tabulation between controls on\r
       form/on all forms using TAB / SHIFT+TAB and arrow keys. Arrow keys are\r
       used more smart, allowing go to nearest control in certain direction. }\r
\r
    function SetAlign( AAlign: TControlAlign ): PControl;\r
    {* Assigns passed value to property Align, aligning control on parent,\r
       and returns @Self (so it is "transparent" function, which can be\r
       used to adjust control at the creation, e.g.:\r
       ! MyLabel := NewLabel( MyForm, 'Label1' ).SetAlign( caBottom );\r
       See also property Align. }\r
    function PreventResizeFlicks: PControl;\r
    {* If called, prevents resizing flicks for child controls, aligned to\r
       right and bottom (but with a lot of code added to executable - about 3,5K).\r
       There is sensible to set DoubleBuffered to True also to eliminate the\r
       most of flicks.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       This method been applied to a form, prevents, resizing flicks for\r
       form and all controls on the form. If it is called for applet window,\r
       all forms are affected. And if You want, You can apply it for certain\r
       control only - in such case only given control and its children will\r
       be resizing without flicks (e.g., using splitter control). }\r
\r
    property Checked: Boolean read GetChecked write Set_Checked;\r
    {* |<#checkbox>\r
       |<#radiobox>\r
       For checkbox and radiobox - if it is checked. Do not assign\r
       value for radiobox - use SetRadioChecked instead. }\r
    function SetChecked(const Value: Boolean): PControl;\r
    {* |<#checkbox>\r
       Use it to check/uncheck check box control or push button.\r
       Do not apply it to check radio buttons - use SetRadioChecked\r
       method below. }\r
    function SetRadioChecked : PControl;\r
    {* |<#radiobox>\r
       Use it to check radio button item correctly (unchecking all\r
       alternative ones). Actually, method Click is called, and control\r
       itself is returned. }\r
    function SetRadioCheckedOld: PControl;\r
    {* |<#radiobox>\r
       Old version of SetRadioChecked (implemented using recommended API\r
       call. It does not work properly, if control is not visible\r
       (together with its form). }\r
    procedure Click;\r
    {* |<#button>\r
       |<#checkbox>\r
       |<#radiobox>\r
       Emulates click on control programmatically, sending WM_COMMAND\r
       message with BN_CLICKED code. This method is sensible only for\r
       buttons, checkboxes and radioboxes. }\r
\r
    function Perform( msgcode: DWORD; wParam, lParam: Integer): Integer; stdcall;\r
    {* Sends message to control's window (created if needed). }\r
    procedure AttachProc( Proc: TWindowFunc );\r
    {* It is possible to attach dynamically any message handler to window\r
       procedure using this method. Last attached procedure is called first.\r
       If procedure returns True, further processing of a message is stopped.\r
       Attached procedure can be detached using DetachProc (but do not\r
       attach/detach procedures during handling of attached procedure -\r
       this can hang application). }\r
    procedure AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );\r
    {* The same as AttachProc, but a handler is executed even after terminating\r
       the main message loop processing (i.e. after assigning true to\r
       AppletTerminated global variable. }\r
    function IsProcAttached( Proc: TWindowFunc ): Boolean;\r
    {* Returns True, if given procedure is already in chain of attached\r
       ones for given control window proc. }\r
    procedure DetachProc( Proc: TWindowFunc );\r
    {* Detaches procedure attached earlier using AttachProc. }\r
\r
    property OnDropFiles: TOnDropFiles read FOnDropFiles write SetOnDropFiles;\r
    {* Assign this event to your handler, if You want to accept drag and drop\r
       files from other applications such as explorer onto your control. When\r
       this event is assigned to a control or form, this has effect also for\r
       all its child controls too. }\r
\r
    property CustomData: Pointer read fCustomData write fCustomData;\r
    {* Can be used to exend the object when new type of control added. Memory,\r
       pointed by this pointer, released automatically in the destructor. }\r
    property CustomObj: PObj read fCustomObj write fCustomObj;\r
    {* Can be used to exend the object when new type of control added. Object,\r
       pointed by this pointer, released automatically in the destructor. }\r
    procedure SetAutoPopupMenu( PopupMenu: PObj );\r
    {* To assign a popup menu to the control, call SetAutoPopupMenu method of\r
       the control with popup menu object as a parameter. }\r
\r
    function SupportMnemonics: PControl;\r
    {* This method provides supporting mnemonic keys in menus, buttons, checkboxes,\r
       toolbar buttons. }\r
    property OnScroll: TOnScroll read FOnScroll write SetOnScroll;\r
    {* }\r
\r
\r
\r
    {$IFDEF USE_CONSTRUCTORS}\r
    //------------------------------------------------------------\r
    // constructors here:\r
    constructor CreateWindowed( AParent: PControl; AClassName: PChar; ACtl3D: Boolean );\r
    constructor CreateApplet( const ACaption: String );\r
    constructor CreateForm( AParent: PControl; const ACaption: String );\r
    constructor CreateControl( AParent: PControl; AClassName: PChar; AStyle: DWORD;\r
                               ACtl3D: Boolean; Actions: PCommandActions );\r
    constructor CreateButton( AParent: PControl; const ACaption: String );\r
    constructor CreateBitBtn( AParent: PControl; const ACaption: String;\r
         AOptions: TBitBtnOptions; ALayout: TGlyphLayout; AGlyphBitmap: HBitmap;\r
         AGlyphCount: Integer);\r
    constructor CreateLabel( AParent: PControl; const ACaption: String );\r
    constructor CreateWordWrapLabel( AParent: PControl; const ACaption: String );\r
    constructor CreateLabelEffect( AParent: PControl; ACaption: String; AShadowDeep: Integer );\r
    constructor CreatePaintBox( AParent: PControl );\r
    constructor CreateGradientPanel( AParent: PControl; AColor1, AColor2: TColor );\r
    constructor CreateGradientPanelEx( AParent: PControl; AColor1, AColor2: TColor;\r
                             AStyle: TGradientStyle; ALayout: TGradientLayout );\r
    constructor CreateGroupbox( AParent: PControl; const ACaption: String );\r
    constructor CreateCheckbox( AParent: PControl; const ACaption: String );\r
    constructor CreateRadiobox( AParent: PControl; const ACaption: String );\r
    constructor CreateEditbox( AParent: PControl; AOptions: TEditOptions );\r
    constructor CreatePanel( AParent: PControl; AStyle: TEdgeStyle );\r
    constructor CreateSplitter( AParent: PControl; AMinSizePrev, AMinSizeNext: Integer;\r
                EdgeStyle: TEdgeStyle );\r
    constructor CreateListbox( AParent: PControl; AOptions: TListOptions );\r
    constructor CreateCombobox( AParent: PControl; AOptions: TComboOptions );\r
    constructor CreateCommonControl( AParent: PControl; AClassName: PChar; AStyle: DWORD;\r
                            ACtl3D: Boolean; Actions: PCommandActions );\r
    constructor CreateRichEdit( AParent: PControl; AOptions: TEditOptions );\r
    constructor CreateRichEdit1( AParent: PControl; AOptions: TEditOptions );\r
    constructor CreateProgressbar( AParent: PControl );\r
    constructor CreateProgressbarEx( AParent: PControl; AOptions: TProgressbarOptions );\r
    constructor CreateListView( AParent: PControl; AStyle: TListViewStyle; AOptions: TListViewOptions;\r
                      AImageListSmall, AImageListNormal, AImageListState: PImageList );\r
    constructor CreateTreeView( AParent: PControl; AOptions: TTreeViewOptions;\r
                      AImgListNormal, AImgListState: PImageList );\r
    constructor CreateTabControl( AParent: PControl; ATabs: array of String;\r
         AOptions: TTabControlOptions; AImgList: PImageList; AImgList1stIdx: Integer );\r
    constructor CreateToolbar( AParent: PControl; AAlign: TControlAlign; AOptions: TToolbarOptions;\r
                     ABitmap: HBitmap; AButtons: array of PChar;\r
                     ABtnImgIdxArray: array of Integer );\r
    {$ENDIF USE_CONSTRUCTORS}\r
\r
    {$IFDEF USE_CUSTOMEXTENSIONS}\r
      {$I CUSTOM_TCONTROL_EXTENSION.inc}\r
    {$ENDIF}\r
    // If an option USE_CUSTOMEXTENSIONS is enabled (at the beginning of this\r
    // unit), You can freely extend TControl definition by your own fields,\r
    // methods and properties. This provides You with capability to extend\r
    // TControl implementing another kinds of visual controls without deriving\r
    // new descendant objects from TControl. This way is provided to avoid too\r
    // large grow of executable size. You also can derive your own controls\r
    // from TControl using standard OOP capabilities. In such case an option\r
    // USE_CONSTRUCTORS should be turned on (see it at the start of this unit).\r
    //   If You choose this "flat" model of extending the TControl with your\r
    // own properties, fieds, methods, events, etc. You should provide three\r
    // inc-files: CUSTOM_TCONTROL_EXTENSION.inc, containing such definitions\r
    // for TControl, CUSTOM_KOL_EXTENSION.inc, containing needed global\r
    // declarations, and CUSTOM_CODE_EXTENSION.inc, the implementation of those\r
    // two.\r
    //   Because KOL is always grow and constantly is extending by me, I also can\r
    // add my own complements for TControl. To avoid naming conflicts, I suggest\r
    // to use the same naming rule for all of You. Name your fields, properies, etc.\r
    // using a form idx_SomeName, where idx is a prefix, containing several\r
    // (at least one) letters and digits. E.g. ZK65_OnSomething.\r
\r
  protected\r
    {$IFDEF USE_DROPDOWNCOUNT}\r
    fDropDownCount: Cardinal;\r
    {$ENDIF}\r
  public\r
    {$IFDEF USE_DROPDOWNCOUNT}\r
    property DropDownCount: Cardinal read fDropDownCount write fDropDownCount;\r
    {$ENDIF}\r
  end;\r
//[END OF TControl DEFINITION]\r
\r
  {$IFDEF USE_MHTOOLTIP}\r
  {$DEFINE interface}\r
  {$I KOLMHToolTip}\r
  {$UNDEF interface}\r
  {$ENDIF}\r
\r
//[Paint Background PROCEDURE]\r
type\r
  TOnPaintBkgnd = procedure( Sender: PControl; DC: HDC; Rect: PRect );\r
  {* Global event definition. Used to define Global_OnPaintBackground\r
     event placeholder. }\r
\r
procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );\r
\r
var\r
  Global_OnPaintBkgnd: TOnPaintBkgnd = DefaultPaintBackground;\r
  {* Global event. It is assigned in XBackgounds.pas add-on to replace\r
     PaintBackground method for all TVisual objects, allowing great\r
     visualization effect: transparent controls over [animated] bitmap\r
     background. Idea:\r
     | <a href=mailto:"bw@sunv.com">Wei&nbsp;Bao</a>. Implementation:\r
     | <a href=mailto:"bonanzas@xcl.cjb.net">Kladov&nbsp;Vladimir</a>. }\r
\r
procedure DummyPaintProc( Sender: PControl; DC: HDC );\r
\r
//[GetShiftState DECLARATION]\r
function GetShiftState: DWORD;\r
\r
//[WndProcXXX DECLARATIONS]\r
function WndProcMouse( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
function WndProcKeybd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
function WndProcDummy( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
function WndProcBufferedDraw( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}\r
function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
{$ENDIF}\r
\r
//[InitCommonXXXX DECLARATIONS]\r
procedure InitCommonControlSizeNotify( Ctrl: PControl );\r
procedure InitCommonControlCommonNotify( Ctrl: PControl );\r
\r
//[Buffered Draw DECLARATIONS]\r
var\r
  Global_OnBufferedDraw: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean\r
                         = WndProcDummy;\r
  Global_DblBufCreateWnd: procedure( Sender: PObj ) = DummyObjProc;\r
  Global_Invalidate: procedure( Sender: PObj ) = DummyObjProc;\r
  {* Is called in TControl.Invalidate to extend it in case when DoubleBuffered\r
     painting used. }\r
\r
  Global_TranspDrawBkgnd: procedure( DC: HDC; Sender: PControl );\r
\r
  //Global_OnCreateWindow: procedure( Sender: PObj ) = DummyObjProc;\r
  //{* Is called when TControl object is created. }\r
  //Global_OnDestroyWindow: procedure( Sender: PObj ) = DummyObjProc;\r
  //{* Is called before destroying TControl object (after accepting it,\r
  //   if event OnClose is defined). }\r
  Global_OnBeginPaint: procedure( Sender: PControl; DC: HDC ) = DummyPaintProc;\r
  {* Is called before painting a window. }\r
  Global_OnEndPaint: procedure( Sender: PControl; DC: HDC ) = DummyPaintProc;\r
  {* Is called after painting a window. }\r
  HelpFilePath: PChar;\r
  {* Path to application help file. If not assigned, application path with\r
     extension replaced to '.hlp' used. To use '.chm' file (HtmlHelp),\r
     call AssignHtmlHelp with a path to a html help file (or a name). }\r
\r
//[Html Help DECLARATIONS]\r
procedure AssignHtmlHelp( const HtmlHelpPath: String );\r
procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: String; Cmd, Data: Integer );\r
{* Use this wrapper procedure to call HtmlHelp API function. }\r
//+++++++++++ HTML HELP DEFINITIONS SECTION:\r
// this section is from\r
//   HTML Help API Interface Unit\r
//   Copyright (c) 1999 The Helpware Group\r
// provided for KOL by Alexey Babenko\r
const\r
  HH_DISPLAY_TOPIC        = $0000;  {**}\r
  HH_HELP_FINDER          = $0000;  // WinHelp equivalent\r
  HH_DISPLAY_TOC          = $0001;  // not currently implemented\r
  HH_DISPLAY_INDEX        = $0002;  // not currently implemented\r
  HH_DISPLAY_SEARCH       = $0003;  // not currently implemented\r
  HH_SET_WIN_TYPE         = $0004;\r
  HH_GET_WIN_TYPE         = $0005;\r
  HH_GET_WIN_HANDLE       = $0006;\r
  HH_ENUM_INFO_TYPE       = $0007;  // Get Info type name, call repeatedly to enumerate, -1 at end\r
  HH_SET_INFO_TYPE        = $0008;  // Add Info type to filter.\r
  HH_SYNC                 = $0009;\r
  HH_RESERVED1            = $000A;\r
  HH_RESERVED2            = $000B;\r
  HH_RESERVED3            = $000C;\r
  HH_KEYWORD_LOOKUP       = $000D;\r
  HH_DISPLAY_TEXT_POPUP   = $000E;  // display string resource id or text in a popup window\r
  HH_HELP_CONTEXT         = $000F;  {**}// display mapped numeric value in dwData\r
  HH_TP_HELP_CONTEXTMENU  = $0010;  // text popup help, same as WinHelp HELP_CONTEXTMENU\r
  HH_TP_HELP_WM_HELP      = $0011;  // text popup help, same as WinHelp HELP_WM_HELP\r
  HH_CLOSE_ALL            = $0012;  // close all windows opened directly or indirectly by the caller\r
  HH_ALINK_LOOKUP         = $0013;  // ALink version of HH_KEYWORD_LOOKUP\r
  HH_GET_LAST_ERROR       = $0014;  // not currently implemented // See HHERROR.h\r
  HH_ENUM_CATEGORY        = $0015;      // Get category name, call repeatedly to enumerate, -1 at end\r
  HH_ENUM_CATEGORY_IT     = $0016;  // Get category info type members, call repeatedly to enumerate, -1 at end\r
  HH_RESET_IT_FILTER      = $0017;  // Clear the info type filter of all info types.\r
  HH_SET_INCLUSIVE_FILTER = $0018;  // set inclusive filtering method for untyped topics to be included in display\r
  HH_SET_EXCLUSIVE_FILTER = $0019;  // set exclusive filtering method for untyped topics to be excluded from display\r
  HH_INITIALIZE           = $001C;  // Initializes the help system.\r
  HH_UNINITIALIZE         = $001D;  // Uninitializes the help system.\r
  HH_PRETRANSLATEMESSAGE  = $00fd;  // Pumps messages. (NULL, NULL, MSG*).\r
  HH_SET_GLOBAL_PROPERTY  = $00fc;  // Set a global property. (NULL, NULL, HH_GPROP)\r
\r
  { window properties }\r
\r
const\r
  HHWIN_PROP_TAB_AUTOHIDESHOW = $00000001;  // (1 << 0)  Automatically hide/show tri-pane window\r
  HHWIN_PROP_ONTOP            = $00000002;  // (1 << 1)  Top-most window\r
  HHWIN_PROP_NOTITLEBAR       = $00000004;  // (1 << 2)  no title bar\r
  HHWIN_PROP_NODEF_STYLES     = $00000008;  // (1 << 3)  no default window styles (only HH_WINTYPE.dwStyles)\r
  HHWIN_PROP_NODEF_EXSTYLES   = $00000010;  // (1 << 4)  no default extended window styles (only HH_WINTYPE.dwExStyles)\r
  HHWIN_PROP_TRI_PANE         = $00000020;  // (1 << 5)  use a tri-pane window\r
  HHWIN_PROP_NOTB_TEXT        = $00000040;  // (1 << 6)  no text on toolbar buttons\r
  HHWIN_PROP_POST_QUIT        = $00000080;  // (1 << 7)  post WM_QUIT message when window closes\r
  HHWIN_PROP_AUTO_SYNC        = $00000100;  // (1 << 8)  automatically ssync contents and index\r
  HHWIN_PROP_TRACKING         = $00000200;  // (1 << 9)  send tracking notification messages\r
  HHWIN_PROP_TAB_SEARCH       = $00000400;  // (1 << 10) include search tab in navigation pane\r
  HHWIN_PROP_TAB_HISTORY      = $00000800;  // (1 << 11) include history tab in navigation pane\r
  HHWIN_PROP_TAB_FAVORITES    = $00001000;  // (1 << 12) include favorites tab in navigation pane\r
  HHWIN_PROP_CHANGE_TITLE     = $00002000;  // (1 << 13) Put current HTML title in title bar\r
  HHWIN_PROP_NAV_ONLY_WIN     = $00004000;  // (1 << 14) Only display the navigation window\r
  HHWIN_PROP_NO_TOOLBAR       = $00008000;  // (1 << 15) Don't display a toolbar\r
  HHWIN_PROP_MENU             = $00010000;  // (1 << 16) Menu\r
  HHWIN_PROP_TAB_ADVSEARCH    = $00020000;  // (1 << 17) Advanced FTS UI.\r
  HHWIN_PROP_USER_POS         = $00040000;  // (1 << 18) After initial creation, user controls window size/position\r
  HHWIN_PROP_TAB_CUSTOM1      = $00080000;  // (1 << 19) Use custom tab #1\r
  HHWIN_PROP_TAB_CUSTOM2      = $00100000;  // (1 << 20) Use custom tab #2\r
  HHWIN_PROP_TAB_CUSTOM3      = $00200000;  // (1 << 21) Use custom tab #3\r
  HHWIN_PROP_TAB_CUSTOM4      = $00400000;  // (1 << 22) Use custom tab #4\r
  HHWIN_PROP_TAB_CUSTOM5      = $00800000;  // (1 << 23) Use custom tab #5\r
  HHWIN_PROP_TAB_CUSTOM6      = $01000000;  // (1 << 24) Use custom tab #6\r
  HHWIN_PROP_TAB_CUSTOM7      = $02000000;  // (1 << 25) Use custom tab #7\r
  HHWIN_PROP_TAB_CUSTOM8      = $04000000;  // (1 << 26) Use custom tab #8\r
  HHWIN_PROP_TAB_CUSTOM9      = $08000000;  // (1 << 27) Use custom tab #9\r
  HHWIN_TB_MARGIN             = $10000000;  // (1 << 28) the window type has a margin\r
\r
  { window parameters }\r
\r
const\r
  HHWIN_PARAM_PROPERTIES      = $00000002;  // (1 << 1)  valid fsWinProperties\r
  HHWIN_PARAM_STYLES          = $00000004;  // (1 << 2)  valid dwStyles\r
  HHWIN_PARAM_EXSTYLES        = $00000008;  // (1 << 3)  valid dwExStyles\r
  HHWIN_PARAM_RECT            = $00000010;  // (1 << 4)  valid rcWindowPos\r
  HHWIN_PARAM_NAV_WIDTH       = $00000020;  // (1 << 5)  valid iNavWidth\r
  HHWIN_PARAM_SHOWSTATE       = $00000040;  // (1 << 6)  valid nShowState\r
  HHWIN_PARAM_INFOTYPES       = $00000080;  // (1 << 7)  valid apInfoTypes\r
  HHWIN_PARAM_TB_FLAGS        = $00000100;  // (1 << 8)  valid fsToolBarFlags\r
  HHWIN_PARAM_EXPANSION       = $00000200;  // (1 << 9)  valid fNotExpanded\r
  HHWIN_PARAM_TABPOS          = $00000400;  // (1 << 10) valid tabpos\r
  HHWIN_PARAM_TABORDER        = $00000800;  // (1 << 11) valid taborder\r
  HHWIN_PARAM_HISTORY_COUNT   = $00001000;  // (1 << 12) valid cHistory\r
  HHWIN_PARAM_CUR_TAB         = $00002000;  // (1 << 13) valid curNavType\r
\r
  { button constants }\r
\r
const\r
  HHWIN_BUTTON_EXPAND         = $00000002;  // (1 << 1)  Expand/contract button\r
  HHWIN_BUTTON_BACK           = $00000004;  // (1 << 2)  Back button\r
  HHWIN_BUTTON_FORWARD        = $00000008;  // (1 << 3)  Forward button\r
  HHWIN_BUTTON_STOP           = $00000010;  // (1 << 4)  Stop button\r
  HHWIN_BUTTON_REFRESH        = $00000020;  // (1 << 5)  Refresh button\r
  HHWIN_BUTTON_HOME           = $00000040;  // (1 << 6)  Home button\r
  HHWIN_BUTTON_BROWSE_FWD     = $00000080;  // (1 << 7)  not implemented\r
  HHWIN_BUTTON_BROWSE_BCK     = $00000100;  // (1 << 8)  not implemented\r
  HHWIN_BUTTON_NOTES          = $00000200;  // (1 << 9)  not implemented\r
  HHWIN_BUTTON_CONTENTS       = $00000400;  // (1 << 10) not implemented\r
  HHWIN_BUTTON_SYNC           = $00000800;  // (1 << 11) Sync button\r
  HHWIN_BUTTON_OPTIONS        = $00001000;  // (1 << 12) Options button\r
  HHWIN_BUTTON_PRINT          = $00002000;  // (1 << 13) Print button\r
  HHWIN_BUTTON_INDEX          = $00004000;  // (1 << 14) not implemented\r
  HHWIN_BUTTON_SEARCH         = $00008000;  // (1 << 15) not implemented\r
  HHWIN_BUTTON_HISTORY        = $00010000;  // (1 << 16) not implemented\r
  HHWIN_BUTTON_FAVORITES      = $00020000;  // (1 << 17) not implemented\r
  HHWIN_BUTTON_JUMP1          = $00040000;  // (1 << 18)\r
  HHWIN_BUTTON_JUMP2          = $00080000;  // (1 << 19)\r
  HHWIN_BUTTON_ZOOM           = $00100000;  // (1 << 20)\r
  HHWIN_BUTTON_TOC_NEXT       = $00200000;  // (1 << 21)\r
  HHWIN_BUTTON_TOC_PREV       = $00400000;  // (1 << 22)\r
\r
  HHWIN_DEF_BUTTONS           = (HHWIN_BUTTON_EXPAND\r
                                 OR HHWIN_BUTTON_BACK\r
                                 OR HHWIN_BUTTON_OPTIONS\r
                                 OR HHWIN_BUTTON_PRINT);\r
\r
\r
  { Button IDs }\r
\r
const\r
  IDTB_EXPAND             = 200;\r
  IDTB_CONTRACT           = 201;\r
  IDTB_STOP               = 202;\r
  IDTB_REFRESH            = 203;\r
  IDTB_BACK               = 204;\r
  IDTB_HOME               = 205;\r
  IDTB_SYNC               = 206;\r
  IDTB_PRINT              = 207;\r
  IDTB_OPTIONS            = 208;\r
  IDTB_FORWARD            = 209;\r
  IDTB_NOTES              = 210; // not implemented\r
  IDTB_BROWSE_FWD         = 211;\r
  IDTB_BROWSE_BACK        = 212;\r
  IDTB_CONTENTS           = 213; // not implemented\r
  IDTB_INDEX              = 214; // not implemented\r
  IDTB_SEARCH             = 215; // not implemented\r
  IDTB_HISTORY            = 216; // not implemented\r
  IDTB_FAVORITES          = 217; // not implemented\r
  IDTB_JUMP1              = 218;\r
  IDTB_JUMP2              = 219;\r
  IDTB_CUSTOMIZE          = 221;\r
  IDTB_ZOOM               = 222;\r
  IDTB_TOC_NEXT           = 223;\r
  IDTB_TOC_PREV           = 224;\r
\r
\r
  { Notification codes }\r
\r
const\r
  HHN_FIRST       = (0-860);\r
  HHN_LAST        = (0-879);\r
\r
  HHN_NAVCOMPLETE   = (HHN_FIRST-0);\r
  HHN_TRACK         = (HHN_FIRST-1);\r
  HHN_WINDOW_CREATE = (HHN_FIRST-2);\r
\r
\r
type\r
  {*** Used by command HH_GET_LAST_ERROR\r
   NOTE: Not part of the htmlhelp.h but documented in HH Workshop help\r
         You must call SysFreeString(xx.description) to free BSTR\r
  }\r
  tagHH_LAST_ERROR = packed record\r
    cbStruct:      Integer;     // sizeof this structure\r
    hr:            Integer;     // Specifies the last error code.\r
    description:   PWideChar;   // (BSTR) Specifies a Unicode string containing a description of the error.\r
  end;\r
  HH_LAST_ERROR = tagHH_LAST_ERROR;\r
  THHLastError = tagHH_LAST_ERROR;\r
\r
\r
type\r
  {*** Notify event info for HHN_NAVCOMPLETE, HHN_WINDOW_CREATE }\r
  PHHNNotify = ^THHNNotify;\r
  tagHHN_NOTIFY = packed record\r
    hdr:    TNMHdr;\r
    pszUrl: PChar;              //PCSTR: Multi-byte, null-terminated string\r
  end;\r
  HHN_NOTIFY = tagHHN_NOTIFY;\r
  THHNNotify = tagHHN_NOTIFY;\r
\r
  {** Use by command HH_DISPLAY_TEXT_POPUP}\r
  PHHPopup = ^THHPopup;\r
  tagHH_POPUP = packed record\r
    cbStruct:      Integer;     // sizeof this structure\r
    hinst:         HINST;       // instance handle for string resource\r
    idString:      cardinal;    // string resource id, or text id if pszFile is specified in HtmlHelp call\r
    pszText:       PChar;       // used if idString is zero\r
    pt:            TPOINT;      // top center of popup window\r
    clrForeground: COLORREF;    // use -1 for default\r
    clrBackground: COLORREF;    // use -1 for default\r
    rcMargins:     TRect;       // amount of space between edges of window and text, -1 for each member to ignore\r
    pszFont:       PChar;       // facename, point size, char set, BOLD ITALIC UNDERLINE\r
  end;\r
  HH_POPUP = tagHH_POPUP;\r
  THHPopup = tagHH_POPUP;\r
\r
  {** Use by commands - HH_ALINK_LOOKUP, HH_KEYWORD_LOOKUP}\r
  PHHAKLink = ^THHAKLink;\r
  tagHH_AKLINK = packed record\r
    cbStruct:      integer;     // sizeof this structure\r
    fReserved:     BOOL;        // must be FALSE (really!)\r
    pszKeywords:   PChar;       // semi-colon separated keywords\r
    pszUrl:        PChar;       // URL to jump to if no keywords found (may be NULL)\r
    pszMsgText:    PChar;       // Message text to display in MessageBox if pszUrl is NULL and no keyword match\r
    pszMsgTitle:   PChar;       // Message text to display in MessageBox if pszUrl is NULL and no keyword match\r
    pszWindow:     PChar;       // Window to display URL in\r
    fIndexOnFail:  BOOL;        // Displays index if keyword lookup fails.\r
  end;\r
  HH_AKLINK = tagHH_AKLINK;\r
  THHAKLink = tagHH_AKLINK;\r
\r
\r
const\r
  HHWIN_NAVTYPE_TOC          = 0;\r
  HHWIN_NAVTYPE_INDEX        = 1;\r
  HHWIN_NAVTYPE_SEARCH       = 2;\r
  HHWIN_NAVTYPE_FAVORITES    = 3;\r
  HHWIN_NAVTYPE_HISTORY      = 4;   // not implemented\r
  HHWIN_NAVTYPE_AUTHOR       = 5;\r
  HHWIN_NAVTYPE_CUSTOM_FIRST = 11;\r
\r
\r
const\r
  IT_INCLUSIVE = 0;\r
  IT_EXCLUSIVE = 1;\r
  IT_HIDDEN    = 2;\r
\r
type\r
  PHHEnumIT = ^THHEnumIT;\r
  tagHH_ENUM_IT = packed record                  //tagHH_ENUM_IT, HH_ENUM_IT, *PHH_ENUM_IT\r
    cbStruct:           Integer;     // size of this structure\r
    iType:              Integer;     // the type of the information type ie. Inclusive, Exclusive, or Hidden\r
    pszCatName:         PAnsiChar;   // Set to the name of the Category to enumerate the info types in a category; else NULL\r
    pszITName:          PAnsiChar;   // volitile pointer to the name of the infotype. Allocated by call. Caller responsible for freeing\r
    pszITDescription:   PAnsiChar;   // volitile pointer to the description of the infotype.\r
  end;\r
  THHEnumIT = tagHH_ENUM_IT;\r
\r
\r
type\r
  PHHEnumCat = ^THHEnumCat;\r
  tagHH_ENUM_CAT = packed record                 //tagHH_ENUM_CAT, HH_ENUM_CAT, *PHH_ENUM_CAT\r
    cbStruct:           Integer;     // size of this structure\r
    pszCatName:         PAnsiChar;   // volitile pointer to the category name\r
    pszCatDescription:  PAnsiChar;   // volitile pointer to the category description\r
  end;\r
  THHEnumCat = tagHH_ENUM_CAT;\r
\r
\r
type\r
  PHHSetInfoType = ^THHSetInfoType;\r
  tagHH_SET_INFOTYPE = packed record             //tagHH_SET_INFOTYPE, HH_SET_INFOTYPE, *PHH_SET_INFOTYPE\r
    cbStruct:           Integer;     // the size of this structure\r
    pszCatName:         PAnsiChar;   // the name of the category, if any, the InfoType is a member of.\r
    pszInfoTypeName:    PAnsiChar;   // the name of the info type to add to the filter\r
  end;\r
  THHSetInfoType = tagHH_SET_INFOTYPE;\r
\r
\r
type\r
  HH_INFOTYPE = DWORD;\r
  THHInfoType = HH_INFOTYPE;\r
  PHHInfoType = ^THHInfoType;        //PHH_INFOTYPE\r
\r
\r
const\r
  HHWIN_NAVTAB_TOP    = 0;\r
  HHWIN_NAVTAB_LEFT   = 1;\r
  HHWIN_NAVTAB_BOTTOM = 2;\r
\r
const\r
  HH_MAX_TABS  = 19;                 // maximum number of tabs\r
const\r
  HH_TAB_CONTENTS     = 0;\r
  HH_TAB_INDEX        = 1;\r
  HH_TAB_SEARCH       = 2;\r
  HH_TAB_FAVORITES    = 3;\r
  HH_TAB_HISTORY      = 4;\r
  HH_TAB_AUTHOR       = 5;\r
  HH_TAB_CUSTOM_FIRST = 11;\r
  HH_TAB_CUSTOM_LAST  = HH_MAX_TABS;\r
\r
  HH_MAX_TABS_CUSTOM = (HH_TAB_CUSTOM_LAST - HH_TAB_CUSTOM_FIRST + 1);\r
\r
\r
\r
  { HH_DISPLAY_SEARCH Command Related Structures and Constants }\r
\r
const\r
  HH_FTS_DEFAULT_PROXIMITY = (-1);\r
\r
type\r
  {** Used by command HH_DISPLAY_SEARCH}\r
  PHHFtsQuery = ^THHFtsQuery;\r
  tagHH_FTS_QUERY = packed record          //tagHH_FTS_QUERY, HH_FTS_QUERY\r
    cbStruct:          integer;      // Sizeof structure in bytes.\r
    fUniCodeStrings:   BOOL;         // TRUE if all strings are unicode.\r
    pszSearchQuery:    PChar;        // String containing the search query.\r
    iProximity:        LongInt;      // Word proximity.\r
    fStemmedSearch:    Bool;         // TRUE for StemmedSearch only.\r
    fTitleOnly:        Bool;         // TRUE for Title search only.\r
    fExecute:          Bool;         // TRUE to initiate the search.\r
    pszWindow:         PChar;        // Window to display in\r
  end;\r
  THHFtsQuery = tagHH_FTS_QUERY;\r
\r
\r
  { HH_WINTYPE Structure }\r
\r
type\r
  {** Used by commands HH_GET_WIN_TYPE, HH_SET_WIN_TYPE}\r
  PHHWinType = ^THHWinType;\r
  tagHH_WINTYPE = packed record             //tagHH_WINTYPE, HH_WINTYPE, *PHH_WINTYPE;\r
    cbStruct:          Integer;      // IN: size of this structure including all Information Types\r
    fUniCodeStrings:   BOOL;         // IN/OUT: TRUE if all strings are in UNICODE\r
    pszType:           PChar;        // IN/OUT: Name of a type of window\r
    fsValidMembers:    DWORD;        // IN: Bit flag of valid members (HHWIN_PARAM_)\r
    fsWinProperties:   DWORD;        // IN/OUT: Properties/attributes of the window (HHWIN_)\r
\r
    pszCaption:        PChar;        // IN/OUT: Window title\r
    dwStyles:          DWORD;        // IN/OUT: Window styles\r
    dwExStyles:        DWORD;        // IN/OUT: Extended Window styles\r
    rcWindowPos:       TRect;        // IN: Starting position, OUT: current position\r
    nShowState:        Integer;      // IN: show state (e.g., SW_SHOW)\r
\r
    hwndHelp:          HWND;         // OUT: window handle\r
    hwndCaller:        HWND;         // OUT: who called this window\r
\r
    paInfoTypes:       PHHInfoType;  // IN: Pointer to an array of Information Types\r
\r
    { The following members are only valid if HHWIN_PROP_TRI_PANE is set }\r
\r
    hwndToolBar:       HWND;         // OUT: toolbar window in tri-pane window\r
    hwndNavigation:    HWND;         // OUT: navigation window in tri-pane window\r
    hwndHTML:          HWND;         // OUT: window displaying HTML in tri-pane window\r
    iNavWidth:         Integer;      // IN/OUT: width of navigation window\r
    rcHTML:            TRect;        // OUT: HTML window coordinates\r
\r
    pszToc:            PChar;        // IN: Location of the table of contents file\r
    pszIndex:          PChar;        // IN: Location of the index file\r
    pszFile:           PChar;        // IN: Default location of the html file\r
    pszHome:           PChar;        // IN/OUT: html file to display when Home button is clicked\r
    fsToolBarFlags:    DWORD;        // IN: flags controling the appearance of the toolbar (HHWIN_BUTTON_)\r
    fNotExpanded:      BOOL;         // IN: TRUE/FALSE to contract or expand, OUT: current state\r
    curNavType:        Integer;      // IN/OUT: UI to display in the navigational pane\r
    tabpos:            Integer;      // IN/OUT: HHWIN_NAVTAB_TOP, HHWIN_NAVTAB_LEFT, or HHWIN_NAVTAB_BOTTOM\r
    idNotify:          Integer;      // IN: ID to use for WM_NOTIFY messages\r
    tabOrder: packed array[0..HH_MAX_TABS] of Byte;  // IN/OUT: tab order: Contents, Index, Search, History, Favorites, Reserved 1-5, Custom tabs\r
    cHistory:          Integer;       // IN/OUT: number of history items to keep (default is 30)\r
    pszJump1:          PChar;         // Text for HHWIN_BUTTON_JUMP1\r
    pszJump2:          PChar;         // Text for HHWIN_BUTTON_JUMP2\r
    pszUrlJump1:       PChar;         // URL for HHWIN_BUTTON_JUMP1\r
    pszUrlJump2:       PChar;         // URL for HHWIN_BUTTON_JUMP2\r
    rcMinSize:         TRect;         // Minimum size for window (ignored in version 1)\r
\r
    cbInfoTypes:       Integer;       // size of paInfoTypes;\r
    pszCustomTabs:     PChar;         // multiple zero-terminated strings\r
  end;\r
  HH_WINTYPE = tagHH_WINTYPE;\r
  THHWinType = tagHH_WINTYPE;\r
\r
const\r
  HHACT_TAB_CONTENTS   = 0;\r
  HHACT_TAB_INDEX      = 1;\r
  HHACT_TAB_SEARCH     = 2;\r
  HHACT_TAB_HISTORY    = 3;\r
  HHACT_TAB_FAVORITES  = 4;\r
\r
  HHACT_EXPAND         = 5;\r
  HHACT_CONTRACT       = 6;\r
  HHACT_BACK           = 7;\r
  HHACT_FORWARD        = 8;\r
  HHACT_STOP           = 9;\r
  HHACT_REFRESH        = 10;\r
  HHACT_HOME           = 11;\r
  HHACT_SYNC           = 12;\r
  HHACT_OPTIONS        = 13;\r
  HHACT_PRINT          = 14;\r
  HHACT_HIGHLIGHT      = 15;\r
  HHACT_CUSTOMIZE      = 16;\r
  HHACT_JUMP1          = 17;\r
  HHACT_JUMP2          = 18;\r
  HHACT_ZOOM           = 19;\r
  HHACT_TOC_NEXT       = 20;\r
  HHACT_TOC_PREV       = 21;\r
  HHACT_NOTES          = 22;\r
\r
  HHACT_LAST_ENUM      = 23;\r
\r
\r
type\r
  {*** Notify event info for HHN_TRACK }\r
  PHHNTrack = ^THHNTrack;\r
  tagHHNTRACK = packed record                  //tagHHNTRACK, HHNTRACK;\r
    hdr:               TNMHdr;\r
    pszCurUrl:         PChar;                  // Multi-byte, null-terminated string  \r
    idAction:          Integer;                // HHACT_ value\r
    phhWinType:        PHHWinType;             // Current window type structure\r
  end;\r
  HHNTRACK = tagHHNTRACK;\r
  THHNTrack = tagHHNTRACK;\r
\r
\r
///////////////////////////////////////////////////////////////////////////////\r
//\r
// Global Control Properties.\r
//\r
const\r
  HH_GPROPID_SINGLETHREAD     = 1;      // VARIANT_BOOL: True for single thread\r
  HH_GPROPID_TOOLBAR_MARGIN   = 2;      // long: Provides a left/right margin around the toolbar.\r
  HH_GPROPID_UI_LANGUAGE      = 3;      // long: LangId of the UI.\r
  HH_GPROPID_CURRENT_SUBSET   = 4;      // BSTR: Current subset.\r
  HH_GPROPID_CONTENT_LANGUAGE = 5;      // long: LandId for desired content.\r
\r
type\r
  tagHH_GPROPID = HH_GPROPID_SINGLETHREAD..HH_GPROPID_CONTENT_LANGUAGE;                //tagHH_GPROPID, HH_GPROPID\r
  HH_GPROPID = tagHH_GPROPID;\r
  THHGPropID = HH_GPROPID;\r
\r
///////////////////////////////////////////////////////////////////////////////\r
//\r
// Global Property structure\r
//\r
{type\r
  PHHGlobalProperty = ^THHGlobalProperty;\r
  tagHH_GLOBAL_PROPERTY = record                  //tagHH_GLOBAL_PROPERTY, HH_GLOBAL_PROPERTY\r
    id:                THHGPropID;\r
    Dummy:             Integer;                  // Added to enforce 8-byte packing\r
    var_:              VARIANT;\r
  end;\r
  HH_GLOBAL_PROPERTY = tagHH_GLOBAL_PROPERTY;\r
  THHGlobalProperty = tagHH_GLOBAL_PROPERTY;}\r
//[END OF HTMLHELP DECLARATIONS]\r
\r
//[GetCtlBrush DECLARATIONS]\r
function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush; //forward;\r
\r
var\r
  Global_GetCtlBrushHandle: function( Sender: PControl ): HBrush = SimpleGetCtlBrushHandle;\r
  {* Is called to obtain brush handle. }\r
\r
  Global_Align: procedure( Sender: PObj ) = DummyObjProc;\r
  {* Is set to perform aligning of control, and only if property Align\r
     is changed for TControl, or SetAlign method is called for it. }\r
\r
//[WndFunc DECLARATION]\r
function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )\r
                                   : Integer; stdcall;\r
{* Global message handler for window. Redirects all messages to\r
   destination windows, obtaining target TControl object address from\r
   window itself, using GetProp API call. }\r
\r
//[Applet VARIABLES]\r
var AppletRunning: Boolean;\r
    {* Is set to True while message loop is processing (in Run procedure). }\r
    AppletTerminated: Boolean;\r
    {* Is set to True when message loop is terminated. }\r
    Applet: PControl;\r
    {* Applet window object. Actually, can be set to main form if program\r
       not needed in special applet button window (useful to make applet\r
       button invisible on taskbar, or to have several forms with single\r
       applet button - crete it in that case using NewApplet). }\r
    AppButtonUsed: Boolean;\r
    {* True if special window to represent applet button (may be invisible)\r
       is used. If no, every form is represented with its own taskbar button\r
       (always visible). }\r
\r
//[Screen DECLARATIONS]\r
    ScreenCursor: HCursor;\r
    {* Set this global variable to override any cursor settings of current\r
       form or control. }\r
\r
function ScreenWidth: Integer;\r
{* Returns screen width in pixels. }\r
function ScreenHeight: Integer;\r
{* Returns screen height in pixels. }\r
\r
//[Status DECLARATIONS]\r
type\r
  TStatusOption = ( soNoSizeGrip, soTop );\r
  {* Options available for status bars. }\r
  TStatusOptions = Set of TStatusOption;\r
  {* Status bar options. }\r
\r
\r
\r
\r
\r
//[Run DECLARATION]\r
procedure Run( var AppletWnd: PControl );\r
{* |<#appbutton>\r
   Call this procedure to process messages loop of your program.\r
   Pass here pointer to applet button object (if You have created it\r
   - see NewApplet) or your main form object of type PControl (created\r
   using NewForm).\r
     |<br><br>\r
     |<h1 align=center><font color=#FF8040><a name="visual_objects_constructors"></a>\r
       Visual objects constructing functions\r
     |</font></h1>\r
   Following constructing functions for visual controls are available:\r
   |#control\r
}\r
\r
//[Applet FUNCTIONS DECLARATIONS]\r
procedure AppletMinimize;\r
{* Minimizes the application (Applet should be assigned to have effect). }\r
procedure AppletHide;\r
{* Minimizes and hides application. }\r
procedure AppletRestore;\r
{* Restores Applet when minimized. }\r
\r
//[Idle handler DECALRATIONS]\r
{YS+}\r
procedure RegisterIdleHandler( const OnIdle: TOnEvent );\r
{* Registers new Idle handler. Idle handler is called each time when\r
   message queue becomes empty. }\r
procedure UnRegisterIdleHandler( const OnIdle: TOnEvent );\r
{* Unregisters Idle handler. }\r
{YS-}\r
\r
\r
\r
//[InitCommonXXXX ANOTHER DECLARATIONS]\r
\r
{* ComCtrl32 controls initialization. }\r
procedure InitCommonControls; stdcall;\r
procedure DoInitCommonControls( dwICC: DWORD );\r
{* Calls extended initialization for Common Controls (from ComCtrl32).\r
   Pass one of following constants:\r
   |<pre>\r
  ICC_LISTVIEW_CLASSES   = $00000001; // listview, header\r
  ICC_TREEVIEW_CLASSES   = $00000002; // treeview, tooltips\r
  ICC_BAR_CLASSES        = $00000004; // toolbar, statusbar, trackbar, tooltips\r
  ICC_TAB_CLASSES        = $00000008; // tab, tooltips\r
  ICC_UPDOWN_CLASS       = $00000010; // updown\r
  ICC_PROGRESS_CLASS     = $00000020; // progress\r
  ICC_HOTKEY_CLASS       = $00000040; // hotkey\r
  ICC_ANIMATE_CLASS      = $00000080; // animate\r
  ICC_WIN95_CLASSES      = $000000FF;\r
  ICC_DATE_CLASSES       = $00000100; // month picker, date picker, time picker, updown\r
  ICC_USEREX_CLASSES     = $00000200; // comboex\r
  ICC_COOL_CLASSES       = $00000400; // rebar (coolbar) control\r
  ICC_INTERNET_CLASSES   = $00000800;\r
  ICC_PAGESCROLLER_CLASS = $00001000; // page scroller\r
  ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control\r
   |</pre>\r
    }\r
\r
const\r
  ICC_LISTVIEW_CLASSES   = $00000001; // listview, header\r
  ICC_TREEVIEW_CLASSES   = $00000002; // treeview, tooltips\r
  ICC_BAR_CLASSES        = $00000004; // toolbar, statusbar, trackbar, tooltips\r
  ICC_TAB_CLASSES        = $00000008; // tab, tooltips\r
  ICC_UPDOWN_CLASS       = $00000010; // updown\r
  ICC_PROGRESS_CLASS     = $00000020; // progress\r
  ICC_HOTKEY_CLASS       = $00000040; // hotkey\r
  ICC_ANIMATE_CLASS      = $00000080; // animate\r
  ICC_WIN95_CLASSES      = $000000FF;\r
  ICC_DATE_CLASSES       = $00000100; // month picker, date picker, time picker, updown\r
  ICC_USEREX_CLASSES     = $00000200; // comboex\r
  ICC_COOL_CLASSES       = $00000400; // rebar (coolbar) control\r
  ICC_INTERNET_CLASSES   = $00000800;\r
  ICC_PAGESCROLLER_CLASS = $00001000; // page scroller\r
  ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control\r
\r
//[Ole DECLARATIONS]\r
function OleInit: Boolean;\r
{* Calls OleInitialize (once - all other calls are simulated by incrementing\r
   call counter. Every OleInit shoud be complemented with correspondent OleUninit.\r
   (Though, it is possible to call API function OleUnInitialize once to\r
   cancel all OleInit calls). }\r
procedure OleUnInit;\r
{* Decrements counter and calls OleUnInitialize when it is zeroed. }\r
var OleInitCount: Integer;\r
{-}\r
\r
function StringToOleStr(const Source: string): PWideChar;\r
{* }\r
\r
{+}\r
function SysAllocStringLen(psz: PWideChar; len: Integer): PWideChar; stdcall;\r
procedure SysFreeString( psz: PWideChar ); stdcall;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- Contructors for visual controls -- }\r
//[NewXXXX DECLARATIONS]\r
\r
//[_NewWindowed DECLARATION]\r
function _NewWindowed( AParent: PControl; ControlClassName: PChar; Ctl3D: Boolean ): PControl;\r
\r
//[NewApplet DECLARATION]\r
function NewApplet( const Caption: String ): PControl;\r
{* |<#control>\r
   Creates applet button window, which has to be parent of all other forms\r
   in your project (but this is *not must*). See also comments about NewForm.\r
   |<br>\r
   Following methods, properties and events are useful to work with applet\r
   control:\r
   |#appbutton }\r
\r
//[NewForm DECLARATION]\r
function NewForm( AParent: PControl; const Caption: String ): PControl;\r
{* |<#control>\r
   Creates form window object and returns pointer to it. If You use only one form,\r
   and You are not going to do applet button on task bar invisible, it is not\r
   necessary to create also special applet button window - just pass\r
   your (main) form object to Run procedure. In that case, it is a good\r
   idea to assign pointer to your main form object to Applet variable\r
   immediately following creating it - because some objects (e.g. TTimer)\r
   want to have Applet assigned to something.\r
   |<br>\r
   |&D=<a href="tcontrol.htm#%1" target=_top> %0 </a>\r
   Following methods, properties and events are useful to work with forms\r
   (ones common for all visual objects, such as <D Left>, <D Top>, <D Width>,\r
   <D Height>, etc. are not listed here - look TControl for it):\r
   |#form }\r
\r
//[_NewControl DECLARATION]\r
function _NewControl( AParent: PControl; ControlClassName: PChar;\r
         Style: DWORD; Ctl3D: Boolean; Actions: PCommandActions ): PControl;\r
\r
//[NewButton DECLARATION]\r
function NewButton( AParent: PControl; const Caption: String ): PControl;\r
{* |<#control>\r
   Creates button on given parent control or form.\r
   Please note, that in Windows, buttons can not change its <D Font> color\r
   and to be <D Transparent>.\r
   |<br> Following methods, properies and events are (especially) useful with\r
   a button:\r
   |#button }\r
\r
//[NewBitBtn DECLARATION]\r
function NewBitBtn( AParent: PControl; const Caption: String;\r
         Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl;\r
{* |<#control>\r
   Creates image button (actually implemented as owner-drawn). In Options,\r
   it is possible to determine, whether bitmap or image list used to contain\r
   one or more (up to 5) images, correspondent to certain BitBtn state.\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   For case of imagelist (option bboImageList), it is possible to use a\r
   number of glyphs from the image list, starting from image index given\r
   by GlyphCount parameter. Number of used glyphs is passed in that case\r
   in high word of GlyphCount parameter (if 0, one image is used therefore).\r
   For bboImageList, BitBtn can be Transparent (and in that case bboNoBorder\r
   style can be useful to draw custom buttons of non-rectangular shape).\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   For case of bitmap BitBtn, image is stretched down (if too big), but can\r
   not be transparent. It is not necessary for bitmap BitBtn to pass correct\r
   GlyphCount - it is calculated on base of bitmap size, if 0 is passed.\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   And, certainly, BitBtn can be without glyph image (text only). For that\r
   case, it is therefore is more flexible and power than usual Button (but\r
   requires more code). E.g., BitBtn can change its <D Font>, <D Color>,\r
   and to be totally <D Transparent>.\r
   Moreover, BitBtn can be <D Flat>, bboFixed, <D SpeedButton> and\r
   have property <D RepeatInterval>.\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   Note: if You use bboFixed Style, use OnChange event instead of OnClick,\r
   because <D Checked> state is changed immediately however OnClick occure\r
   only when mouse or space key released (and can be not called at all if\r
   mouse button is released out of BitBtn bounds). Also, bboFixed defines\r
   only which glyph to show (the border if it is not turned off behaves as\r
   usual for a button, i.e. it becomes lowered and then raised again at any click).\r
   Here You can find references to other properties, events and methods\r
   applicable to BitBtn:\r
   |#bitbtn }\r
\r
//[NewLabel DECLARATION]\r
function NewLabel( AParent: PControl; const Caption: String ): PControl;\r
{* |<#control>\r
   Creates static text control (native Windows STATIC control).\r
   Use property <D Caption> at run time to change label text. Also\r
   it is possible to adjust label <D Font>, <D Brush> or <D Color>.\r
   Label can be <D Transparent>. If You want to have rotated text\r
   label, call NewLabelEffect instead and change its <D Font>.FontOrientation.\r
   Other references certain for a label:\r
   |#label }\r
\r
//[NewWordWrapLabel DECLARATION]\r
function NewWordWrapLabel( AParent: PControl; const Caption: String ): PControl;\r
{* |<#control>\r
   Creates multiline static text control (native Windows STATIC control),\r
   which can wrap long text onto several lines. See also NewLabel.\r
   See also:\r
   |#wwlabel\r
   |#label }\r
\r
//[NewLabelEffect DECLARATION]\r
function NewLabelEffect( AParent: PControl; const Caption: String; ShadowDeep: Integer ): PControl;\r
{* |<#control>\r
   Creates 3D-label with capability to rotate its text <D Caption>, which\r
   is controlled by changing <D Font>.FontOrientation property. If You want\r
   to get flat effect label (e.g. to rotate it only), pass <D ShadowDeep> = 0.\r
   Please note, that drawing procedure uses <D Canvas> property, so using of\r
   LabelEffect leads to increase size of executable.\r
   See also:\r
   |#3dlabel\r
   |#label }\r
\r
//[NewPaintbox DECLARATION]\r
function NewPaintbox( AParent: PControl ): PControl;\r
{* |<#control>\r
   Creates owner-drawn STATIC control. Set its <D OnPaint> event to\r
   perform custom painting.\r
   |#paintbox }\r
\r
//[NewImageShow DECLARATION]\r
function NewImageShow( AParent: PControl; AImgList: PImageList; ImgIdx: Integer ): PControl;\r
{* |<#control>\r
   Creates an image show control, implemented as a paintbox which is used to\r
   draw an image from the imagelist. At run-time, use property CurIndex to\r
   select another image from the imagelist, and a property ImageListNormal to\r
   use another image list. When the control is created, its size becomes\r
   equal to dimensions of imagelist (if any). }\r
\r
//[NewScrollBar DECLARATION]\r
function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl;\r
{ * not yet finished... }\r
\r
//[NewScrollBox DECLARATION]\r
function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle;\r
         Bars: TScrollerBars ): PControl;\r
{* |<#control>\r
   Creates simple scrolling box, which can be used any way you wish, e.g. to scroll\r
   certain large image. To provide automatic scrolling of a set of child controls,\r
   use advanced scroll box, created with NewScrollBoxEx. }\r
\r
procedure NotifyScrollBox( Self_, Child: PControl );\r
\r
\r
function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;\r
{* |<#control>\r
   Creates extended scrolling box control, which automatically scrolls child\r
   controls (if any). }\r
\r
//[NewGradientPanel DECLARATION]\r
function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;\r
{* |<#control>\r
   Creates gradient-filled STATIC control. To adjust colors at the\r
   run time, change <D Color1> and <D Color2> properties (which initially are\r
   assigned from Color1, Color2 parameters), and call <D Invalidate> method\r
   to repaint control. }\r
\r
function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;\r
                             Style: TGradientStyle; Layout: TGradientLayout ): PControl;\r
{* |<#control>\r
   Creates gradient-filled STATIC control. To adjust colors at the\r
   run time, change <D Color1> and <D Color2> properties (which initially are\r
   assigned from Color1, Color2 parameters), and call <D Invalidate> method\r
   to repaint control. Depending on style and first line/point layout, can\r
   looking different. Idea: Vladimir Stojiljkovic. }\r
\r
//[NewPanel DECLARATION]\r
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;\r
{* |<#control>\r
   Creates panel, which can be parent for other controls (though, any\r
   control can be used as a parent for other ones, but panel is specially\r
   designed for such purpose). }\r
\r
//[NewMDIxxx DECLARATIONS]\r
function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl;\r
{* |<#control>\r
   Creates MDI client window, which is a special type of child window,\r
   containing all MDI child windows, created calling NewMDIChild function.\r
   On a form, MDI client behaves like a panel, so it can be placed and sized\r
   (or aligned) like any other controls. To minimize flick during resizing\r
   main form having another aligned controls, place MDI client window on\r
   a panel and align it caClient in the panel.\r
   |<br>Note:\r
   MDI client must be a single on the form. }\r
\r
function NewMDIChild( AParent: PControl; const ACaption: String ): PControl;\r
{* |<#control>\r
   Creates MDI client window. AParent should be a MDI client window,\r
   created with NewMDIClient function. }\r
\r
//[NewSplitter DECLARATIONS]\r
function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;\r
{* |<#control>\r
   Creates splitter control, which will separate previous one (i.e. last\r
   created one before splitter on the same parent) from created\r
   next, allowing to user to adjust size of separated controls by dragging\r
   the splitter in desired direction. Created splitter becomes vertical\r
   or horizontal depending on Align style of previous control on the same\r
   parent (if caLeft/caRight then vertical, if caTop/caBottom then horizontal).\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   Please note, what if previous control has no Align equal to caLeft/caRight\r
   or caTop/caBottom, splitter will not be able to function normally. If\r
   previous control does not exist, it is yet possible to use splitter as\r
   a resizeable panel (but set its initial Align value first - otherwise it\r
   is not set by default. Also, change Cursor property as You wish in that\r
   case, since it is not set too in case, when previous control does not\r
   exist).\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   Additional parameters determine, which minimal size (width or height -\r
   correspondently to split direction) is allowed for left (top) control\r
   and to rest of client area of parent, correspondently. (It is possible\r
   later to set second control for checking its size with MinSizeNext\r
   value - using TControl.SecondControl property). If -1 passed,\r
   correspondent control size is not checked during dragging of splitter.\r
   Usually 0 is more suitable value (with this value, it is garantee, that\r
   splitter will be always available even if mouse was released far from the\r
   edge of form).\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   It is possible for user to press Escape any time while dragging splitter\r
   to abort all adjustments made starting from left mouse button push and\r
   begin of drag the splitter. But remember please, that such event is\r
   controlled using timer, and therefore correspondent keyboard events\r
   are received by currently focused control. Be sure, that pressing Escape\r
   will not affect to any control on form, which could be focused, otherwise\r
   filter keyboard messages (by yourself) to prevent undesired handling of\r
   Escape key by certain controls while splitting. (Use Dragging property\r
   to check if splitter is dragging by user with mouse).\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   See also:\r
   NewSplitterEx\r
   |#splitter }\r
\r
function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;\r
         EdgeStyle: TEdgeStyle ): PControl;\r
{* |<#control>\r
   Creates splitter control. Difference from NewSplitter is what it is possible\r
   to determine if a splitter will be beveled or not. See also NewSplitter. }\r
\r
//[NewGroupbox DECLARATION]\r
function NewGroupbox( AParent: PControl; const Caption: String ): PControl;\r
{* |<#control>\r
   Creates group box control. Note, that to group radio items, group\r
   box is not necessary - any parent can play role of group for radio items.\r
   See also NewPanel. }\r
\r
//[NewCheckbox DECLARATION]\r
function NewCheckbox( AParent: PControl; const Caption: String ): PControl;\r
{* |<#control>\r
   Creates check box control. Special properties, methods, events:\r
   |#checkbox }\r
\r
function NewCheckBox3State( AParent: PControl; const Caption: String ): PControl;\r
{* |<#control>\r
   Creates check box control with 3 states. Special properties, methods,\r
   events:\r
   |#checkbox }\r
\r
//[NewRadiobox DECLARATION]\r
function NewRadiobox( AParent: PControl; const Caption: String ): PControl;\r
{* |<#control>\r
   Creates radio box control. Alternative radio items must have the\r
   same parent window (regardless of its kind, either groupbox (NewGroupbox),\r
   panel (NewPanel) or form itself). Following properties, methods and events\r
   are specially for radiobox controls:\r
   |#radiobox }\r
\r
//[NewEditbox DECLARATION]\r
function NewEditbox( AParent: PControl; Options: TEditOptions ): PControl;\r
{* |<#control>\r
   Creates edit box control. To create multiline edit box, similar to\r
   TMemo in VCL, apply eoMultiline in Options. Following properties, methods,\r
   events are special for edit controls:\r
   |#edit }\r
\r
//[NewRichEdit DECLARATION]\r
function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;\r
{* |<#control>\r
   Creates rich text edit control. A rich edit control is a window in which\r
   the user can enter and edit text. The text can be assigned character and\r
   paragraph formatting, and can include embedded OLE objects. Rich edit\r
   controls provide a programming interface for formatting text. However, an\r
   application must implement any user interface components necessary to make\r
   formatting operations available to the user.\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   Note: eoPassword, eoMultiline options have no effect for RichEdit control.\r
   Some operations are supersided with special versions of those, created\r
   especially for RichEdit, but in some cases it is necessary to use\r
   another properties and methods, specially designed for RichEdit (see\r
   methods and properties, which names are starting from RE_...).\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   Following properties, methods, events are special for edit controls:\r
   |#richedit\r
   }\r
\r
function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;\r
{* |<#control>\r
   Like NewRichEdit, but to work with older RichEdit control version 1.0\r
   (window class 'RichEdit' forced to use instead of 'RichEdit20A', even\r
   if library RICHED20.DLL found and loaded successfully). One more\r
   difference - OleInit is not called, so the most of OLE capabilities\r
   of RichEdit could not working. }\r
\r
//[NewListbox DECLARATION]\r
function NewListbox( AParent: PControl; Options: TListOptions ): PControl;\r
{* |<#control>\r
   Creates list box control. Following properties, methods and events are\r
   special for Listbox:\r
   |#listbox }\r
\r
//[NewCombobox DECLARATION]\r
function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;\r
{* |<#control>\r
   Creates new combo box control. Note, that it is not possible to align\r
   combobox caLeft or caRight: this can cause infinit recursion in the\r
   application.\r
   |<br>Following properties, methods and events are\r
   special for Combobox:\r
   |#combo }\r
\r
//[_NewCommonControl DECLARATION]\r
function _NewCommonControl( AParent: PControl; ClassName: PChar; Style: DWORD;\r
                            Ctl3D: Boolean; Actions: PCommandActions ): PControl;\r
\r
//[NewProgressbar DECLARATION]\r
function NewProgressbar( AParent: PControl ): PControl;\r
{* |<#control>\r
   Creates progress bar control. Following properties are special for\r
   progress bar:\r
   |#progressbar\r
   See also NewProgressEx. }\r
\r
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;\r
{* |<#control>\r
   Can create progress bar with smooth style (progress is not segmented\r
   onto bricks) or/and vertical progress bar - using additional parameter.\r
   For list of properties, suitable for progress bars, see NewProgressbar. }\r
\r
//[NewListVew DECLARATION]\r
function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;\r
  ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;\r
{* |<#control>\r
   Creates list view control. It is very powerful control, which can partially\r
   compensate absence of grid controls (in lvsDetail view mode). Properties,\r
   methods and events, special for list view control are:\r
   |#listview }\r
\r
//[NewTreeView DECLARATION]\r
function NewTreeView( AParent: PControl; Options: TTreeViewOptions;\r
                      ImgListNormal, ImgListState: PImageList ): PControl;\r
{* |<#control>\r
   Creates tree view control. See tree view methods and properties:\r
   |#treeview }\r
\r
//[NewTabControl DECLARATION]\r
function NewTabControl( AParent: PControl; Tabs: array of String; Options: TTabControlOptions;\r
         ImgList: PImageList; ImgList1stIdx: Integer ): PControl;\r
{* |<#control>\r
   Creates new tab control (like notebook). To place child control on a certain\r
   page of TabControl, use property Pages[ Idx ], for example:\r
   ! Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' );\r
   | &nbsp;&nbsp;&nbsp;\r
   To determine number of pages at run time, use property <D Count>;\r
   |<br> to determine which page is currently selected (or to change\r
   selection), use property <D CurrentIndex>;\r
   |<br> to feedback to switch between tabs assign your handler to OnSelChange\r
   event;\r
   |<br>Note, that by default, tab control is created with a border lowered to\r
   tab control's parent. To remove it, you can apply WS_EX_TRANSPARENT extended\r
   style (see TControl.ExStyle property), but painting of some child controls\r
   can be strange a bit in this case (no border drawing for edit controls was\r
   found, but not always...). You can also apply style WS_THICKFRAME (TControl.Style\r
   property) to make the border raised.\r
   |<br> Other methods and properties, suitable for tab control, are:\r
   |#tabcontrol }\r
\r
//[NewToolbar DECLARATION]\r
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;\r
                     Bitmap: HBitmap; Buttons: array of PChar;\r
                     BtnImgIdxArray: array of Integer ) : PControl;\r
{* |<#control>\r
   Creates toolbar control. Bitmap must contain images for all buttons\r
   excluding separators (defined by string '-' in Buttons array), otherwise\r
   last buttons will no have images at all. Image width for every button\r
   is assumed to be equal to Bitmap height (if last of "squares" has\r
   insufficient width, it will not be used). To define fixed buttons, use\r
   characters '+' or '-' as a prefix for button string (even empty). To\r
   create groups of (radio-)buttons, use also '!' follow '+' or '-'. (These rules\r
   are similar used in menu creation). To define drop down button, use (as\r
   first) prefix '^'. (Do not forget to set <D OnTBDropDown> event for this\r
   case). If You want to assign images to buttons not in the same order\r
   how these are placed in Bitmap (or You use system bitmap), define for every\r
   button (in BtnImgIdxArray array) indexes for every button (excluding\r
   separator buttons). Otherwise, it is possible to define index only for first\r
   button (e.g., [0]). It is also possible to change TBImages[ ] property\r
   for such purpose, or do the same in method TBSetBtnImgIdx).\r
   |<br>\r
   Following properties, methods and event are specially designed to work with\r
   toolbar control:\r
   |#toolbar\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   If your project uses Align property to align controls, this can conflict with\r
   toolbar native aligning. To solve such problem, place toolbar to parent panel,\r
   which has its own Align property assigned to desired value.\r
   |<br>\r
   To create toolbar with buttons, drawn from top to bottom, instead from left\r
   to right, combine caLeft / caRight in Align parameter and style tboWrapable\r
   when create toolbar. To adjust width of vertically aligned toolbar, it is\r
   possible to call ResizeParentLeft for it. E.g.:\r
\r
   ! P0 := NewPanel( W, esRaised ) .SetSize( 30, 0 ) .SetAlign( caLeft );\r
   ! //                            ^^^^^^^^^^^^^^^^^            //////\r
   !TB := NewToolbar( P0, caLeft, [ tboNoDivider, tboWrapable ], DWORD(-1),\r
   ! //                   //////                  ///////////\r
   !                  [ ' ', ' ', ' ', '-', ' ', ' ' ],\r
   !      [ STD_FILEOPEN ] ).ResizeParentRight;\r
   !//Note, that caLeft is *must*, and tboWrapable style too. SetSize for\r
   !//parent panel is not necessary, but only if ResizeParentRight is called\r
   !//than for Toolbar.\r
   |<br><br>\r
   One more note: if You create toolbar without text labels (passing ' ' for\r
   each button You add), include also option tboTextRight to fix incorrect\r
   sizing of buttons under Windows9x.\r
   }\r
\r
//[NewDateTimePicker DECLARATION]\r
function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions )\r
         : PControl;\r
{* |<#control>\r
   Creates date and time picker common control.\r
}\r
\r
\r
\r
{ -- Constructor for Image List objet -- }\r
\r
//[NewImageList DECLARATION]\r
function NewImageList( AOwner: PControl ): PImageList;\r
{* Constructor of TImageList object. Unlike other non-visual objects, image list\r
   can be parented by TControl object (but this does not *must*), and in that\r
   case it is destroyed automatically when its parent control is destroyed.\r
   Every control can have several TImageList objects, linked to a simple list.\r
   But if any TImageList object is destroyed, all following ones are destroyed\r
   too (at least, now I implemented it so). }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
//[TIMER]\r
type\r
  {++}(*TTimer = class;*){--}\r
  PTimer = {-}^{+}TTimer;\r
{ ----------------------------------------------------------------------\r
\r
                            TTimer object\r
\r
----------------------------------------------------------------------- }\r
//[TTimer DEFINITION]\r
  TTimer = object( TObj )\r
  {* Easy timer incapsulation object. Uses applet window to\r
     receive timer events. So, either assign your main form\r
     to Applet variable or create applet button object (and\r
     assign it to Applet) before enabling timer. }\r
  protected\r
    fHandle : Integer;\r
    fEnabled: Boolean;\r
    fInterval: Integer;\r
    fOnTimer: TOnEvent;\r
    procedure SetEnabled(const Value: Boolean); virtual;\r
    procedure SetInterval(const Value: Integer);\r
  protected\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* Destructor. }\r
  public\r
    property Handle : Integer read fHandle;\r
    {* Windows timer object handle. }\r
    property Enabled : Boolean read fEnabled write SetEnabled;\r
    {* True, is timer is on. Initially, always False. Before assigning True,\r
       make sure, that Applet global variable is assigned to applet object\r
       (NewApplet) or to form (NewForm). }\r
    property Interval : Integer read fInterval write SetInterval;\r
    {* Interval in milliseconds (1000 is default and means 1 second). }\r
    property OnTimer : TOnEvent read fOnTimer write fOnTimer;\r
    {* Event, which is called when time interval is over. }\r
  end;\r
//[END OF TTimer DEFINITION]\r
\r
//[NewTimer DECLARATION]\r
function NewTimer( Interval: Integer ): PTimer;\r
{* Constructs initially disabled timer with interval 1000 (1 second). }\r
\r
\r
//[MULTIMEDIA TIMER]\r
type\r
  {++}(*TMMTimer = class;*){--}\r
  PMMTimer = {-}^{+}TMMTimer;\r
\r
//[TMMTimer DEFINITION]\r
  TMMTimer = object( TTimer )\r
  {* Multimedia timer incapsulation object. Does not require Applet or special\r
     window to handle it. System creates a thread for each high resolution\r
     timer, so using many such objects can degrade total PC performance. }\r
  protected\r
    FResolution: Integer;\r
    FPeriodic: Boolean;\r
    procedure SetEnabled(const Value: Boolean); {-}virtual;{+}{++}(*override;*){--}\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
    property Resolution: Integer read FResolution write FResolution;\r
    {* Minimum timer resolution. The less the more accuracy (0 is exactly\r
       Interval milliseconds between timer shots). It is recommended to set\r
       this property greater to prevent entire system from reducing overhead.\r
       If you change this value, reset and then set Enabled again to apply\r
       changes. }\r
    property Periodic: Boolean read FPeriodic write FPeriodic;\r
    {* TRUE, if timer is periodic (default). Otherwise, timer is one-shot\r
       (set it Enabled every time in such case for each shot). If you change\r
       this property, reset and set Enabled property again to get effect. }\r
  end;\r
//[END OF TMMTimer DEFINITION]\r
\r
//[NewMMTimer DECLARATION]\r
function NewMMTimer( Interval: Integer ): PMMTimer;\r
{* Creates multimedia timer object. Initially, it has Resolution = 0,\r
   Periodic = TRUE and Enabled = FALSE. Do not forget also to assign your\r
   event handler to OnTimer to do something on timer shot. }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
//[DIRCHANGE]\r
type\r
  {++}(*TDirChange = class;*){--}\r
  PDirChange = {-}^{+}TDirChange;\r
  {* }\r
\r
  TOnDirChange = procedure (Sender: PDirChange; const Path: string) of object;\r
  {* Event type to define OnChange event for folder monitoring objects. }\r
\r
  TFileChangeFilters = (fncFileName, fncDirName, fncAttributes, fncSize,\r
      fncLastWrite, fncLastAccess, fncCreation, fncSecurity);\r
  {* Possible change monitor filters. }\r
  TFileChangeFilter = set of TFileChangeFilters;\r
  {* Set of filters to pass to a constructor of TDirChange object. }\r
\r
{ ----------------------------------------------------------------------\r
\r
                          TDirChange object\r
\r
----------------------------------------------------------------------- }\r
//[TDirChange DEFINITION]\r
  TDirChange = object(TObj)\r
  {* Object type to monitor changes in certain folder. }\r
  protected\r
    FOnChange: TOnDirChange;\r
    FHandle: THandle;\r
    FPath: string;\r
    FMonitor: PThread;\r
    function Execute( Sender: PThread ): Integer;\r
    procedure Changed;\r
  protected\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {*}\r
  public\r
    property Handle: THandle read FHandle;\r
    {* Handle of file change notification object. *}\r
    property Path: String read FPath; //write SetPath;\r
    {* Path to monitored folder (to a root, if tree of folders\r
       is under monitoring). }\r
  end;\r
//[END OF TDirChange DEFINITION]\r
\r
//[NewDirChangeNotifier DECLARATION]\r
function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;\r
                               WatchSubtree: Boolean; ChangeProc: TOnDirChange ): PDirChange;\r
{* Creates notification object TDirChangeNotifier. If something wrong (e.g.,\r
   passed directory does not exist), nil is returned as a result. When change\r
   is notified, ChangeProc is called always in main thread context.\r
   (Please note, that ChangeProc can not be nil).\r
   If empty filter is passed, default filter is used:\r
   [fncFileName..fncLastWrite]. }\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- TTrayIcon object -- }\r
//[TRAYICON]\r
\r
type\r
  TOnTrayIconMouse = procedure( Sender: PObj; Message : Word ) of object;\r
  {* Event type to be called when Applet receives a message from an icon,\r
     added to the taskbar tray. }\r
\r
  {++}(*TTrayIcon = class;*){--}\r
  PTrayIcon = {-}^{+}TTrayIcon;\r
{ ----------------------------------------------------------------------\r
\r
                TTrayIcon - icon in tray area of taskbar\r
\r
----------------------------------------------------------------------- }\r
//[TTrayIcon DEFINITION]\r
  TTrayIcon = object(TObj)\r
  {* Object to place (and change) a single icon onto taskbar tray. }\r
  protected\r
    FIcon: HIcon;\r
    FActive: Boolean;\r
    FTooltip: String;\r
    FOnMouse: TOnTrayIconMouse;\r
    FControl: PControl;\r
    fAutoRecreate: Boolean;\r
    FNoAutoDeactivate: Boolean;\r
    FWnd: HWnd;\r
    procedure SetIcon(const Value: HIcon);\r
    procedure SetActive(const Value: Boolean);\r
    procedure SetTrayIcon( const Value : DWORD );\r
    procedure SetTooltip(const Value: String);\r
    procedure SetAutoRecreate(const Value: Boolean);\r
  protected\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* Destructor. Use Free method instead (as usual). }\r
  public\r
    property Icon : HIcon read FIcon write SetIcon;\r
    {* Icon to be shown on taskbar tray. If not set, value of Active\r
       property has no effect. It is also possible to assign a value\r
       to Icon property after assigning True to Active to install\r
       icon first time or to replace icon with another one (e.g. to\r
       get animation effect).\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       Previously allocated icon (if any) is not deleted using\r
       DeleteObject. This is normal for icons, loaded from resource\r
       (e.g., by LoadIcon API call). But if icon was created (e.g.) by\r
       CreateIconIndirect, your code is responsible for destroying\r
       of it). }\r
    property Active : Boolean read FActive write SetActive;\r
    {* Set it to True to show assigned Icon on taskbar tray. Default\r
       is False. Has no effect if Icon property is not assigned.\r
       TrayIcon is deactivated automatically when Applet is finishing\r
       (but only if Applet window is used as a "parent" for tray\r
       icon object). }\r
    property Tooltip : String read FTooltip write SetTooltip;\r
    {* Tooltip string, showing automatically when mouse is moving\r
       over installed icon. Though "huge string" type is used, only\r
       first 63 characters are considered. Also note, that only in\r
       most recent versions of Windows multiline tooltips are supported. }\r
    property OnMouse : TOnTrayIconMouse read FOnMouse write FOnMouse;\r
    {* Is called then mouse message is taking place concerning installed\r
       icon. Only type of message can be obtained (e.g. WM_MOUSEMOVE,\r
       WM_LBUTTONDOWN etc.) }\r
    property AutoRecreate: Boolean read fAutoRecreate write SetAutoRecreate;\r
    {* If set to TRUE, auto-recreating of tray icon is proveded in case,\r
       when Explorer is restarted for some (unpredictable) reasons. Otherwise,\r
       your tray icon is disappeared forever, and if this is the single way\r
       to communicate with your application, the user nomore can achieve it. }\r
    property NoAutoDeactivate: Boolean read FNoAutoDeactivate write FNoAutoDeactivate;\r
    {* If set to true, tray icon is not removed from tray automatically on\r
       WM_CLOSE message receive by owner control. Set Active := FALSE in\r
       your code for such case before accepting closing the form. }\r
    property Wnd: HWnd read FWnd write FWnd;\r
    {* A window to use as a base window for tray icon messages. Overrides\r
       parent Control handle is assigned. Note, that if Wnd property used,\r
       message handling is not done automatically, and you should do this in\r
       your code, or at least for one tray icon object, call AttachProc2Wnd. }\r
    procedure AttachProc2Wnd;\r
    {* Call this method for a tray icon object in case if Wnd used rather then\r
       control. It is enough to call this method once for each Wnd used, even\r
       if several other tray icons are also based on the same Wnd. See also\r
       DetachProc2Wnd method. }\r
    procedure DetachProc2Wnd;\r
    {* Call this method to detach window procedure attached via AttachProc2Wnd.\r
       Do it once for a Wnd, used as a base to handle tray icon messages.\r
       Caution! If you do not call this method before destroying Wnd, the\r
       application will not functioning normally. }\r
  end;\r
  {* When You create invisible application, which should be represented by\r
     only the tray icon, prepare a handle for the window, resposible for\r
     messages handling. Remember, that window handle is created automatically\r
     only when a window is showing first time. If window's property Visible is\r
     set to False, You should to call CreateWindow manually.\r
     <br>\r
     There is a known bug exist with similar invisible tray-iconized applications.\r
     When a menu is activated in response to tray mouse event, if there was\r
     not active window, belonging to the application, the menu is not disappeared\r
     when mouse is clicked anywhere else. This bug is occure in Windows9x/ME.\r
     To avoid it, activate first your form window. This last window shoud have\r
     status visible (but, certainly, there are no needs to place it on visible\r
     part of screen - change its position, so it will not be visible for user,\r
     if You wish).\r
     <br>\r
     Also, to make your application "invisible" but until special event is occure,\r
     use Applet separate from the main form, and make for both Visible := False.\r
     This allows for You to make your form visible any time You wish, and without\r
     making application button visible if You do not wish.\r
  }\r
  {= Êîãäà Âû äåëàåòå íåâèäèìîå ïðèëîæåíèå, êîòîðîå äîëæíî áûòü ïðåäñòàâëåíî\r
     òîëüêî èêîíêîé â òðåå, îáåñïå÷üòå íåíóëåâîé Handle äëÿ îêíà, îòâå÷àþùåãî\r
     çà îáðàáîòêó ñîîáùåíèé. Ïîìíèòå, ÷òî Handle îêíà ñîçäàåòñÿ àâòîìàòè÷åñêè\r
     òîëüêî â òîò ìîìåíò, êîãäà îíî äîëæíî ïîÿâèòüñÿ â ïåðâûé ðàç. Åñëè ñâîéñòâî\r
     îêíà Visible óñòàíîâëåíî â FALSE, íåîáõîäèìî âûçâàòü CreateWindow ñàìîñòîÿòåëüíî.\r
     <br>\r
     Ñóùåñòâóåò èçâåñòíûé BUG ñ ïîäîáíûìè íåâèäèìûìè ìèíèìèçèðîâàííûìè â òðåé\r
     ïðèëîæåíèÿìè. Êîãäà â îòâåò íà ñîáûòèå ìûøè àêòèâèçèðâàíî âûïàäàþùåå ìåíþ,\r
     îíî íå èñ÷åçàåò ïî ùåë÷êó ìûøè âíå ýòîãî ìåíþ. Ïðîèñõîäèò ýòî â Windows9x/ME.\r
     ÷òîáû ðåøèòü ýòó ïðîáëåìó, ñíà÷àëà àêòèâèçèðóéòå ñâîå îêíî (ôîðìó). Ýòî îêíî\r
     äîëæíî áûòü âèäèìûì (íî, êîíå÷íî, åãî ìîæíî ðàçìåñòèòü âíå ïðåäåëîâ âèäèìîé\r
     ÷àñòè ýêðàíà, òàê ÷òî ïîëüçîâàòåëþ åãî âèäíî íå áóäåò).\r
     <br>\r
     Òàê æå, ÷òîáû ñäåëàòü ïðèëîæåíèå íåâèäèìûì, ïî êðàéíåé ìåðå, ïîêà ýòî íå\r
     ïîòðåáóåòñÿ, èñïîëüçóéòå îòäåëüíûé ïðåäñòàâèòåëü êëàññà TControl - ãëîáàëüíóþ\r
     ïåðåìåííóþ Applet, è ïðèñâîéòå FALSE åå ñâîéñòâó Visible.\r
  }\r
//[END OF TTrayIcon DEFINITION]\r
\r
//[NewTrayIcon DECLARATION]\r
function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon;\r
{* Constructor of TTrayIcon object. Pass main form or applet as Wnd\r
   parameter. }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
//[JUST ONE]\r
{ -- JustOne -- }\r
\r
type\r
  TOnAnotherInstance = procedure( const CmdLine: String ) of object;\r
  {* Event type to use in JustOneNotify function. }\r
\r
function JustOne( Wnd: PControl; const Identifier : String ) : Boolean;\r
{* Returns True, if this is a first instance. For all other instances\r
   (application is already running), False is returned. }\r
\r
function JustOneNotify( Wnd: PControl; const Identifier : String;\r
                        const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;\r
{* Returns True, if this is a first instance. For all other instances\r
   (application is already running), False is returned. If handler\r
   aOnAnotherInstance passed, it is called (in first instance) every time\r
   when another instance of an application is started, receiving command\r
   line used to run it. }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- string (mainly) utility procedures and functions. -- }\r
\r
//[Message Box DECLARATIONS]\r
function MsgBox( const S: String; Flags: DWORD ): DWORD;\r
{* Displays message box with the same title as Applet.Caption. If applet\r
   is not running, and Applet global variable is not assigned, caption\r
   'Error' is displayed (but actually this is not an error - the system\r
   does so, if nil is passed as a title).\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   Returns ID_... result (correspondently to flags passed (MB_OK, MBYESNO,\r
   etc. -> ID_OK, ID_YES, ID_NO, etc.) }\r
procedure MsgOK( const S: String );\r
{* Displays message box with the same title as Applet.Caption (or 'Error',\r
   if Applet is not running). }\r
function ShowMsg( const S: String; Flags: DWORD ): DWORD;\r
{* Displays message box like MsgBox, but uses Applet.Handle as a parent\r
   (so the message has no button on a task bar). }\r
procedure ShowMessage( const S: String );\r
{* Like ShowMsg, but has only styles MB_OK and MB_SETFOREGROUND. }\r
procedure ShowMsgModal( const S: String );\r
{* This message function can be used out of a message loop (e.g., after\r
   finishing the application). It is always modal.\r
      Actually, a form with word-wrap label (decorated as borderless edit\r
   box with btnFace color) and with OK button is created and shown modal.\r
   When a dialog is called from outside message loop, caption 'Information'\r
   is always displayed.\r
   Dialog form is automatically resized vertically to fit message text\r
   (but until screen height is achieved) and shown always centered on\r
   screen. The width is fixed (400 pixels).\r
   |<br>\r
   Do not use this function outside the message loop for case, when the\r
   Applet variable is not used in an application. }\r
function ShowQuestion( const S: String; Answers: String ): Integer;\r
{* Modal dialog like ShowMsgModal. It is based on KOL form, so it can\r
   be called also out of message loop, e.g. after finishing the\r
   application. Also, this function *must* be used in MDI applications\r
   in place of any dialog functions, based on MessageBox.\r
   |<br>\r
   The second parameter should be empty string or several possible\r
   answers separated by '/', e.g.: 'Yes/No/Cancel'. Result is\r
   a number answered, starting from 1. For example, if  'Cancel'\r
   was pressed, 3 will be returned.\r
   |<br>\r
   User can also press ESCAPE key, or close modal dialog. In such case\r
   -1 is returned. }\r
function ShowQuestionEx( const S: String; Answers: String; CallBack: TOnEvent ): Integer;\r
{* Like ShowQuestion, but with CallBack function, called just before showing\r
   the dialog. }\r
procedure SpeakerBeep( Freq: Word; Duration: DWORD );\r
{* On Windows NT, calls Windows.Beep. On Windows 9x, produces beep on speaker\r
   of desired frequency during given duration time (in milliseconds). }\r
\r
{++}(*\r
function FormatMessage(dwFlags: DWORD; lpSource: Pointer; dwMessageId: DWORD; dwLanguageId: DWORD;\r
  lpBuffer: PChar; nSize: DWORD; Arguments: Pointer): DWORD; stdcall;\r
*){--}\r
function SysErrorMessage(ErrorCode: Integer): string;\r
{* Creates and returns a string containing formatted system error message.\r
   It is possible then to display this message or write it to a log\r
   file, e.g.:\r
   !  ShowMsg( SysErrorMessage( GetLastError ) );\r
\r
\r
\r
   |&R=<a name="%0"></a><font color=#FF8040><h1>%0</h1></font>\r
   <R 64-bit integer numbers>\r
}\r
//[I64 TYPE]\r
type\r
  I64 = record\r
  {* 64 bit integer record. Use it and correspondent functions below in KOL\r
     projects to avoid dependancy from Delphi version (earlier versions of\r
     Delphi had no Int64 type). }\r
    Lo, Hi: DWORD;\r
  end;\r
  PI64 = ^I64;\r
  {* }\r
\r
\r
{-}\r
{$IFNDEF _D4orHigher}\r
  Int64 = I64;\r
  PInt64 = PI64;\r
{$ENDIF}\r
\r
function MakeInt64( Lo, Hi: DWORD ): I64;\r
{* }\r
function Int2Int64( X: Integer ): I64;\r
{* }\r
procedure IncInt64( var I64: I64; Delta: Integer );\r
{* I64 := I64 + Delta; }\r
procedure DecInt64( var I64: I64; Delta: Integer );\r
{* I64 := I64 - Delta; }\r
function Add64( const X, Y: I64 ): I64;\r
{* Result := X + Y; }\r
function Sub64( const X, Y: I64 ): I64;\r
{* Result := X - Y; }\r
function Neg64( const X: I64 ): I64;\r
{* Result := -X; }\r
function Mul64i( const X: I64; Mul: Integer ): I64;\r
{* Result := X * Mul; }\r
function Div64i( const X: I64; D: Integer ): I64;\r
{* Result := X div D; }\r
function Mod64i( const X: I64; D: Integer ): Integer;\r
{* Result := X mod D; }\r
function Sgn64( const X: I64 ): Integer;\r
{* Result := sign( X ); i.e.:\r
   |<br>\r
   if X < 0 then -1\r
   |<br>\r
   if X = 0 then 0\r
   |<br>\r
   if X > 0 then 1 }\r
function Cmp64( const X, Y: I64 ): Integer;\r
{* Result := sign( X - Y ); i.e.\r
   |<br>\r
   if X < Y then -1\r
   |<br>\r
   if X = Y then 0\r
   |<br>\r
   if X > Y then 1 }\r
function Int64_2Str( X: I64 ): String;\r
{* }\r
function Str2Int64( const S: String ): I64;\r
{* }\r
function Int64_2Double( const X: I64 ): Double;\r
{* }\r
function Double2Int64( D: Double ): I64;\r
{*\r
\r
\r
\r
  <R Floating point numbers>\r
}\r
\r
const\r
  NAN = 0.0 / 0.0;\r
{+}\r
  {++}(*const NAN = 1e-100;*){--}\r
\r
\r
function IsNan(const AValue: Double): Boolean;\r
{* Checks is an argument passed is NAN. }\r
\r
function IntPower(Base: Extended; Exponent: Integer): Extended;\r
{* Result := Base ^ Exponent; }\r
\r
//[String<->Double DECLARATIONS]\r
function Str2Double( const S: String ): Double;\r
{* }\r
\r
function Double2Str( D: Double ): String;\r
{* }\r
function Extended2Str( E: Extended ): String;\r
{* }\r
\r
function Double2StrEx( D: Double ): String;\r
{* experimental, do not use }\r
\r
function TruncD( D: Double ): Double;\r
{* Result := trunc( D ) as Double;\r
|<hr>\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
  <R Small bit arrays (max 32 bits in array)>\r
  See also TBits object.\r
}\r
\r
//[SMALL BIT ARRAYS DECLARATIONS]\r
function GetBits( N: DWORD; first, last: Byte ): DWord;\r
{* Retuns bits straing from <first> and to <last> inclusively. }\r
function GetBitsL( N: DWORD; from, len: Byte ): DWord;\r
{* Retuns len bits starting from index <from>.\r
|<hr>\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
  <R Arithmetics, geometry and other utility functions>\r
\r
  See also units KolMath.pas, CplxMath.pas and Err.pas.\r
}\r
//[MulDiv DECLARATION]\r
{$IFNDEF FPC}\r
function MulDiv( A, B, C: Integer ): Integer;\r
{* Returns A * B div C. Small and fast. }\r
{$ENDIF}\r
\r
//[TMethod TYPE]\r
type\r
///////////////////////////////////////////\r
{$ifndef _D6orHigher}                    //\r
///////////////////////////////////////////\r
   TMethod = packed record\r
   {* Is defined here because using of VCL classes.pas unit is\r
      not recommended in XCL. This record type is used often\r
      to set/access event handlers, referring to a procedure\r
      of object (usually to set such event to an ordinal\r
      procedure setting Data field to nil. }\r
    Code: Pointer; // Pointer to method code.\r
    {* If used to fake assigning to event handler of type 'procedure\r
       of object' with ordinal procedure pointer, use symbol '@'\r
       before method:\r
       |<br>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<font face="Courier"><b>\r
       |    Method.Code := @MyProcedure;\r
       |</b></font> }\r
    Data: Pointer; // Pointer to object, owning the method.\r
    {* To fake event of type 'procedure of object' with setting it to\r
       ordinal procedure assign here NIL; }\r
   end;\r
   {* When assigning TMethod record to event handler, typecast it with\r
      desired event type, e.g.:\r
      |<br>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<font face="Courier"><b>\r
      |     SomeObject.OnSomeEvent := TOnSomeEvent( Method );\r
      |</b></font><br> }\r
///////////////////////////////////////////\r
{$endif}                                 //\r
///////////////////////////////////////////\r
   PMethod = ^TMethod;\r
   {* }\r
\r
   function MakeMethod( Data, Code: Pointer ): TMethod;\r
   {* Help function to construct TMethod record. Can be useful to\r
      assign regular type procedure/function as event handler for\r
      event, defined as object method (do not forget, that in that\r
      case it must have first dummy parameter to replace @Self,\r
      passed in EAX to methods of object). }\r
\r
//[Rectangles&Points DECLARATIONS]\r
   function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; stdcall;\r
   {* Use it instead of VCL Rect function }\r
   function RectsEqual( const R1, R2: TRect ): Boolean;\r
   {* Returns True if rectangles R1 and R2 have the same bounds }\r
   function RectsIntersected( const R1, R2: TRect ): Boolean;\r
   {* Returns TRUE if rectangles R1 and R2 have at least one common point.\r
      Note, that right and bottom bounds of rectangles are not their part,\r
      so, if such points are lying on that bounds, FALSE is returned. }\r
   function PointInRect( const P: TPoint; const R: TRect ): Boolean;\r
   {* Returns True if point P is located in rectangle R (including\r
      left and top bounds but without right and bottom bounds of the\r
      rectangle). }\r
   function MakePoint( X, Y: Integer ): TPoint;\r
   {* Use instead of VCL function Point }\r
//[MakeFlags DECLARATION]\r
   function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;\r
   {* }\r
\r
  function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange;\r
  {* Returns TDateTimeRange from two TDateTime bounds. }\r
\r
//[Integer FUNCTIONS DECLARATIONS]\r
   procedure Swap( var X, Y: Integer );\r
   {* exchanging values }\r
   function Min( X, Y: Integer ): Integer;\r
   {* minimum of two integers }\r
   function Max( X, Y: Integer ): Integer;\r
   {* maximum of two integers }\r
   function Abs( X: Integer ): Integer;\r
   {* absolute value }\r
   function Sgn( X: Integer ): Integer;\r
   {* sign of X: if X < 0, -1 is returned, if > 0, then +1, otherwise 0. }\r
   function iSqrt( X: Integer ): Integer;\r
   {* square root\r
   |<hr>\r
\r
\r
\r
\r
  <R String to number and number to string conversions>\r
}\r
//[Integer<->String DECLARATIONS]\r
function Int2Hex( Value : DWord; Digits : Integer ) : String;\r
{* Converts integer Value into string with hex number. Digits parameter\r
   determines minimal number of digits (will be completed by adding\r
   necessary number of leading zeroes). }\r
function Int2Str( Value : Integer ) : String;\r
{* Obvious. }\r
function UInt2Str( Value: DWORD ): String;\r
{* The same as Int2Str, but for unsigned integer value. }\r
function Int2StrEx( Value, MinWidth: Integer ): String;\r
{* Like Int2Str, but resulting string filled with leading spaces to provide\r
   at least MinWidth characters. }\r
function Int2Rome( Value: Integer ): String;\r
{* Represents number 1..8999 to Rome numer. }\r
function Int2Ths( I : Integer ) : String;\r
{* Converts integer into string, separating every three digits from each\r
   other by ',' character. (Convert to thousands). }\r
function Int2Digs( Value, Digits : Integer ) : String;\r
{* Converts integer to string, inserting necessary number of leading zeroes\r
   to provide desired length of string, given by Digits parameter. If\r
   resulting string is greater then Digits, string is not truncated anyway. }\r
function Num2Bytes( Value : Double ) : String;\r
{* Converts double float to string, considering it as a bytes count.\r
   If Value is sufficiently large, number is represented in kilobytes (with\r
   following letter K), or in megabytes (M), gigabytes (G) or terabytes (T).\r
   Resulting string number is truncated to two decimals (.XX) or to one (.X),\r
   if the second is 0. }\r
function S2Int( S: PChar ): Integer;\r
{* Converts null-terminated string to Integer. Scanning stopped when any\r
   non-digit character found. Even empty string or string not containing\r
   valid integer number silently converted to 0. }\r
function Str2Int(const Value : String) : Integer;\r
{* Converts string to integer. First character, which can not be\r
   recognized as a part of number, regards as a separator. Even\r
   empty string or string without number silently converted to 0. }\r
function Hex2Int( const Value : String) : Integer;\r
{* Converts hexadecimal number to integer. Scanning is stopped\r
   when first non-hexadicimal character is found. Leading dollar ('$')\r
   character is skept (if present). Minus ('-') is not concerning as\r
   a sign of number and also stops scanning.}\r
function cHex2Int( const Value : String) : Integer;\r
{* As Hex2Int, but also checks for leading '0x' and skips it. }\r
function Octal2Int( const Value: String ) : Integer;\r
{* Converts octal number to integer. Scanning is stopped on first\r
   non-octal digit (any char except 0..7). There are no checking if\r
   there octal numer in the parameter. If the first char is not octal\r
   digit, 0 is returned. }\r
function Binary2Int( const Value: String ) : Integer;\r
{* Converts binary number to integer. Like Octal2Int, but only digits\r
   0 and 1 are allowed. }\r
{$IFNDEF _FPC}\r
function Format( const fmt: string; params: array of const ): String;\r
{* Uses API call to wvsprintf, so does not understand extra formats,\r
   such as floating point, date/time, currency conversions. See list of\r
   available formats in win32.hlp (topic wsprintf).\r
|<hr>\r
\r
\r
\r
   <R Working with null-terminated and ansi strings>\r
}\r
{$ENDIF _FPC}\r
//[String FUNCTIONS DECLARATIONS]\r
function StrComp(const Str1, Str2: PChar): Integer;\r
{* Compares two strings fast. -1: Str1<Str2; 0: Str1=Str2; +1: Str1>Str2 }\r
function StrComp_NoCase(const Str1, Str2: PChar): Integer;\r
{* Compares two strings fast without case sensitivity.\r
   Returns: -1 when Str1<Str2; 0 when Str1=Str2; +1 when Str1>Str2 }\r
function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;\r
{* Compare two strings (fast). Terminating 0 is not considered, so if\r
   strings are equal, comparing is continued up to MaxLen bytes.\r
   Since this, pass minimum of lengths as MaxLen. }\r
function StrLComp_NoCase(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;\r
{* Compare two strings fast without case sensitivity.\r
   Terminating 0 is not considered, so if strings are equal,\r
   comparing is continued up to MaxLen bytes.\r
   Since this, pass minimum of lengths as MaxLen. }\r
function StrCopy( Dest, Source: PChar ): PChar;\r
{* Copy source string to destination (fast). Pointer to Dest is returned. }\r
function StrCat( Dest, Source: PChar ): PChar;\r
{* Append source string to destination (fast). Pointer to Dest is returned. }\r
function StrLen(const Str: PChar): Cardinal;\r
{* StrLen returns the number of characters in Str, not counting the null\r
  terminator. }\r
function StrScanLen(Str: PChar; Chr: Char; Len: Integer): PChar;\r
{* Fast scans string Str of length Len searching character Chr.\r
   Pointer to a character next to found or to Str[Len] (if no one found)\r
   is returned. }\r
function StrScan(Str: PChar; Chr: Char): PChar;\r
{* Fast search of given character in a string. Pointer to found character\r
   (or nil) is returned. }\r
function StrRScan(const Str: PChar; Chr: Char): PChar;\r
{* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr\r
  does not occur in Str, StrRScan returns NIL. The null terminator is\r
  considered to be part of the string. }\r
function StrIsStartingFrom( Str, Pattern: PChar ): Boolean;\r
{* Returns True, if string Str is starting from Pattern, i.e. if\r
   Copy( Str, 1, StrLen( Pattern ) ) = Pattern. Str must not be nil! }\r
function StrIsStartingFromNoCase( Str, Pattern: PChar ): Boolean;\r
{* Like StrIsStartingFrom above, but without case sensitivity. }\r
function TrimLeft(const S: string): string;\r
{* Removes spaces, tabulations and control characters from the starting\r
   of string S. }\r
function TrimRight(const S: string): string;\r
{* Removes spaces, tabulates and other control characters from the\r
   end of string S. }\r
function Trim( const S : string): string;\r
{* Makes TrimLeft and TrimRight for given string. }\r
function RemoveSpaces( const S: String ): String;\r
{* Removes all characters less or equal to ' ' in S and returns it. }\r
procedure Str2LowerCase( S: PChar );\r
{* Converts null-terminated string to lowercase (inplace). }\r
function LowerCase(const S: string): string;\r
{* Obvious. }\r
function UpperCase(const S: string): string;\r
{* Obvious. }\r
function AnsiUpperCase(const S: string): string;\r
{* Obvious. }\r
function AnsiLowerCase(const S: string): string;\r
{* Obvious. }\r
{$IFNDEF _D2}\r
{$IFNDEF _FPC}\r
function WAnsiUpperCase(const S: WideString): WideString;\r
{* Obvious. }\r
function WAnsiLowerCase(const S: WideString): WideString;\r
{* Obvious. }\r
{$ENDIF _FPC}\r
{$ENDIF _D2}\r
function AnsiCompareStr(const S1, S2: string): Integer;\r
{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare\r
  operation is controlled by the current Windows locale. The return value\r
  is the same as for CompareStr. }\r
function _AnsiCompareStr(S1, S2: PChar): Integer;\r
{* The same, but for PChar ANSI strings }\r
function AnsiCompareStrNoCase(const S1, S2: string): Integer;\r
{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare\r
  operation is controlled by the current Windows locale. The return value\r
  is the same as for CompareStr. }\r
function _AnsiCompareStrNoCase(S1, S2: PChar): Integer;\r
{* The same, but for PChar ANSI strings }\r
function AnsiCompareText( const S1, S2: String ): Integer;\r
{* }\r
\r
{$IFNDEF _FPC}\r
function LStrFromPWCharLen(Source: PWideChar; Length: Integer): String;\r
{* from Delphi5 - because D2 does not contain it. }\r
function LStrFromPWChar(Source: PWideChar): String;\r
{* from Delphi5 - because D2 does not contain it. }\r
{$ENDIF _FPC}\r
\r
function CopyEnd( const S : String; Idx : Integer ) : String;\r
{* Returns copy of source string S starting from Idx up to the end of\r
   string S. Works correctly for case, when Idx > Length( S ) (returns\r
   empty string for such case). }\r
function CopyTail( const S : String; Len : Integer ) : String;\r
{* Returns last Len characters of the source string. If Len > Length( S ),\r
   entire string S is returned. }\r
procedure DeleteTail( var S : String; Len : Integer );\r
{* Deletes last Len characters from string. }\r
function IndexOfChar( const S : String; Chr : Char ) : Integer;\r
{* Returns index of given character (1..Length(S)), or\r
   -1 if a character not found. }\r
function IndexOfCharsMin( const S, Chars : String ) : Integer;\r
{* Returns index (in string S) of those character, what is taking place\r
   in Chars string and located nearest to start of S. If no such\r
   characters in string S found, -1 is returned. }\r
{$IFNDEF _D2}\r
{$IFNDEF _FPC}\r
function IndexOfWideCharsMin( const S, Chars : WideString ) : Integer;\r
{* Returns index (in wide string S) of those wide character, what\r
   is taking place in Chars wide string and located nearest to start of S.\r
   If no such characters in string S found, -1 is returned. }\r
{$ENDIF _FPC}\r
{$ENDIF _D2}\r
\r
function IndexOfStr( const S, Sub : String ) : Integer;\r
{* Returns index of given substring in source string S. If found,\r
   1..Length(S)-Length(Sub), if not found, -1. }\r
function Parse( var S : String; const Separators : String ) : String;\r
{* Returns first characters of string S, separated from others by\r
   one of characters, taking place in Separators string, assigning\r
   a tail of string (after found separator) to source string. If\r
   no separator characters found, source string S is returned, and\r
   source string itself becomes empty. }\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
function WParse( var S : WideString; const Separators : WideString ) : WideString;\r
{* Returns first wide characters of wide string S, separated from others\r
   by one of wide characters, taking place in Separators wide string,\r
   assigning a tail of wide string (following found separator) to the\r
   source one. If there are no separator characters found, source wide\r
   string S is returned, and source wide string itself becomes empty. }\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
function ParsePascalString( var S : String; const Separators : String ) : String;\r
{* Returns first characters of string S, separated from others by\r
   one of characters, taking place in Separators string, assigning\r
   a tail of string (after the found separator) to source string. If\r
   there are no separator characters found, the source string S is returned,\r
   and the source string itself becomes empty. Additionally: if the first (after\r
   a blank space) is the quote "'" or '#', pascal string is assumung first\r
   and is converted to usual string (without quotas) before analizing\r
   of other separators. }\r
function String2PascalStrExpr( const S : String ) : String;\r
{* Converts string to Pascal-like string expression (concatenation of\r
   strings with quotas and characters with leading '#'). }\r
function StrEq( const S1, S2 : String ) : Boolean;\r
{* Returns True, if LowerCase(S1) = LowerCase(S2). I.e., if strings\r
   are equal to each other without caring of characters case sensitivity\r
   (ASCII only). }\r
function AnsiEq( const S1, S2 : String ) : Boolean;\r
{* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI\r
   stringsare equal to each other without caring of characters case\r
   sensitivity. }\r
{$IFNDEF _D2}\r
{$IFNDEF _FPC}\r
function WAnsiEq( const S1, S2 : WideString ) : Boolean;\r
{* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI\r
   stringsare equal to each other without caring of characters case\r
   sensitivity. }\r
{$ENDIF _FPC}\r
{$ENDIF _D2}\r
\r
function StrIn( const S : String; const A : array of String ) : Boolean;\r
{* Returns True, if S is "equal" to one of strings, taking place\r
   in A array. To check equality, StrEq function is used, i.e.\r
   comaprison is taking place without case sensitivity. }\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
function WStrIn( const S : WideString; const A : array of WideString ) : Boolean;\r
{* Returns True, if S is "equal" to one of strings, taking place\r
   in A array. To check equality, WAnsiEq function is used, i.e.\r
   comaprison is taking place without case sensitivity. }\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
function StrIs( const S : String; const A : array of String; var Idx: Integer ) : Boolean;\r
{* Returns True, if S is "equal" to one of strings, taking place\r
   in A array, and in such Case Idx also is assigned to an index of A element\r
   equal to S. To check equality, StrEq function is used, i.e.\r
   comaprison is taking place without case sensitivity. }\r
function IntIn( Value: Integer; const List: array of Integer ): Boolean;\r
{* Returns TRUE, if Value is found in a List. }\r
function _StrSatisfy( S, Mask : PChar ) : Boolean;\r
{* }\r
function _2StrSatisfy( S, Mask: PChar ): Boolean;\r
{* }\r
function StrSatisfy( const S, Mask : String ) : Boolean;\r
{* Returns True, if S is satisfying to a given Mask (which can contain\r
   wildcard symbols '*' and '?' interpeted correspondently as 'any\r
   set of characters' and 'single any character'. If there are no\r
   such wildcard symbols in a Mask, result is True only if S is maching\r
   to Mask string.) }\r
function StrReplace( var S: String; const From, ReplTo: String ): Boolean;\r
{* Replaces first occurance of From to ReplTo in S, returns True,\r
   if pattern From was found and replaced. }\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
function WStrReplace( var S: WideString; const From, ReplTo: WideString ): Boolean;\r
{* Replaces first occurance of From to ReplTo in S, returns True,\r
   if pattern From was found and replaced. See also function StrReplace.\r
   This function is not available in Delphi2 (this version of Delphi\r
   does not support WideString type). }\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
function StrRepeat( const S: String; Count: Integer ): String;\r
{* Repeats given string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
function WStrRepeat( const S: WideString; Count: Integer ): WideString;\r
{* Repeats given wide string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
procedure NormalizeUnixText( var S: String );\r
{* In the string S, replaces all occurances of character #10 (without leading #13)\r
   to the character #13. }\r
\r
{$IFNDEF _FPC}\r
function WStrLen( W: PWideChar ): Integer;\r
{* Returns Length of null-terminated Unicode string. }\r
procedure WStrCopy( Dest, Src: PWideChar );\r
{* Copies null-terminated Unicode string (terminated null also copied). }\r
function WStrCmp( W1, W2: PWideChar ): Integer;\r
{* Compares two null-terminated Unicode strings. }\r
{$ENDIF _FPC}\r
\r
function StrPCopy(Dest: PChar; const Source: string): PChar;\r
{* Copyes Pascal-style string into null-terminaed one. }\r
function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;\r
{* Copyes first MaxLen characters of Pascal-style string into\r
   null-terminated one. }\r
\r
function DelimiterLast( const Str, Delimiters: String ): Integer;\r
{* Returns index of the last of delimiters given by same named parameter\r
   among characters of Str. If there are no delimiters found, length of\r
   Str is returned. This function is intended mainly to use in filename\r
   parsing functions. }\r
function __DelimiterLast( Str, Delimiters: PChar ): PChar;\r
{* Returns address of the last of delimiters given by Delimiters parameter\r
   among characters of Str. If there are no delimeters found, position of\r
   the null terminator in Str is returned. This function is intended\r
   mainly to use in filename parsing functions. }\r
function SkipSpaces( P: PChar ): PChar;\r
{* Skips all characters #1..' ' in a string.\r
}\r
{$IFDEF F_P}\r
function DummyStrFun( const S: String ): String;\r
{$ENDIF}\r
\r
\r
//[Memory FUNCTIONS DECLARATIONS]\r
function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;\r
{* Fast compare of two memory blocks. }\r
function AllocMem( Size : Integer ) : Pointer;\r
{* Allocates global memory and unlocks it. }\r
procedure DisposeMem( var Addr : Pointer );\r
{* Locks global memory block given by pointer, and frees it.\r
   Does nothing, if the pointer is nil.\r
   |<hr>\r
\r
  <R Text in clipboard operations>\r
}\r
\r
//[clipboard FUNCTIONS DECLARATIONS]\r
function Clipboard2Text: String;\r
{* If clipboard contains text, this function returns it for You. }\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
function Clipboard2WText: WideString;\r
{* If clipboard contains text, this function returns it for You (as Unicode string). }\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
function Text2Clipboard( const S: String ): Boolean;\r
{* Puts given string to a clipboard. }\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
function WText2Clipboard( const WS: WideString ): Boolean;\r
{* Puts given Unicode string to a clipboard.\r
|<hr>\r
}\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
\r
\r
//[Mnemonics FUNCTIONS DECLARATIONS]\r
var SearchMnemonics: function ( const S: String ): String\r
    = {$IFDEF F_P} DummyStrFun {$ELSE} UpperCase {$ENDIF};\r
    MnemonicsLocale: Integer;\r
\r
procedure SupportAnsiMnemonics( LocaleID: Integer );\r
{* Provides encoding to work with given locale. Call this global function to\r
   extend TControl.SupportMnemonics capability (also should be called for a form\r
   or for Applet variable).\r
\r
\r
\r
\r
\r
   <R Date and time handling>\r
}\r
//[TDateTime TYPE DEFINITION]\r
type\r
  //TDateTime = Double; // well, it is already defined so in System.pas\r
  {* Basic date and time type. Integer part represents year and days (as is,\r
     i.e. 1-Jan-2000 is representing by value 730141, which is a number of\r
     days from 1-Jan-0001 to 1-Jan-2000 inclusively). Fractional part is\r
     representing hours, minutes, seconds and milliseconds of a day\r
     proportionally (like in VCL TDateTime type, e.g. 0.5 = 12:00, 0.25 = 6:00,\r
     etc.). }\r
\r
  PDayTable = ^TDayTable;\r
  TDayTable = array[1..12] of Word;\r
\r
  TDateFormat = ( dfShortDate, dfLongDate );\r
  {* Date formats available to use in formatting date/time to string. }\r
  TTimeFormatFlag = ( tffNoMinutes, tffNoSeconds, tffNoMarker, tffForce24 );\r
  {* Additional flags, used for formatting time. }\r
  TTimeFormatFlags = Set of TTimeFormatFlag;\r
  {* Set of flags, used for formatting time. }\r
\r
const\r
  MonthDays: array [Boolean] of TDayTable =\r
    ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),\r
     (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31));\r
  {* The MonthDays array can be used to quickly find the number of\r
    days in a month:  MonthDays[IsLeapYear(Y), M].      }\r
\r
  SecsPerDay = 24 * 60 * 60;\r
  {* Seconds per day. }\r
  MSecsPerDay = SecsPerDay * 1000;\r
  {* Milliseconds per day. }\r
\r
  VCLDate0 = 693594;\r
  {* Value to convert VCL "date 0" to KOL "date 0" and back.\r
     This value corresponds to 30-Dec-1899, 0:00:00. So,\r
     to convert VCL date to KOL date, just subtract this\r
     value from VCL date. And to convert back from KOL date\r
     to VCL date, add this value to KOL date.}\r
\r
{++}(*\r
procedure GetLocalTime(var lpSystemTime: TSystemTime); stdcall;\r
procedure GetSystemTime(var lpSystemTime: TSystemTime); stdcall;\r
*){--}\r
\r
//[Date&Time FUNCTIONS DECLARATIONS]\r
function Now : TDateTime;\r
{* Returns local date and time on running PC. }\r
function Date: TDateTime;\r
{* Returns todaylocal date. }\r
procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD );\r
{* Decodes date. }\r
procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD );\r
{* Decodes date. }\r
function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean;\r
{* Encodes date. }\r
function CompareSystemTime(const D1, D2 : TSystemTime) : Integer;\r
{* Compares to TSystemTime records. Returns -1, 0, or 1 if, correspondantly,\r
   D1 < D2, D1 = D2 and D1 > D2. }\r
procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer );\r
{* Increases/decreases day in TSystemTime record onto given days count\r
   (can be negative). }\r
procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer );\r
{* Increases/decreases month number in TSystemTime record onto given\r
   months count (can be negative). Correct result is not garantee if\r
   day number is incorrect for newly obtained month. }\r
function IsLeapYear(Year: Word): Boolean;\r
{* Returns True, if given year is "leap" (i.e. has 29 days in the February). }\r
function DayOfWeek(Date: TDateTime): Integer;\r
{* Returns day of week (0..6) for given date. }\r
function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean;\r
{* Converts TSystemTime record to XDateTime variable. }\r
function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;\r
{* Converts TDateTime variable to TSystemTime record. }\r
function DateTime_System2Local( DTSys: TDateTime ): TDateTime;\r
{* Converts DTSys representing system time (+0 Grinvich) to local time. }\r
function DateTime_Local2System( DTLoc: TDateTime ): TDateTime;\r
{* Converts DTLoc representing local time to system time (+0 Grinvich) }\r
function CatholicEaster( nYear: Integer ): TDateTime;\r
{* Returns date of catholic easter for given year. }\r
\r
procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);\r
{* Dividing of integer onto divisor with obtaining both result of division\r
   and remainder. }\r
\r
function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;\r
                         const DfltDateFormat : TDateFormat; const DateFormat : PChar ) : String;\r
{* Formats date, stored in TSystemTime record into string, using given locale\r
   and date/time formatting flags. }\r
function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;\r
                         const Flags : TTimeFormatFlags; const TimeFormat : PChar ) : String;\r
{* Formats time, stored in TSystemTime record into string, using given locale\r
   and date/time formatting flags. }\r
\r
function Date2StrFmt( const Fmt: String; D: TDateTime ): String;\r
{* Represents date as a string correspondently to Fmt formatting string.\r
   See possible pictures in definition of the function Str2DateTimeFmt\r
   (the first part). If Fmt string is empty, default system date format\r
   for short date string used. }\r
function Time2StrFmt( const Fmt: String; D: TDateTime ): String;\r
{* Represents time as a string correspondently to Fmt formatting string.\r
   See possible pictures in definition of the function Str2DateTimeFmt\r
   (the second part). If Fmt string is empty, default system time format\r
   for short date string used. }\r
function DateTime2StrShort( D: TDateTime ): String;\r
{* Formats date and time to string in short date format using current user\r
   locale. }\r
function Str2DateTimeFmt( const sFmtStr, sS: String ): TDateTime;\r
{* Restores date or/and time from string correspondently to a format string.\r
   Date and time formatting string can contain following pictures (case\r
   sensitive):\r
   |<pre>\r
        DATE PICTURES\r
   d    Day of the month as digits without leading zeros for single digit days.\r
   dd   Day of the month as digits with leading zeros for single digit days\r
   ddd  Day of the week as a 3-letter abbreviation as specified by a\r
        LOCALE_SABBREVDAYNAME value.\r
   dddd Day of the week as specified by a LOCALE_SDAYNAME value.\r
   M    Month as digits without leading zeros for single digit months.\r
   MM   Month as digits with leading zeros for single digit months\r
   MMM  Month as a three letter abbreviation as specified by a LOCALE_SABBREVMONTHNAME value.\r
   MMMM Month as specified by a LOCALE_SMONTHNAME value.\r
   y    Year represented only be the last digit.\r
   yy   Year represented only be the last two digits.\r
   yyyy Year represented by the full 4 digits.\r
   gg   Period/era string as specified by the CAL_SERASTRING value. The gg\r
        format picture in a date string is ignored if there is no associated era\r
        string. In Enlish locales, usual values are BC or AD.\r
\r
        TIME PICTURES\r
   h    Hours without leading zeros for single-digit hours (12-hour clock).\r
   hh   Hours with leading zeros for single-digit hours (12-hour clock).\r
   H    Hours without leading zeros for single-digit hours (24-hour clock).\r
   HH   Hours with leading zeros for single-digit hours (24-hour clock).\r
   m    Minutes without leading zeros for single-digit minutes.\r
   mm   Minutes with leading zeros for single-digit minutes.\r
   s    Seconds without leading zeros for single-digit seconds.\r
   ss   Seconds with leading zeros for single-digit seconds.\r
   t    One character–time marker string (usually P or A, in English locales).\r
   tt   Multicharacter–time marker string (usually PM or AM, in English locales).\r
   |</pre>\r
   E.g., 'D, yyyy/MM/dd h:mm:ss'.\r
   See also Str2DateTimeShort function.\r
  }\r
function Str2DateTimeShort( const S: String ): TDateTime;\r
{* Restores date and time from string correspondently to current user locale. }\r
function Str2DateTimeShortEx( const S: String ): TDateTime;\r
{* Like Str2DateTimeShort above, but uses locale defined date and time\r
   separators to avoid recognizing time as a date in some cases.\r
|<hr>\r
\r
\r
  <R File and directory routines>\r
}\r
\r
//[OpenFile CONSTANTS]\r
const\r
  ofOpenRead          = $80000000;\r
  {* Use this flag (in combination with others) to open file for "read" only. }\r
  ofOpenWrite         = $40000000;\r
  {* Use this flag (in combination with others) to open file for "write" only. }\r
  ofOpenReadWrite     = $C0000000;\r
  {* Use this flag (in combination with others) to open file for "read" and "write". }\r
  ofShareExclusive    = $00;\r
  {* Use this flag (in combination with others) to open file for exclusive use. }\r
  ofShareDenyWrite    = $01;\r
  {* Use this flag (in combination with others) to open file in share mode, when\r
     only attempts to open it in other process for "write" will be impossible.\r
     I.e., other processes could open this file simultaneously for read only\r
     access. }\r
  ofShareDenyRead     = $02;\r
  {* Use this flag (in combination with others) to open file in share mode, when\r
     only attempts to open it for "read" in other processes will be disabled.\r
     I.e., other processes could open it for "write" only access. }\r
  ofShareDenyNone     = $03;\r
  {* Use this flag (in combination with others) to open file in full sharing mode.\r
     I.e. any process will be able open this file using the same share flag. }\r
  ofCreateNew         = $100;\r
  {* Default creation disposition. Use this flag for creating new file (usually\r
     for write access. }\r
  ofCreateAlways      = $200;\r
  {* Use this flag (in combination with others) to open existing or creating new\r
     file. If existing file is opened, it is truncated to size 0. }\r
  ofOpenExisting      = $300;\r
  {* Use this flag (in combination with others) to open existing file only. }\r
  ofOpenAlways        = $400;\r
  {* Use this flag (in combination with others) to open existing or create new\r
     (if such file is not yet exists). }\r
  ofTruncateExisting  = $500;\r
  {* Use this flag (in combination with others) to open existing file and truncate\r
     it to size 0. }\r
\r
  ofAttrReadOnly = $10000;\r
  {* Use this flag to create Read-Only file (?). }\r
  ofAttrHidden   = $20000;\r
  {* Use this flag to create hidden file. }\r
  ofAttrSystem   = $40000;\r
  {* Use this flag to create system file. }\r
  ofAttrTemp       = $1000000;\r
  {* Use this flag to create temp file. }\r
  ofAttrArchive  = $200000;\r
  {* Use this flag to create archive file. }\r
  ofAttrCompressed = $8000000;\r
  {* Use this flag to create compressed file. Has effect only on NTFS, and\r
     only if ofAttrCompressed is not specified also. }\r
  ofAttrOffline    = $10000000;\r
  {* Use this flag to create offline file. }\r
//[END OF OpenFileConstants]\r
\r
//[File FUNCTIONS DECLARATIONS]\r
function FileCreate(const FileName: string; OpenFlags: DWord): THandle;\r
{* Call this function to open existing or create new file. OpenFlags\r
   parameter can be a combination of up to three flags (by one from\r
   each group:\r
   |<table border=0>\r
   |&L=<tr><td valign=top>%0</td><td valign=top>\r
   |&E=</td></tr>\r
   <L ofOpenRead, ofOpenWrite, ofOpenReadWrite> - 1st group. Here You decide\r
      wish You open file for read, write or read-and-write operations; <E>\r
   <L ofShareExclusive, ofShareDenyWrite, ofShareDenyRead, ofShareDenyNone> -2nd\r
      group - sharing. Here You can mark out sharing mode, which is used to\r
      open file. <E>\r
   <L ofCreateNew, ofCreateAlways, ofOpenExisting, ofOpenAlways, ofTruncateExisting>\r
      - 3rd group - creation disposition. Here You determine, either to create new\r
      or open existing file and if to truncate existing or not.\r
   |</table> }\r
function FileClose(Handle: THandle): Boolean;\r
{* Call it to close opened earlier file. }\r
function FileExists( const FileName: String ) : Boolean;\r
{* Returns True, if given file exists.\r
   |<br>Note (by Dod):\r
   It is not documented in a help for GetFileAttributes, but it seems that\r
   under NT-based Windows systems, FALSE is always returned for files\r
   opened for excluseve use like pagefile.sys. }\r
function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;\r
{* Reads bytes from current position in file to buffer. Returns number of\r
   read bytes. }\r
function File2Str(Handle: THandle): String;\r
{* Reads file from current position to the end and returns result as ansi string. }\r
\r
function FileSeek(Handle: THandle; MoveTo: integer; MoveMethod: TMoveMethod): DWord;\r
{* Changes current position in file. }\r
function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord;\r
{* Writes bytes from buffer to file from current position, extending its\r
   size if needed. }\r
function FileEOF( Handle: THandle ) : Boolean;\r
{* Returns True, if EOF is achieved during read operations or last byte is\r
   overwritten or append made to extend file during last write operation. }\r
function FileFullPath( const FileName : String ) : String;\r
{* Returns full path name for given file. Validness of source FileName path\r
   is not checked at all. }\r
function FileShortPath( const FileName: String ): String;\r
{* Returns short path to the file or directory. }\r
function FileIconSystemIdx( const Path: String ): Integer;\r
{* Returns index of the index of the system icon correspondent to the file or\r
   directory in system icon image list. }\r
function FileIconSysIdxOffline( const Path: String ): Integer;\r
{* The same as FileIconSystemIdx, but an icon is calculated for the file\r
   as it were offline (it is possible to get an icon for file even if\r
   it is not existing, on base of its extension only). }\r
procedure LogFileOutput( const filepath, str: String );\r
{* Debug function. Use it to append given string to the end of the given file. }\r
\r
function StrSaveToFile( const Filename, Str: String ): Boolean;\r
{* Saves a string to a file without any changes. If file does not exists, it is\r
   created. If it exists, it is overriden. If operation failed, FALSE is returned. }\r
function StrLoadFromFile( const Filename: String ): String;\r
{* Reads entire file and returns its content as a string. If operation failed,\r
   an empty strinng is returned. }\r
\r
function Mem2File( Filename: PChar; Mem: Pointer; Len: Integer ): Integer;\r
{* Saves memory block to a file (if file exists it is overriden, created new if\r
   not exists). }\r
function File2Mem( Filename: PChar; Mem: Pointer; MaxLen: Integer ): Integer;\r
{* Loads file content to memory. }\r
\r
function FileSize( const Path: String ) : Integer;\r
{* Returns file size in bytes without opening it. If file too large\r
   to represent its size as Integer, -1 is returned. }\r
function GetUniqueFilename( PathName: string ) : String;\r
{* If file given by PathName exists, modifies it to create unique\r
   filename in target folder and returns it. Modification is performed\r
   by incrementing last number in name (if name part of file does not\r
   represent a number, such number is generated and concatenated to\r
   it). E.g., if file aaa.aaa is already exist, the function checks\r
   names aaa1.aaa, aaa2.aaa, ..., aaa10.aaa, etc. For name abc123.ext,\r
   names abc124.ext, abc125.ext, etc. will be checked. }\r
\r
function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;\r
{* Compares time of file (createing, writing, accessing. Returns\r
   -1, 0, 1 if correspondantly FT1<FT2, FT1=FT2, FT1>FT2. }\r
\r
//[Directory FUNCTIONS DECLARATIONS]\r
function GetStartDir: String;\r
{* Returns path to directory where executable is located (regardless\r
   of current directory). }\r
function DirectoryExists(const Name: string): Boolean;\r
{* Returns True if given directory (folder) exists. }\r
function DirectoryEmpty(const Name: String): Boolean;\r
{* Returns True if given directory is not exists or empty. }\r
{\r
function DirectorySize( const Path: String ): I64;\r
-- moved after PDirList\r
}\r
function DirectoryHasSubdirs( const Path: String ): Boolean;\r
{* Returns TRUE if given directory exists and has subdirectories. }\r
function CheckDirectoryContent( const Name: String; SubDirsOnly: Boolean; const Mask: String ): Boolean;\r
{* Returns TRUE if directory does not contain files (or directories only)\r
   satisfying given mask. }\r
\r
//---------------------------------------------------------\r
// Following functions/procedures are created by Edward Aretino:\r
// IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter,\r
// ForceDirectories, CreateDir, ChangeFileExt\r
//---------------------------------------------------------\r
function IncludeTrailingPathDelimiter(const S: string): string;\r
{* by Edward Aretino. Adds '\' to the end if it is not present. }\r
function ExcludeTrailingPathDelimiter(const S: string): string;\r
{* by Edward Aretino. Removes '\' at the end if it is present. }\r
function ForceDirectories(Dir: String): Boolean;\r
{* by Edward Aretino. Creates given directory if not present. All needed\r
   subdirectories are created if necessary. }\r
function CreateDir(const Dir: string): Boolean;\r
{* by Edward Aretino. Creates given directory. }\r
function ChangeFileExt(FileName: String; const Extension: string): string;\r
{* by Edward Aretino. Changes file extention. }\r
\r
function ExcludeTrailingChar( const S: String; C: Char ): String;\r
{* If S is finished with character C, it is excluded. }\r
function IncludeTrailingChar( const S: String; C: Char ): String;\r
{* If S is not finished with character C, it is added. }\r
\r
function ExtractFilePath( const Path: String ) : String;\r
{* Returns only path part from exact path to file. }\r
function ExtractFileName( const Path: String ) : String;\r
{* Extracts file name from exact path to file. }\r
function ExtractFileNameWOext( const Path: String ) : String;\r
{* Extracts file name from path to file or from filename. }\r
function ExtractFileExt( const Path: String ) : String;\r
{* Extracts extention from file name (returns it with dot '.' first) }\r
function ReplaceFileExt( const Path, NewExt: String ): String;\r
{* Returns a path with extension replaced to a given one. }\r
function ExtractShortPathName( const Path: String ): String;\r
{* }\r
function FilePathShortened( const Path: String; MaxLen: Integer ): String;\r
{* Returns shortened file path to fit MaxLen characters. }\r
function FilePathShortenPixels( const Path: String; DC: HDC; MaxPixels: Integer ): String;\r
{* Returns shortened file path to fit MaxPixels for a given DC. If you pass\r
   Canvas.Handle of any control or bitmap object, ensure that font is valid\r
   for it (or call TCanvas.RequiredState( FontValid ) method before. If DC passed\r
   = 0, call is equivalent to call FilePathShortened, and MaxPixels means in such\r
   case maximum number of characters. }\r
function MinimizeName( const Path: String; DC: HDC; MaxPixels: Integer ): String;\r
{* Exactly the same as MinimizeName in FileCtrl.pas (VCL). }\r
\r
function GetSystemDir: String;\r
{* Returns path to windows system directory. }\r
function GetWindowsDir : string;\r
{* Returns path to Windows directory. }\r
function GetWorkDir : string;\r
{* Returns path to application's working directory. }\r
function GetTempDir : string;\r
{* Returns path to default temp folder (directory to place temporary files). }\r
function CreateTempFile( const DirPath, Prefix: String ): String;\r
{* Returns path to just created temporary file. }\r
function  GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: string): string;\r
{* List of files in string, separating each path from others with semicolon (';').\r
   E.g.: 'c:\tmp\unit1.dcu;c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}\r
function DeleteFiles( const DirPath: String ): Boolean;\r
{* Deletes files by file mask (given with wildcards '*' and '?'). }\r
function DeleteFile2Recycle( const Filename : String ) : Boolean;\r
{* Deletes file to recycle bin. This operation can be very slow, when\r
   called for a single file. To delete group of files at once (fast),\r
   pass a list of paths to files to be deleted, separating each path\r
   from others with semicolon (';'). E.g.: 'unit1.dcu;unit1.~pa'\r
   |<br>\r
   FALSE is returned only in case when at least one file was not deleted\r
   successfully.\r
   |<br>\r
   Note, that files are deleted not to recycle bin, if wildcards are\r
   used or not fully qualified paths to files. }\r
function CopyMoveFiles( const FromList, ToList: String; Move: Boolean ): Boolean;\r
{* }\r
{-}\r
function DiskFreeSpace( const Path: String ): I64; {+}\r
{* Returns disk free space in bytes. Pass a path to root directory,\r
   e.g. 'C:\'.\r
|<hr>\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
  <R Wrappers to registry API functions>\r
\r
  These functions can be used independently to simplify access to Windows\r
  registry. }\r
\r
//[Registry FUNCTIONS DECLARATIONS]\r
{++}(*\r
function RegSetValueEx(hKey: HKEY; lpValueName: PChar;\r
  Reserved: DWORD; dwType: DWORD; lpData: Pointer; cbData: DWORD): Longint; stdcall;\r
*){--}\r
function RegKeyOpenRead( Key: HKey; const SubKey: String ): HKey;\r
{* Opens registry key for read operations (including enumerating of subkeys).\r
   Pass either handle of opened earlier key or one of constans\r
   HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS\r
   as a first parameter. If not successful, 0 is returned. }\r
function RegKeyOpenWrite( Key: HKey; const SubKey: String ): HKey;\r
{* Opens registry key for write operations (including adding new values or\r
   subkeys), as well as for read operations too. See also RegKeyOpenRead. }\r
function RegKeyOpenCreate( Key: HKey; const SubKey: String ): HKey;\r
{* Creates and opens key. }\r
function RegKeyGetStr( Key: HKey; const ValueName: String ): String;\r
{* Reads key, which must have type REG_SZ (null-terminated string). If\r
   not successful, empty string is returned. This function as well as all\r
   other registry manipulation functions, does nothing, if Key passed is 0\r
   (without producing any error). }\r
function RegKeyGetStrEx( Key: HKey; const ValueName: String ): String;\r
{* Like RegKeyGetStr, but accepts REG_EXPAND_SZ type, expanding all\r
   environment variables in resulting string.\r
   |<br>\r
   Code provided by neuron, e-mailto:neuron@hollowtube.mine.nu }\r
function RegKeyGetDw( Key: HKey; const ValueName: String ): DWORD;\r
{* Reads key value, which must have type REG_DWORD. If ValueName passed\r
   is '' (empty string), unnamed (default) value is reading. If not\r
   successful, 0 is returned. }\r
function RegKeySetStr(Key: HKey; const ValueName: String; const Value: String ): Boolean;\r
{* Writes new key value as null-terminated string (type REG_SZ). If not\r
   successful, returns False. }\r
function RegKeySetStrEx( Key: HKey; const ValueName: string; const Value: string;\r
                         expand: boolean): Boolean;\r
{* Writes new key value as REG_SZ or REG_EXPAND_SZ. - by neuron, e-mailto:neuron@hollowtube.mine.nu }\r
function RegKeySetDw( Key: HKey; const ValueName: String; Value: DWORD ): Boolean;\r
{* Writes new key value as dword (with type REG_DWORD). Returns False,\r
   if not successful. }\r
procedure RegKeyClose( Key: HKey );\r
{* Closes key, opened using RegKeyOpenRead or RegKeyOpenWrite. (But does\r
   nothing, if Key passed is 0). }\r
function RegKeyDelete( Key: HKey; const SubKey: String ): Boolean;\r
{* Deletes key. Does nothing if key passed is 0 (returns FALSE). }\r
function RegKeyDeleteValue( Key: HKey; const SubKey: String ): Boolean;\r
{* Deletes value. - by neuron, e-mailto:neuron@hollowtube.mine.nu }\r
function RegKeyExists( Key: HKey; const SubKey: String ): Boolean;\r
{* Returns TRUE, if given subkey exists under given Key. }\r
function RegKeyValExists( Key: HKey; const ValueName: String ): Boolean;\r
{* Returns TRUE, if given value exists under the Key.\r
}\r
function RegKeyValueSize( Key: HKey; const ValueName: String ): Integer;\r
{* Returns a size of value. This is a size of buffer needed to store\r
   registry key value. For string value, size returned is equal to a\r
   length of string plus 1 for terminated null character. }\r
function RegKeyGetBinary( Key: HKey; const ValueName: String; var Buffer; Count: Integer ): Integer;\r
{* Reads binary data from a registry, writing it to the Buffer.\r
   It is supposed that size of Buffer provided is at least Count bytes.\r
   Returned value is actul count of bytes read from the registry and written\r
   to the Buffer.\r
   |<br>\r
   This function can be used to get data of any type from the registry, not\r
   only REG_BINARY. }\r
function RegKeySetBinary( Key: HKey; const ValueName: String; const Buffer; Count: Integer ): Boolean;\r
{* Stores binary data in the registry. }\r
function RegKeyGetDateTime(Key: HKey; const ValueName: String): TDateTime;\r
{* Returns datetime variable stored in registry in binary format. }\r
function RegKeySetDateTime(Key: HKey; const ValueName: String; DateTime: TDateTime): Boolean;\r
{* Stores DateTime variable in the registry. }\r
\r
\r
//-------------------------------------------------------\r
// registry functions by Valerian Luft <luft@valerian.de>\r
//-------------------------------------------------------\r
function RegKeyGetSubKeys( const Key: HKEY; List: PStrList): Boolean;\r
{* The function enumerates subkeys of the specified open registry key.\r
   True is returned, if successful.\r
}\r
function RegKeyGetValueNames(const Key: HKEY; List: PStrList): Boolean;\r
{* The function enumerates value names of the specified open registry key.\r
   True is returned, if successful.\r
}\r
function RegKeyGetValueTyp (const Key:HKEY; const ValueName: String) : DWORD;\r
{* The function receives the type of data stored in the specified value.\r
   |<br>\r
   If the function fails, the return value is the Key value.\r
   |<br>\r
   If the function succeeds, the return value return will be one of the following:\r
   |<br>\r
   REG_BINARY , REG_DWORD, REG_DWORD_LITTLE_ENDIAN,\r
   REG_DWORD_BIG_ENDIAN, REG_EXPAND_SZ, REG_LINK , REG_MULTI_SZ,\r
   REG_NONE, REG_RESOURCE_LIST, REG_SZ\r
\r
\r
|<hr>\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
  <R Data sorting (quicksort implementation)>\r
  This part contains implementation of 'quick sort' algorithm,\r
   based on following code:\r
\r
|<pre>\r
| TQSort by Mike Junkin 10/19/95.\r
| DoQSort routine adapted from Peter Szymiczek's QSort procedure which\r
| was presented in issue#8 of The Unofficial Delphi Newsletter.\r
\r
| TQSort changed by Vladimir Kladov (Mr.Bonanzas) to allow 32-bit\r
| sorting (of big arrays with more than 64K elements).\r
|</pre>\r
\r
  Finally, this sort procedure is adapted to XCL (and then to KOL)\r
  requirements (no references to SysUtils, Classes etc. TQSort object\r
  is transferred to a single procedure call and DoQSort method is\r
  renamed to SortData - which is a regular procedure now). }\r
\r
//[Sorting TYPES]\r
type\r
  TCompareEvent = function (const Data: Pointer; const e1,e2 : Dword) : Integer;\r
  {* Event type to define comparison function between two elements of an array.\r
     This event handler must return -1 or +1 (correspondently for cases e1<e2\r
     and e2>e2). Items are enumerated from 0 to uNElem. }\r
  TSwapEvent = procedure (const Data : Pointer; const e1,e2 : Dword);\r
  {* Event type to define swap procedure which is swapping two elements of an\r
     array. }\r
\r
//[SortData FUNCTIONS DECLARATIONS]\r
procedure SortData( const Data: Pointer; const uNElem: Dword;\r
                    const CompareFun: TCompareEvent;\r
                    const SwapProc: TSwapEvent );\r
{* Call it to sort any array of data of any kind, passing total\r
   number of items in an array and two defined (regular) function\r
   and procedure to perform custom compare and swap operations.\r
   First procedure parameter is to pass it to callback function\r
   CompareFun and procedure SwapProc. Items are enumerated from\r
   0 to uNElem-1. }\r
\r
procedure SortIntegerArray( var A : array of Integer );\r
{* procedure to sort array of integers. }\r
\r
procedure SortDwordArray( var A : array of DWORD );\r
{* Procedure to sort array of unsigned 32-bit integers.\r
|<hr>\r
}\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- directory list object -- }\r
//[DirList Object]\r
\r
type\r
  TDirItemAction = ( diSkip, diAccept, diCancel );\r
  TOnDirItem = procedure( Sender: PObj; var DirItem: TWin32FindData; var Accept: TDirItemAction )\r
             of object;\r
  TSortDirRules = ( sdrNone, sdrFoldersFirst, sdrCaseSensitive, sdrByName, sdrByExt,\r
                    sdrBySize, sdrBySizeDescending, sdrByDateCreate, sdrByDateChanged,\r
                    sdrByDateAccessed );\r
  {* List of rules (options) to sort directories. Rules are passed to Sort\r
     method in an array, and first placed rules are applied first. }\r
\r
  {++}(*TDirList = class;*){--}\r
  PDirList = {-}^{+}TDirList;\r
{ ----------------------------------------------------------------------\r
\r
                TDirList - Directory scanning\r
\r
----------------------------------------------------------------------- }\r
//[TDirList DEFINITION]\r
  TDirList = object( TObj )\r
  {* Allows easy directory scanning. This is not visual object, but\r
     storage to simplify working with directory content. }\r
  protected\r
    FList : PList;\r
    FPath: string;\r
    fFilters: PStrList;\r
    fOnItem: TOnDirItem;\r
    function Get(Idx: Integer): PWin32FindData;\r
    function GetCount: Integer;\r
    function GetNames(Idx: Integer): string;\r
    function GetIsDirectory(Idx: Integer): Boolean;\r
  protected\r
    function SatisfyFilter( FileName : PChar; FileAttr, FindAttr : DWord ) : Boolean;\r
  {++}(*public*){--}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* Destructor. As usual, call Free method to destroy an object. }\r
  public\r
    property Items[ Idx : Integer ] : PWin32FindData read Get; default;\r
    {* Full access to scanned items (files and subdirectories). }\r
    property IsDirectory[ Idx: Integer ]: Boolean read GetIsDirectory;\r
    {* Returns TRUE, if specified item represents a directory, not a file. }\r
    property Count : Integer read GetCount;\r
    {* Number of items. }\r
    property Names[ Idx : Integer ] : string read GetNames;\r
    {* Full long names of directory items. }\r
    property Path : string read FPath;\r
    {* Path of scanned directory. }\r
    procedure Clear;\r
    {* Call it to clear list of files. }\r
    procedure ScanDirectory( const DirPath, Filter : String; Attr : DWord );\r
    {* Call it to rescan directory or to scan another directory content\r
       (method Clear is called first). Pass path to directory, file filter\r
       and attributes to scan directory immediately.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr\r
       parameter. If 0 passed, both files and directories are listed. }\r
    procedure ScanDirectoryEx( const DirPath, Filters : String; Attr : DWord );\r
    {* Call it to rescan directory or to scan another directory content\r
       (method Clear is called first). Pass path to directory, file filter\r
       and attributes to scan directory immediately.\r
       |<br>&nbsp;&nbsp;&nbsp;\r
       Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr\r
       parameter. }\r
    procedure Sort( Rules : array of TSortDirRules );\r
   {* Sorts directory entries. If empty rules array passed, default rules\r
      array DefSortDirRules is used. }\r
   function FileList( const Separator {e.g.: ';', or #13}: String;\r
            Dirs, FullPaths: Boolean ): String;\r
   {* Returns a string containing all names separated with Separator.\r
      If Dirs=FALSE, only files are returned. }\r
   property OnItem: TOnDirItem read fOnItem write fOnItem;\r
   {* This event is called on reading each item while scanning directory.\r
      To use it, first create PDirList object with empty path to scan, then\r
      assign OnItem event and call ScanDirectory with correct path. }\r
  end;\r
//[END OF TDirList DEFINITION]\r
\r
//[NewDirList DECLARATIONS]\r
function NewDirList( const DirPath, Filter: String; Attr: DWORD ): PDirList;\r
{* Creates directory list object using easy one-string filter. If Attr = FILE_ATTRIBUTE_NORMAL,\r
   only files are scanned without directories. If Attr = 0, both files and\r
   directories are listed. }\r
\r
function NewDirListEx( const DirPath, Filters: String; Attr: DWORD ): PDirList;\r
{* Creates directory list object using several filters, separated by ';'.\r
   Filters starting from '^' consider to be anti-filters, i.e. files,\r
   satisfying to those masks, are skept during scanning. }\r
\r
const DefSortDirRules : array[ 0..3 ] of TSortDirRules = ( sdrFoldersFirst,\r
      sdrByName, sdrBySize, sdrByDateCreate );\r
{* Default rules to sort directory entries. }\r
\r
//[DirectorySize DECLARATION]\r
{-}\r
function DirectorySize( const Path: String ): I64;\r
{* Returns directory size in bytes as large 64 bit integer. }\r
{+}\r
\r
\r
//[OpenSaveDialog OPTIONS]\r
type\r
  TOpenSaveOption = ( OSCreatePrompt,\r
                      OSExtensionDiffent,\r
                      OSFileMustExist,\r
                      OSHideReadonly,\r
                      OSNoChangedir,\r
                      OSNoReferenceLinks,\r
                      OSAllowMultiSelect,\r
                      OSNoNetworkButton,\r
                      OSNoReadonlyReturn,\r
                      OSOverwritePrompt,\r
                      OSPathMustExist,\r
                      OSReadonly,\r
                      OSNoValidate\r
  //{$IFDEF OpenSaveDialog_Extended}\r
                      ,\r
                      OSTemplate,\r
                      OSHook\r
  //{$ENDIF}\r
                    );\r
  TOpenSaveOptions = set of TOpenSaveOption;\r
  {* Options available for TOpenSaveDialog. }\r
\r
  {++}(*TOpenSaveDialog = class;*){--}\r
  POpenSaveDialog = {-}^{+}TOpenSaveDialog;\r
{ ----------------------------------------------------------------------\r
\r
                              TOpenSaveDialog\r
\r
----------------------------------------------------------------------- }\r
//[TOpenSaveDialog DEFINITION]\r
  TOpenSaveDialog = object( TObj )\r
  {* Object to show standard Open/Save dialog. Initially provided\r
     for XCL by Carlo Kok. }\r
  protected\r
    FFilter : String;\r
    fFilterIndex : Integer;\r
    fOpenDialog : Boolean;\r
    FInitialDir : String;\r
    FDefExtension : String;\r
    FFilename : string;\r
    FTitle : string;\r
    FOptions : TOpenSaveOptions;\r
    fWnd: THandle;\r
  public\r
    {$IFDEF OpenSaveDialog_Extended}\r
    TemplateName: String;\r
    HookProc: Pointer;\r
    {$ENDIF}\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* destructor }\r
    Function Execute : Boolean;\r
    {* Call it after creating to perform selecting of file by user. }\r
    property Filename : String read FFilename write FFileName;\r
    {*\r
    Filename is seperated by #13 when multiselect is true and the first\r
    file, is the path of the files selected.\r
    |<pre>\r
    |  C:\Projects\r
    |  Test1.Dpr\r
    |  Test2.Dpr\r
    |</pre>\r
    If only one file is selected, it is provided as (e.g.)\r
    C:\Projects\Test1.dpr\r
    |<br> For case when OSAllowMultiselect option used, after each\r
    call initial value for a Filename containing several files prevents\r
    system from opening the dialog. To fix this, assign another initial\r
    value to Filename property in your code, when you use multiselect.\r
    }\r
    property InitialDir : string read FInitialDir write FInitialDir;\r
    {* Initial directory path. If not set, current directory (usually\r
       directory when program is started) is used. }\r
    property Filter : String read FFilter write FFilter;\r
    {* A list of pairs of filter names and filter masks, separated with '|'.\r
       If a mask contains more than one mask, it should be separated with ';'.\r
       E.g.:\r
       ! 'All files|*.*|Text files|*.txt;*.1st;*.diz' }\r
    property FilterIndex : Integer read FFilterIndex write FFilterIndex;\r
    {* Index of default filter mask (0 by default, which means "first"). }\r
    property OpenDialog : Boolean read FOpenDialog write FOpenDialog;\r
    {* True, if "Open" dialog. False, if "Save" dialog. True is default. }\r
    property Title : String read Ftitle write Ftitle;\r
    {* Title for dialog. }\r
    property Options : TOpenSaveOptions read FOptions write FOptions;\r
    {* Options. }\r
    property DefExtension : String read FDefExtension write FDefExtension;\r
    {* Default extention. Set it to desired extension without leading period,\r
       e.g. 'txt', but not '.txt'. }\r
    property WndOwner: THandle read fWnd write fWnd;\r
    {* Owner window handle. If not assigned, Applet.Handle is used (whenever\r
       possible). Assign it, if your application has stay-on-top forms, and\r
       a separate Applet object is used. }\r
  end;\r
//[END OF TOpenSaveDialog DEFINITION]\r
\r
//[Default OpenSaveDialog OPTIONS]\r
const DefOpenSaveDlgOptions: TOpenSaveOptions = [ OSHideReadonly,\r
  OSOverwritePrompt, OSFileMustExist, OSPathMustExist ];\r
\r
//[NewOpenSaveDialog DECLARATION]\r
function NewOpenSaveDialog( const Title, StrtDir: String;\r
         Options: TOpenSaveOptions ): POpenSaveDialog;\r
{* Creates object, which can be used (several times) to open file(s)\r
   selecting dialog. }\r
\r
\r
\r
//[OpenDirectory Object]\r
type\r
  {++}(*TOpenDirDialog = class;*){--}\r
  POpenDirDialog = {-}^{+}TOpenDirDialog;\r
\r
  TOpenDirOption = ( odBrowseForComputer, odBrowseForPrinter, odDontGoBelowDomain,\r
                   odOnlyFileSystemAncestors, odOnlySystemDirs, odStatusText,\r
                   odBrowseIncludeFiles );\r
  {* Flags available for TOpenDirDialog object. }\r
                   // odfStatusText - do not support status callback\r
  TOpenDirOptions = set of TOpenDirOption;\r
  {* Set of all flags used to control ZOpenDirDialog class. }\r
\r
  TOnODSelChange = procedure( Sender: POpenDirDialog; NewSelDir: PChar;\r
                              var EnableOK: Integer; var StatusText: String )\r
                              of object;\r
  {* Event type to be called when user select another directory in OpenDirDialog.\r
     Set EnableOK to -1 to disable OK button, or to +1 to enable it.\r
     It is also possible to set new StatusText string. }\r
\r
{ ----------------------------------------------------------------------\r
\r
                               TOpenDirDialog\r
\r
----------------------------------------------------------------------- }\r
//[TOpenDirDialog DEFINITION]\r
  TOpenDirDialog = object( TObj )\r
  {* Dialog for open directories, uses SHBrowseForFolder. }\r
  protected\r
    FTitle: String;\r
    FOptions: TOpenDirOptions;\r
    FCallBack: Pointer;\r
    FCenterProc: procedure( Wnd: HWnd );\r
    FBuf : array[ 0..MAX_PATH ] of Char;\r
    FInitialPath: String;\r
    FCenterOnScreen: Boolean;\r
    FDoSelChanged: procedure( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ); stdcall;\r
    FOnSelChanged: TOnODSelChange;\r
    FStatusText: String;\r
    FWnd: HWnd;\r
    function GetPath: String;\r
    procedure SetInitialPath(const Value: String);\r
    procedure SetCenterOnScreen(const Value: Boolean);\r
    procedure SetOnSelChanged(const Value: TOnODSelChange);\r
    function GetInitialPath: String;\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* destructor }\r
    function Execute : Boolean;\r
    {* Call it to select directory by user. Returns True, if operation was\r
       not cancelled by user. }\r
    property Title : String read FTitle write FTitle;\r
    {* Title for a dialog. }\r
    property Options : TOpenDirOptions read FOptions write FOptions;\r
    {* Option flags. }\r
    property Path : String read GetPath;\r
    {* Resulting (selected by user) path. }\r
    property InitialPath: String read GetInitialPath write SetInitialPath;\r
    {* Set this property to a path of directory to be selected initially\r
       in a dialog. }\r
    property CenterOnScreen: Boolean read FCenterOnScreen write SetCenterOnScreen;\r
    {* Set it to True to center dialog on screen. }\r
    property OnSelChanged: TOnODSelChange read FOnSelChanged write SetOnSelChanged;\r
    {* This event is called every time, when user selects another directory.\r
       It is possible to eneble/disable OK button in dialog and/or change\r
       dialog status text in responce to event. }\r
    property WndOwner: HWnd read FWnd write FWnd;\r
    {* Owner window. If you want to provide your dialog visible over stay-on-top\r
       form, fire it as a child of the form, assigning the handle of form window\r
       to this property first. }\r
  end;\r
//[END OF TOpenDirDialog DEFINITION]\r
\r
//[NewOpenSaveDialog DECLARATION]\r
function NewOpenDirDialog( const Title: String; Options: TOpenDirOptions ):\r
         POpenDirDialog;\r
{* Creates object, which can be used (several times) to open directory\r
   selecting dialog (using SHBrowseForFolder API call). }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
//[Color Dialog Object]\r
type\r
  TColorCustomOption = ( ccoFullOpen, ccoShortOpen, ccoPreventFullOpen );\r
\r
  {++}(*TColorDialog = class;*){--}\r
  PColorDialog = {-}^{+}TColorDialog;\r
{ ----------------------------------------------------------------------\r
\r
                               TColorDialog\r
\r
----------------------------------------------------------------------- }\r
//[TColorDialog DEFINITION]\r
  TColorDialog = object( TObj )\r
  {* Color choosing dialog. }\r
  protected\r
  public\r
    OwnerWindow: HWnd;\r
    {* Owner window (can be 0). }\r
    CustomColors: array[ 1..16 ] of TColor;\r
    {* Array of stored custom colors. }\r
    ColorCustomOption: TColorCustomOption;\r
    {* Options (how to open a dialog). }\r
    Color: TColor;\r
    {* Returned color (if the result of Execute is True). }\r
    function Execute: Boolean;\r
    {* Call this method to open a dialog and wait its result. }\r
  end;\r
//[END OF TColorDialog DEFINITION]\r
\r
//[NewColorDialog DECLARATION]\r
function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog;\r
{* Creates color choosing dialog object. }\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
//[Ini files]\r
type\r
  TIniFileMode = ( ifmRead, ifmWrite );\r
  {* ifmRead is default mode (means "read" data from ini-file.\r
     Set mode to ifmWrite to write data to ini-file, correspondent to\r
     TIniFile. }\r
\r
  {++}(*TIniFile = class;*){--}\r
  PIniFile = {-}^{+}TIniFile;\r
{ ----------------------------------------------------------------------\r
\r
                TIniFile - store/load data to ini-files\r
\r
----------------------------------------------------------------------- }\r
//[TIniFile DEFINITION]\r
  TIniFile = object( TObj )\r
  {* Ini file incapsulation. The main feature is what the same block of\r
     read-write operations could be defined (difference must be only in\r
     Mode value).\r
     |*Ini file sample.\r
     This sample shows how the same Pascal operators can be used both\r
     for read and write for the same variables, when working with TIniFile:\r
     !    procedure ReadWriteIni( Write: Boolean );\r
     !    var Ini: PIniFile;\r
     !    begin\r
     !      Ini := OpenIniFile( 'MyIniFile.ini' );\r
     !      Ini.Section := 'Main';\r
     !      if Write then            // if Write, the same operators will save\r
     !         Ini.Mode := ifmWrite; // data rather then load.\r
     !      MyForm.Left := Ini.ValueInteger( 'Left', MyForm.Left );\r
     !      MyForm.Top  := Ini.ValueInteger( 'Top',  MyForm.Top );\r
     !      Ini.Free;\r
     !    end;\r
     !\r
     |*  }\r
  protected\r
    fMode: TIniFileMode;\r
    fFileName: String;\r
    fSection: String;\r
  protected\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* destructor }\r
    property Mode: TIniFileMode read fMode write fMode;\r
    {* ifmWrite, if write data to ini-file rather than read it. }\r
    property FileName: String read fFileName;\r
    {* Ini file name. }\r
    property Section: String read fSection write fSection;\r
    {* Current ini section. }\r
    function ValueInteger( const Key: String; Value: Integer ): Integer;\r
    {* Reads or writes integer data value. }\r
    function ValueString( const Key: String; const Value: String ): String;\r
    {* Reads or writes string data value. }\r
    function ValueBoolean( const Key: String; Value: Boolean ): Boolean;\r
    {* Reads or writes boolean data value. }\r
    function ValueData( const Key: String; Value: Pointer; Count: Integer ): Boolean;\r
    {* Reads or writes data from/to buffer. Returns True, if success. }\r
    procedure ClearAll;\r
    {* Clears all sections of ini-file. }\r
    procedure ClearSection;\r
    {* Clears current Section of ini-file. }\r
    procedure ClearKey( const Key: String );\r
    {* Clears given key in current section. }\r
\r
    /////////////// + by Vyacheslav A. Gavrik:\r
    procedure GetSectionNames(Names:PStrList);\r
    {* Retrieves section names, storing it in string list passed as a parameter.\r
       String list does not cleared before processing. Section names are added\r
       to the end of the string list. }\r
    procedure SectionData(Names:PStrList);\r
    {* Read/write current section content to/from string list. (Depending on\r
       current Mode value). }\r
    ///////////////\r
\r
  end;\r
//[END OF TIniFile DEFINITION]\r
\r
//[OpenIniFile DECLARATION]\r
function OpenIniFile( const FileName: String ): PIniFile;\r
{* Opens ini file, creating TIniFile object instance to work with it. }\r
\r
\r
\r
\r
\r
//[CABINET FILES OBJECT]\r
type\r
  {++}(*TCabFile = class;*){--}\r
  PCABFile = {-}^{+}TCABFile;\r
\r
  TOnNextCAB = function( Sender: PCABFile ): String of object;\r
  TOnCABFile = function( Sender: PCABFile; var FileName: String ): Boolean of object;\r
\r
{ ----------------------------------------------------------------------\r
\r
                TCabFile - windows cabinet files\r
\r
----------------------------------------------------------------------- }\r
//[TCabFile DEFINITION]\r
  TCABFile = object( TObj )\r
  {* An object to simplify extracting files from a cabinet (.CAB) files.\r
     The only what need to use this object, setupapi.dll. It is provided\r
     with all latest versions of Windows. }\r
  protected\r
    FPaths: PStrList;\r
    FNames: PStrList;\r
    FOnNextCAB: TOnNextCAB;\r
    FOnFile: TOnCABFile;\r
    FTargetPath: String;\r
    FSetupapi: THandle;\r
    function GetNames(Idx: Integer): String;\r
    function GetCount: Integer;\r
    function GetPaths(Idx: Integer): String;\r
    function GetTargetPath: String;\r
  protected\r
    FGettingNames: Boolean;\r
    FCurCAB: Integer;\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* }\r
    property Paths[ Idx: Integer ]: String read GetPaths;\r
    {* A list of CAB-files. It is stored, when constructing function\r
       OpenCABFile called. }\r
    property Names[ Idx: Integer ]: String read GetNames;\r
    {* A list of file names, stored in a sequence of CAB files. To get know,\r
       how many files are there, check Count property. }\r
    property Count: Integer read GetCount;\r
    {* Number of files stored in a sequence of CAB files. }\r
    function Execute: Boolean;\r
    {* Call this method to extract or enumerate files in CAB. For every\r
       file, found during executing, event OnFile is alled (if assigned).\r
       If the event handler (if any) does not provide full target path for\r
       a file to extract to, property TargetPath is applyed (also if it\r
       is assigned), or file is extracted to the default directory (usually\r
       the same directory there CAB file is located, or current directory\r
       - by a decision of the system).\r
       |<br>\r
       If a sequence of CAB files is used, and not all names for CAB files\r
       are provided (absent or represented by a string '?' ), an event\r
       OnNextCAB is called to obtain the name of the next CAB file.}\r
    property CurCAB: Integer read FCurCAB;\r
    {* Index of current CAB file in a sequence of CAB files. When OnNextCAB\r
       event is called (if any), CurCAB property is already set to the\r
       index of path, what should be provided. }\r
    property OnNextCAB: TOnNextCAB read FOnNextCAB write FOnNextCAB;\r
    {* This event is called, when a series of CAB files is needed and not\r
       all CAB file names are provided (absent or represented by '?' string).\r
       If this event is not assigned, the user is prompted to browse file. }\r
    property OnFile: TOnCABFile read FOnFile write FOnFile;\r
    {* This event is called for every file found during Execute method.\r
       In an event handler (if any assigned), it is possible to return\r
       False to skip file, or to provide another full target path for\r
       file to extract it to, then default. If the event is not assigned,\r
       all files are extracted either to default directory, or to the\r
       directory TargetPath, if it is provided. }\r
    property TargetPath: String read GetTargetPath write FTargetPath;\r
    {* Optional target directory to place there extracted files. }\r
  end;\r
//[END OF TCABFile DEFINITION]\r
\r
//[OpenCABFile DECLARATION]\r
function OpenCABFile( const APaths: array of String ): PCABFile;\r
{* This function creates TCABFile object, passing a sequence of CAB file names\r
   (fully qualified). It is possible not to provide all names here, or pass '?'\r
   string in place of some of those. For such files, either an event OnNextCAB\r
   will be called, or (and) user will be prompted to browse file during\r
   executing (i.e. Extracting). }\r
\r
\r
\r
\r
\r
\r
\r
//[MENU OBJECT]\r
\r
type\r
  TMenuitemInfo = packed record\r
    cbSize: UINT;\r
    fMask: UINT;\r
    fType: UINT;             { used if MIIM_TYPE}\r
    fState: UINT;            { used if MIIM_STATE}\r
    wID: UINT;               { used if MIIM_ID}\r
    hSubMenu: HMENU;         { used if MIIM_SUBMENU}\r
    hbmpChecked: HBITMAP;    { used if MIIM_CHECKMARKS}\r
    hbmpUnchecked: HBITMAP;  { used if MIIM_CHECKMARKS}\r
    dwItemData: DWORD;       { used if MIIM_DATA}\r
    dwTypeData: PAnsiChar;   { used if MIIM_TYPE}\r
    cch: UINT;               { used if MIIM_TYPE}\r
    hbmpItem: HBITMAP;       { used if MIIM_BITMAP - not exists under Windows95 }\r
  end;\r
\r
type\r
  {++}(*TMenu = class;*){--}\r
  PMenu = {-}^{+}TMenu;\r
\r
  TOnMenuItem = procedure( Sender : PMenu; Item : Integer ) of object;\r
  {* Event type to define OnMenuItem event. }\r
\r
  TMenuAccelerator = packed Record\r
  {* Menu accelerator record. Use MakeAccelerator function to combine desired\r
     attributes into a record, describing the accelerator. }\r
    fVirt: Byte; // or-combination of FSHIFT, FCONTROL, FALT, FVIRTKEY, FNOINVERT\r
    Key: Word;   // character or virtual key code (FVIRTKEY flag is present above)\r
    NotUsed: Byte; // not used\r
  end;\r
\r
  // by Sergey Shisminzev:\r
  TMenuOption = (moDefault, moDisabled, moChecked,\r
          moCheckMark, moRadioMark, moSeparator, moBitmap, moSubMenu,\r
          moBreak, moBarBreak);\r
  {* Options to add menu items dynamically. }\r
  TMenuOptions = set of TMenuOption;\r
  {* Set of options for menu item to use it in TMenu.AddItem method. }\r
\r
  TMenuBreak = ( mbrNone, mbrBreak, mbrBarBreak );\r
  {* Possible menu item break types. }\r
\r
{ ----------------------------------------------------------------------\r
\r
                TMenu - main, popup menu and menu item\r
\r
----------------------------------------------------------------------- }\r
//[TMenu DEFINITION]\r
  TMenu = object( TObj )\r
  {* Dynamic menu incapsulation object. Can play role of form main menu or popup\r
     menu, depending on kind of parent window (form or control) and order of\r
     creation (created first (for a form) become main menu). Does not allow\r
     merging menus, but items can be hidden. Additionally checkmark bitmaps,\r
     shortcut key accelerators and other features are available. }\r
  protected\r
    FHandle: HMenu;\r
    FId: Integer;\r
    FParent: PMenu;\r
    FControl: PControl;\r
    fNextMenu : PMenu;\r
    FRadioGroup: Integer;\r
    FIsCheckItem: Boolean;\r
    FIsSeparator: Boolean;\r
    FMenuBreak: TMenuBreak;\r
    FItems: PList;\r
    FOnMenuItem : TOnMenuItem;\r
    FOnRadioOff : TOnMenuItem;\r
    fOnPopup: TOnEvent;\r
    fByAccel: Boolean;\r
    FPopupFlags: DWORD;\r
    //fAutoPopup: Boolean;\r
    FVisible: Boolean;\r
    FSavedState: DWORD;\r
    FData: Pointer;\r
    FOwnerDraw: Boolean;\r
    FCaption: String;\r
    FBitmap: HBitmap;\r
    FBmpChecked: HBitmap;\r
    FBmpItem: HBitmap;\r
    ClearBitmapsProc: procedure( Sender: PMenu );\r
    FClearBitmaps: Boolean;\r
    FNotPopup: Boolean;\r
    FAccelerator: TMenuAccelerator;\r
    FHelpContext: Integer;\r
    FOnMeasureItem: TOnMeasureItem;\r
    FOnDrawItem: TOnDrawItem;\r
    {$IFDEF USE_MENU_CURCTL}\r
    fCurCtl: PControl;\r
    {$ENDIF USE_MENU_CURCTL}\r
    function GetItems( Id: HMenu ): PMenu;\r
    function GetCount: Integer;\r
    function GetTopParent: PMenu;\r
    function GetState( const Index: Integer ): Boolean;\r
    procedure SetState( const Index: Integer; Value: Boolean );\r
    procedure SetVisible( Value: Boolean );\r
    procedure SetData( Value: Pointer );\r
    procedure SetMenuItemCaption( const Value: String );\r
    function FillMenuItems(AHandle: HMenu; StartIdx: Integer;\r
      const Template: array of PChar): Integer;\r
    procedure SetMenuBreak( Value: TMenuBreak );\r
    function GetControl: PControl;\r
    function GetInfo( var MII: TMenuItemInfo ): Boolean;\r
    function SetInfo( var MII: TMenuItemInfo ): Boolean;\r
    function SetTypeInfo( var MII: TMenuItemInfo ): Boolean;\r
    procedure SetBitmap( Value: HBitmap );\r
    procedure SetBmpChecked( Value: HBitmap );\r
    procedure SetBmpItem( Value: HBitmap );\r
    procedure ClearBitmaps;\r
    procedure SetAccelerator( const Value: TMenuAccelerator );\r
    procedure SetHelpContext( Value: Integer );\r
    procedure SetSubmenu( Value: HMenu );\r
    procedure SetOnMeasureItem( const Value: TOnMeasureItem );\r
    procedure SetOnDrawItem( const Value: TOnDrawItem );\r
    procedure SetOwnerDraw( Value: Boolean );\r
  protected\r
    function GetItemChecked( Item : Integer ) : Boolean;\r
    procedure SetItemChecked( Item : Integer; Value : Boolean );\r
    function GetItemBitmap(Idx: Integer): HBitmap;\r
    procedure SetItemBitmap(Idx: Integer; const Value: HBitmap);\r
    function GetItemText(Idx: Integer): String;\r
    procedure SetItemText(Idx: Integer; const Value: String);\r
    function GetItemEnabled(Idx: Integer): Boolean;\r
    procedure SetItemEnabled(Idx: Integer; const Value: Boolean);\r
    function GetItemVisible(Idx: Integer): Boolean;\r
    procedure SetItemVisible(Idx: Integer; const Value: Boolean);\r
    function GetItemAccelerator(Idx: Integer): TMenuAccelerator;\r
    procedure SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator);\r
    function GetItemSubMenu( Idx: Integer ): HMenu;\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    {* To release menu dynamically, call Free method instead. All (popup)\r
       menus created after this (for the same control) are destroyed in\r
       that case too.\r
       |<br>\r
       It is not necessary to release menu object manually: all menus,\r
       created with given form (or control), are automatically released,\r
       when owner form (or control) is destroyed.\r
    }\r
    property Handle : HMenu read FHandle;\r
    {* Handle of Windows menu object. }\r
    property MenuId: Integer read FId;\r
    {* Id of the menu item object. If menu item has subitems, it has\r
       also submenu Handle. Top parent menu object itself has no Id.\r
       Id-s areassigned automatically starting from 4096. Do not\r
       (re)create menu items instantly, because such values are not\r
       reused, and maximum possible Id value must not exceed 65535. }\r
    property Parent: PMenu read FParent;\r
    {* Parent menu item (or parent menu). }\r
    property TopParent: PMenu read GetTopParent;\r
    {* Top parent menu, owning all nested subitems. }\r
    property Owner: PControl read GetControl;\r
    {* Parent control or form. }\r
    property Caption: String read FCaption write SetMenuItemCaption;\r
    {* Menu item caption text (including '&' indicating mnemonic characters,\r
       and keyboard accelerator representation string, usually following\r
       tabulation character). }\r
    property Items[ Id: HMenu ]: PMenu read GetItems;\r
    {* Returns menu item object by its index or by menu id. Since menu id\r
       values are starting from 4096, values from 0 to 4095 are interpreted\r
       as absolute index of menu item. Be careful accessing menu items or\r
       submenus by index, if you dynamically insert or delete items or\r
       submenus. In this version, separators are enumerating too, like\r
       all other items. Use index -1 to access object itself. The first\r
       item of a menu (or the first subitem of submenu item) has index 0.\r
       Children are enumerating before all siblings. The maximum available\r
       index is (Count - 1), when accessing menu items by index. }\r
    property Count: Integer read GetCount;\r
    {* Count of items together with all its nested subitems. }\r
    function IndexOf( Item: PMenu ): Integer;\r
    {* Returns index of an item. This index can be used to access\r
       menu item. Value -2 is returned, if the Item is not a child for menu\r
       or menu item, and has no parents, which are children for it, etc.\r
       Menu object itself always has index -1. }\r
    property OnMenuItem : TOnMenuItem read FOnMenuItem write FOnMenuItem;\r
    {* Is called when menu item is clicked. Absolute index of menu item\r
       clicked is passed as the second parameter. TopParent always is\r
       passed as a Sender parameter. }\r
    property ByAccel: Boolean read fByAccel;\r
    {* True, when OnMenuItem is called not by mouse, but by accelerator key.\r
       Check this flag for entire menu (TopParent), not for item itself.\r
       (Note, that Sender in OnMenuItem always is TopParent menu object). )\r
    }\r
    property IsSeparator: Boolean read FIsSeparator;\r
    {* TRUE, if a separator menu item. }\r
    property MenuBreak: TMenuBreak read FMenuBreak write SetMenuBreak;\r
    {* Menu item break type. }\r
    property OnUncheckRadioItem : TOnMenuItem read FOnRadioOff write FOnRadioOff;\r
    {* Is called when radio item becomes unchecked in menu in result of\r
       checking another radio item of the same radio group. }\r
    property RadioGroup: Integer read FRadioGroup write FRadioGroup;\r
    {* Radio group index. Several neighbour items with the same radio group\r
       index form radio group. Only single item from the same group can be\r
       checked at a time. }\r
    property IsCheckItem: Boolean read FIsCheckItem;\r
    {* If menu item is defined as check item, it is checked automatically\r
       when clicked. }\r
    procedure RadioCheckItem;\r
    {* Call this method to check radio item. (Calling this method for\r
       an item, which is not belonging to a radio group, just sets its\r
       Checked state to TRUE). }\r
    property Checked: Boolean index MFS_CHECKED read GetState write SetState;\r
    {* Checked state of the item. }\r
    property Enabled: Boolean\r
             {$IFDEF F_P}\r
             index $80000000 or MFS_DISABLED\r
             {$ELSE DELPHI}\r
             index Integer( $80000000 or MFS_DISABLED )\r
             {$ENDIF F_P/DELPHI}\r
             read GetState write SetState;\r
    {* Enabled state of the item. Whaen assigned, Grayed state also is\r
       set to arbitrary value (i.e., when Enabled is set to true, Grayed\r
       is set to FALSE. }\r
    property DefaultItem: Boolean index MFS_DEFAULT read GetState write SetState;\r
    {* Set this property to TRUE to make menu item default. Default item\r
       is drawn with bold.\r
       |<br>If you change DefaultItem at run-time and whant\r
       to provide changing its visual state, recreate the item first resetting\r
       Visible property, then setting it again. }\r
    property Highlight: Boolean index MFS_HILITE read GetState write SetState;\r
    {* Highlight state of the item. }\r
    property Visible: Boolean read FVisible write SetVisible;\r
    {* Visibility of menu item. }\r
    property Data: Pointer read FData write SetData;\r
    {* Data pointer, associated with the menu item. }\r
    property Bitmap: HBitmap read FBitmap write SetBitmap;\r
    {* Bitmap used for unchecked state of the menu item. }\r
    property BitmapChecked: HBitmap read FBmpChecked write SetBmpChecked;\r
    {* Bitmap used for checked state of the menu item. }\r
    property BitmapItem: HBitmap read FBmpItem write SetBmpItem;\r
    {* Bitmap used for item itself. In addition, following special values\r
       are possible:\r
       HBMMENU_CALLBACK, HBMMENU_MBAR_CLOSE, HBMMENU_MBAR_CLOSE_D,\r
       HBMMENU_MBAR_MINIMIZE, HBMMENU_MBAR_MINIMIZE_D, HBMMENU_MBAR_RESTORE,\r
       HBMMENU_POPUP_CLOSE, HBMMENU_POPUP_MAXIMIZE, HBMMENU_POPUP_MINIMIZE,\r
       HBMMENU_POPUP_RESTORE, HBMMENU_SYSTEM. }\r
    property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator;\r
    {* Accelerator for menu item. }\r
    property HelpContext: Integer read FHelpContext write SetHelpContext;\r
    {* Help context for entire menu (help context can not be assigned to\r
       individual menu items). }\r
\r
    procedure AssignEvents( StartIdx: Integer; Events: array of TOnMenuItem );\r
    {* It is possible to assign its own event handler to every menu item\r
       using this call. This procedure also is called automatically in\r
       a constructor NewMenuEx. }\r
\r
    procedure Popup( X, Y : Integer );\r
    {* Only for popup menu - to popup it at the given position on screen. }\r
    procedure PopupEx( X, Y: Integer );\r
    {* This version of popup command is very useful, when popup menu is activated\r
       when its parent window is not visible (e.g., for a kind of applications,\r
       which always are invisible, and can be activated only using tray icon).\r
       PopupEx method provides correct tracking of menu disappearing when mouse\r
       is clicked anywhere else on screen, fixing strange menu behavior in some\r
       Windows versions (NT).\r
       |<br>\r
       Actually, when PopupEx used, parent form is shown but below of visible\r
       screen, and when menu is disappearing, previous state of the form (visibility\r
       and position) are restored. If such solvation is not satisfying You,\r
       You can do something else (e.g., use region clipping, etc.) }\r
    property OnPopup: TOnEvent read fOnPopup write fOnPopup;\r
    {* This event occurs before the popup menu is shown. }\r
    property NotPopup: Boolean read FNotPopup write FNotPopup;\r
    {* Set this property to true to prevent popup of popup menu, e.g. in\r
       OnPopup event handler. }\r
    property Flags: DWORD read FPopupFlags write FPopupFlags;\r
    {* Pop-up flags, which are used to call TrackPopupMenuEx, when Popup or\r
       PopupEx method is called. Can be a combination of following values:\r
       |<br>\r
       TPM_CENTERALIGN or TPM_LEFTALIGN or TPM_RIGHTALIGN\r
       |<br>\r
       TPM_BOTTOMALIGN or TPM_TOPALIGN or TPM_VCENTERALIGN\r
       |<br>\r
       TPM_NONOTIFY or TPM_RETURNCMD\r
       |<br>\r
       TPM_LEFTBUTTON or TPM_RIGHTBUTTON\r
       |<br>\r
       TPM_HORNEGANIMATION or TPM_HORPOSANIMATION or TPM_NOANIMATION or\r
       TPM_VERNEGANIMATION or TPM_VERPOSANIMATION\r
       |<br>\r
       TPM_HORIZONTAL or TPM_VERTICAL.\r
       |<br>\r
       By default, a combination TPM_LEFTALIGN or TPM_LEFTBUTTON is used. }\r
    function Insert(InsertBefore: Integer; ACaption: PChar; Event: TOnMenuItem;\r
             Options: TMenuOptions): PMenu;\r
    {* Inserts new menu item before item, given by Id (>=4096) or index\r
       value InsertBefore. Pointer to an object created is returned. }\r
    property SubMenu: HMenu read FHandle; // write SetSubMenu;\r
    {* Submenu associated with the menu item. The same as Handle. It was possible\r
       in ealier versions to change this value, replacing (removing, assigning)\r
       entire popup menu as a submenu for menu item.\r
       But in modern version of TMenu, this is not possible.\r
       Instead, entire menu object should be added or removed using\r
       InsertSubmenu or RemoveSubmenu methods. }\r
    procedure InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer );\r
    {* Inserts existing menu item (together with its subitems if any present)\r
       into given position. See also RemoveSubMenu. }\r
    function RemoveSubMenu( ItemToRemove: Integer ): PMenu;\r
    {* Removes menu item from the menu, returning TMenu object, representing it,\r
       if submenu item, having its own children, detached. If an individual menu\r
       item is removed, nil is returned.\r
       This function can be useful to add or remove dynamically entire submenus\r
       (created together with its subitems). }\r
    property OnMeasureItem: TOnMeasureItem read FOnMeasureItem write SetOnMeasureItem;\r
    {* This event is called for owner-drawn menu items. Event handler should return\r
       menu item height in lower word of a result and item width (for menu) in\r
       high word of result. If either for height or for width returned value is 0,\r
       a default one is used. }\r
    property OnDrawItem: TOnDrawItem read FOnDrawItem write SetOnDrawItem;\r
    {* This event is called for owner-drawn menu items. }\r
    property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw;\r
    {* Set this property to true for some items to make it owner-draw. }\r
\r
    // For compatibility with old code (be sure that item with given index\r
    // actually exists):\r
    function GetMenuItemHandle( Idx : Integer ): DWORD;\r
    {* Returns Id of menu item with given index. }\r
    property ItemHandle[ Idx: Integer ]: DWORD read GetMenuItemHandle;\r
    {* Returns handle for item given by index. }\r
    property ItemChecked[ Idx : Integer ] : Boolean read GetItemChecked write SetItemChecked;\r
    {* True, if correspondent menu item is checked. }\r
    procedure RadioCheck( Idx : Integer );\r
    {* Call this method to check radio item. For radio items, do not\r
       use assignment to ItemChecked or Checked properties. }\r
    property ItemBitmap[ Idx: Integer ]: HBitmap read GetItemBitmap write SetItemBitmap;\r
    {* This property allows to assign bitmap to menu item (for unchecked state\r
       only - for checked menu items default checkmark bitmap is used). }\r
    procedure AssignBitmaps( StartIdx: Integer; Bitmaps: array of HBitmap );\r
    {* Can be used to assign bitmaps to several menu items during one call. }\r
    property ItemText[ Idx: Integer ]: String read GetItemText write SetItemText;\r
    {* This property allows to get / modify menu item text at run time. }\r
    property ItemEnabled[ Idx: Integer ]: Boolean read GetItemEnabled write SetItemEnabled;\r
    {* Controls enabling / disabling menu items. Disabled menu items are\r
       displayed (grayed) but inaccessible to click. }\r
    property ItemVisible[ Idx: Integer ]: Boolean read GetItemVisible write SetItemVisible;\r
    {* This property allows to simulate visibility of menu items (implementing\r
       it by removing or inserting again if needed. For items of submenu, which\r
       is made invisible, True is returned. If such item made Visible, entire\r
       submenu with all its parent menu items becomes visible. To release menu\r
       properly it is necessary to make before all its items visible again.\r
       This does not matter, if menu is released at the end of execution, but\r
       can be sensible if owner form is destroyed and re-created at run time\r
       dynamically. }\r
    function ParentItem( Idx: Integer ): Integer;\r
    {* Returns index of parent menu item (for submenu item). If there are no\r
       such item (Idx corresponds to root level menu item), -1 is returned. }\r
    property ItemAccelerator[ Idx: Integer ]: TMenuAccelerator read GetItemAccelerator write SetItemAccelerator;\r
    {* Allows to get / change accelerator key kodes assigned to menu items.\r
       Has no effect unless SupportMnemonics called for a form. }\r
    property ItemSubmenu[ Idx: Integer ]: HMenu read GetItemSubmenu; // write SetItemSubmenu;\r
    {* Retrieves submenu item dynamically. See also SubMenu property. }\r
\r
    // by Sergey Shisminzev:\r
    function AddItem(ACaption: PChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;\r
    {* Adds menu item dynamically. Returns ID of the added item. }\r
    function InsertItem(InsertBefore: Integer; ACaption: PChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;\r
    {* Inserts menu item before an item with ID, given by InsertBefore parameter. }\r
    function InsertItemEx(InsertBefore: Integer; ACaption: PChar; Event: TOnMenuItem; Options: TMenuOptions;\r
             ByPosition: Boolean): Integer;\r
    {* Inserts menu item by command or by position, dependant on ByPosition parameter }\r
    procedure RedrawFormMenuBar;\r
    {* }\r
\r
    {$IFDEF USE_MENU_CURCTL}\r
    property CurCtl: PControl read fCurCtl;\r
    {* By Alexander Pravdin. This property is assigned to a control which were\r
       initiated a pop-up, for popup menu. }\r
    {$ENDIF USE_MENU_CURCTL}\r
\r
  end;\r
//[END OF TMenu DEFINITION]\r
\r
//[MenuStructSize VARIABLE]\r
function MenuStructSize: Integer;\r
{* Returns 44 under Windows95, and 48 (=sizeof(TMenuItemInfo) under all other\r
   Windows versions. }\r
\r
//[NewMenu DECLARATION]\r
function NewMenu( AParent : PControl; MaxCmdReserve: DWORD; const Template : array of PChar;\r
                      aOnMenuItem: TOnMenuItem ): PMenu;\r
{* Menu constructor. First created menu becomes main menu of form (if AParent\r
   is a form). All other menus becomes popup (can be activated using Popup\r
   method). To provide dynamic replacing of main menu, create all popup\r
   menus as children of any other control, not form itself.\r
   When Menu is created, pass FirstCmd integer value to set it\r
   as ID of first menu item (all other ID's obtained by incrementing this value),\r
   and Template, which is an array of PChar (usually array of string constants),\r
   containing list of menu item identifiers and/or formatting characters.\r
|<br>&nbsp;&nbsp;&nbsp;\r
  FirstCmd value is assigned to first menu item created as its ID,\r
  all follow menu items are assigned to ID's obtained from FirstCmd incrementing\r
  it by 1. It is desirable to provide not intersected ranges of ID's for\r
  defferent menus in the applet.\r
|<br>&nbsp;&nbsp;&nbsp;\r
  Following formatting characters can be used in menu template strings:\r
|&L=<br><b>%1</b>\r
  <L &amp; (in identifier)> - to underline next character and use it as a shortcut character\r
           when possible;\r
  <L + (in front of identifier)> - to make item checked. If also\r
|<b>!</b> is used before <b>\r
  &\r
|</b> than radioitem is defined;\r
  <L - (in front of identifier)> - item not checked;\r
  <L - (separate)> - separator (between two items);\r
  <L ( (separate)> - start of submenu;\r
  <L ) (separate)> - end of submenu;\r
|<br>&nbsp;&nbsp;&nbsp;\r
  To get access to menu items, use constants 0, 1, etc. It is a good idea\r
  to create special enumerated type to index correspondent menu items\r
  using Ord( ) operator. Note in that case, that it is necessary only to\r
  define constants correspondent to identifiers (positions, correspondent\r
  to separators or submenu brackets are not identified by numbers).\r
|<br>&nbsp;&nbsp;&nbsp;\r
}\r
\r
function NewMenuEx( AParent : PControl; FirstCmd : Integer; const Template : array of PChar;\r
                      aOnMenuItems: array of TOnMenuItem ): PMenu;\r
{* Creates menu, assigning its own event handler for every (enough) menu item. }\r
\r
//[MakeAccelerator DECLARATION]\r
function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;\r
{* Creates accelerator item to assign it to TMenu.ItemAccelerator[ ] property\r
   easy.}\r
\r
//[GetAcceleratorText DECLARATION]\r
// {YS} added 7 Aug 2004\r
function GetAcceleratorText( const Accelerator: TMenuAccelerator ): string;\r
{* Returns text representation of accelerator. }\r
\r
// NewActionList, TAction - by Yury Sidorov\r
//[ACTIONS OBJECT]\r
{ ----------------------------------------------------------------------\r
\r
                TAction and TActionList\r
\r
----------------------------------------------------------------------- }\r
type\r
  PControlRec = ^TControlRec;\r
  TOnUpdateCtrlEvent = procedure(Sender: PControlRec) of object;\r
\r
  TCtrlKind = (ckControl, ckMenu, ckToolbar);\r
  TControlRec = record\r
    Ctrl: PObj;\r
    CtrlKind: TCtrlKind;\r
    ItemID: integer;\r
    UpdateProc: TOnUpdateCtrlEvent;\r
  end;\r
\r
  {++}(* TAction = class;*){--}\r
  PAction = {-}^{+}TAction;\r
\r
  {++}(* TActionList = class;*){--}\r
  PActionList = {-}^{+}TActionList;\r
\r
//[TAction DEFINITION]\r
  TAction = {-} object( TObj ) {+}{++}(*class*){--}\r
  {*! Use action objects, in conjunction with action lists, to centralize the response\r
      to user commands (actions).\r
      Use AddControl, AddMenuItem, AddToolbarButton methods to link controls to an action.\r
      See also TActionList.\r
      }\r
  protected\r
    FControls: PList;\r
    FCaption: string;\r
    FChecked: boolean;\r
    FVisible: boolean;\r
    FEnabled: boolean;\r
    FHelpContext: integer;\r
    FHint: string;\r
    FOnExecute: TOnEvent;\r
    FAccelerator: TMenuAccelerator;\r
    FShortCut: string;\r
    procedure DoOnMenuItem(Sender: PMenu; Item: Integer);\r
    procedure DoOnToolbarButtonClick(Sender: PControl; BtnID: Integer);\r
    procedure DoOnControlClick(Sender: PObj);\r
\r
    procedure SetCaption(const Value: string);\r
    procedure SetChecked(const Value: boolean);\r
    procedure SetEnabled(const Value: boolean);\r
    procedure SetHelpContext(const Value: integer);\r
    procedure SetHint(const Value: string);\r
    procedure SetVisible(const Value: boolean);\r
    procedure SetAccelerator(const Value: TMenuAccelerator);\r
    procedure UpdateControls;\r
\r
    procedure LinkCtrl(ACtrl: PObj; ACtrlKind: TCtrlKind; AItemID: integer; AUpdateProc: TOnUpdateCtrlEvent);\r
    procedure SetOnExecute(const Value: TOnEvent);\r
\r
    procedure UpdateCtrl(Sender: PControlRec);\r
    procedure UpdateMenu(Sender: PControlRec);\r
    procedure UpdateToolbar(Sender: PControlRec);\r
\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    procedure LinkControl(Ctrl: PControl);\r
    {* Add a link to a TControl or descendant control. }\r
    procedure LinkMenuItem(Menu: PMenu; MenuItemIdx: integer);\r
    {* Add a link to a menu item. }\r
    procedure LinkToolbarButton(Toolbar: PControl; ButtonIdx: integer);\r
    {* Add a link to a toolbar button. }\r
    procedure Execute;\r
    {* Executes a OnExecute event handler. }\r
    property Caption: string read FCaption write SetCaption;\r
    {* Text caption. }\r
    property Hint: string read FHint write SetHint;\r
    {* Hint (tooltip). Currently used for toolbar buttons only. }\r
    property Checked: boolean read FChecked write SetChecked;\r
    {* Checked state. }\r
    property Enabled: boolean read FEnabled write SetEnabled;\r
    {* Enabled state. }\r
    property Visible: boolean read FVisible write SetVisible;\r
    {* Visible state. }\r
    property HelpContext: integer read FHelpContext write SetHelpContext;\r
    {* Help context. }\r
    property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator;\r
    {* Accelerator for menu items. }\r
    property OnExecute: TOnEvent read FOnExecute write SetOnExecute;\r
    {* This event is executed when user clicks on a linked object or Execute method was called. }\r
  end;\r
//[END OF TAction DEFINITION]\r
\r
//[TActionList DEFINITION]\r
  TActionList = {-} object( TObj ) {+}{++}(*class*){--}\r
  {*! TActionList maintains a list of actions used with components and controls,\r
     such as menu items and buttons.\r
     Action lists are used, in conjunction with actions, to centralize the response\r
     to user commands (actions).\r
     Write an OnUpdateActions handler to update actions state.\r
     Created using function NewActionList.\r
     See also TAction.\r
  }\r
  protected\r
    FOwner: PControl;\r
    FActions: PList;\r
    FOnUpdateActions: TOnEvent;\r
    function GetActions(Idx: integer): PAction;\r
    function GetCount: integer;\r
  protected\r
    procedure DoUpdateActions(Sender: PObj);\r
  public\r
    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}\r
    function Add(const ACaption, AHint: string; OnExecute: TOnEvent): PAction;\r
    {* Add a new action to the list. Returns pointer to action object. }\r
    procedure Delete(Idx: integer);\r
    {* Delete action by index from list. }\r
    procedure Clear;\r
    {* Clear all actions in the list. }\r
    property Actions[Idx: integer]: PAction read GetActions;\r
    {* Access to actions in the list. }\r
    property Count: integer read GetCount;\r
    {* Number of actions in the list.. }\r
    property OnUpdateActions: TOnEvent read FOnUpdateActions write FOnUpdateActions;\r
    {* Event handler to update actions state. This event is called each time when application\r
      goes in the idle state (no messages in the queue). }\r
  end;\r
//[END OF TActionList DEFINITION]\r
\r
//[NewActionList DECLARATION]\r
function NewActionList(AOwner: PControl): PActionList;\r
{* Action list constructor. AOwner - owner form.\r
|<hr>\r
\r
\r
\r
\r
\r
\r
\r
\r
   <R System functions and working with windows>\r
}\r
//[Window FUNCTIONS DECLARATIONS]\r
type\r
  TWindowChildKind = ( wcActive, wcFocus, wcCapture, wcMenuOwner,\r
                       wcMoveSize, wcCaret );\r
  {* Type of window child kind. Used in function GetWindowChild. }\r
\r
function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd;\r
{* Returns child of given top-level window, having given characteristics.\r
   For example, it is possible to get know for foreground window,\r
   which of its child window has focus. This function does not work in old\r
   Windows 95 (returns Wnd in that case). But for Windows 98, Windows NT/2000\r
   this function works fine. To obtain focused child of the window,\r
   use GetFocusedWindow, which is independant from Windows version. }\r
\r
function GetFocusedChild( Wnd: HWnd ): HWnd;\r
{* Returns focused child of given window (which should be foreground\r
   and active, certainly). 0 is returned either if Wnd is not active\r
   or Wnd has no focused child window. }\r
\r
function Stroke2Window( Wnd: HWnd; const S: String ): Boolean;\r
{* Posts characters from string S to those child window of Wnd, which\r
   has focus now (top-level window Wnd must be foreground, and have\r
   focused edit-aware control to receive the stroke).\r
   |<br>\r
   This function allows only to post typeable characters (including\r
   such special symbols as #13 (Enter), #9 (Tab), #8 (BackSpace), etc.\r
   |<br>\r
   See also function Stroke2WindowEx, which allows to post any key down\r
   and up events, simulating keyboard for given (automated) application. }\r
\r
function Stroke2WindowEx( Wnd: HWnd; const S: String; Wait: Boolean ): Boolean;\r
{* In addition to function Stroke2Window, this one can send special keys\r
   to given window, including functional keys and navigation keys. To\r
   post special key to target window, place a combination of names of\r
   such key together with keys, which should be passed simultaneously,\r
   between square or figure brackets. For example, [Ctrl F1], [Alt Shift Home],\r
   [Ctrl E]. For letters and usual characters, it is not necessary to\r
   simulate pressing it with determining all Shift combinations and it is\r
   sufficient to pass characters as is. (E.g., not '[Shift 1]', but '!'). }\r
\r
function FindWindowByThreadID( ThreadID : DWORD ) : HWnd;\r
{* Searches for window, belonging to a given thread. }\r
\r
function GetDesktopRect : TRect;\r
{* Returns rectangle of screen, free of taskbar and other\r
   similar app-bars, which reduces size of available desktop\r
   when created. }\r
function GetWorkArea: TRect;\r
{* The same as GetDesktopRect, but obtained calling SystemParametersInfo. }\r
\r
function ExecuteWait( const AppPath, CmdLine, DfltDirectory: String;\r
         Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean;\r
{* Allows to execute an application and wait when it is finished. Pass\r
   INFINITE constant as TimeOut, if You sure that application is finished\r
   anyway. If another value passed as a TimeOut (in milliseconds), and\r
   application was not finished for that time, ExecuteWait is returning\r
   FALSE, and if ProcID is not nil, than ProcID^ contains started process\r
   handle (it can be used to wait it more, or to terminate it using\r
   TerminateProcess API function).\r
   |<br>\r
   Launching application can be console or GUI - it does not matter.\r
   Pass SW_SHOW, SW_HIDE or other SW_XXX constant as Show parameter\r
   as appropriate.\r
   |<br>\r
   Trie is returned only in case when application specified was launched\r
   successfully and finished for TimeOut specified. Otherwise, check\r
   ProcID^ variable: if it is 0, process could not be launched (and it\r
   is possible to get information about error using GetLastError API\r
   function in a such case). You can freely pass nil in place of ProcID\r
   parameter, but this is acually correct only when TimeOut is INFINITE. }\r
function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: String;\r
         Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean;\r
{* Executes an application with its console input and output redirection.\r
   Terminating of the application is not waiting, but if ProcID pointer\r
   is defined, it receives process Id launched, so it is possible to\r
   call WaitForSingleObject for it. InPipe is a pointer to THandle variable\r
   which receives a handle to input pipe of the console redirected. The same\r
   is for OutPipeWr and OutPipeRd, but for output of the console redirected.\r
   Before reading from OutPipeRd^, first close OutPipeWr^. If you run\r
   simple console application, for which you want to read results after its\r
   termination, you can use ExecuteConsoleAppIORedirect instead.\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   Notes: if your application is not console and it does not create console\r
   using AllocConsole, this function will fail to redirect input-output. }\r
function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: String;\r
         Show: DWORD; const InStr: String; var OutStr: String; WaitTimeout: DWORD )\r
         : Boolean;\r
{* Executes an application, redirecting its console input and output.\r
   After redirecting input and output and launching the application,\r
   content of InStr is written to input stream of the application, then\r
   the application is waiting for its termination (WaitTimeout milliseconds\r
   or INFINITE, as passed) and console output of the application is read to\r
   OutStr. TRUE is returned only in case, when all these tasks are\r
   completed successfully.\r
   |<br>&nbsp;&nbsp;&nbsp;\r
   Notes: if your application is not console and it does not create console\r
   using AllocConsole, this function will fail to redirect input-output. }\r
\r
\r
function WindowsShutdown( const Machine : String; Force, Reboot : Boolean ) : Boolean;\r
{* Shut down of Windows NT. Pass Machine = '' to shutdown this PC.\r
   Pass Reboot = True to reboot immediatelly after shut down. }\r
\r
type\r
  TWindowsVersion = ( wv31, wv95, wv98, wvNT, wvY2K, wvXP, wvLongHorn );\r
  {* Windows versions constants. }\r
  TWindowsVersions = Set of TWindowsVersion;\r
  {* Set of Windows version (e.g. to define a range of versions supported by the\r
     application). }\r
\r
function WinVer : TWindowsVersion;\r
{* Returns Windows version. }\r
function IsWinVer( Ver : TWindowsVersions ) : Boolean;\r
{* Returns True if Windows version is in given range of values. }\r
\r
//[Parameters FUNCTIONS DECLARATIONS]\r
function ParamStr( Idx: Integer ): String;\r
{* Returns command-line parameter by index. This function supersides\r
   standard ParamStr function. }\r
function ParamCount: Integer;\r
{* Returns number of parameters in command line.\r
|<hr>\r
}\r
\r
\r
//{$DEFINE CHK_BITBLT}\r
procedure Chk_BitBlt;\r
{$IFDEF ASM_VERSION}\r
procedure StartDC;\r
procedure FinishDC;\r
{$ENDIF ASM_VERSION}\r
\r
//[WndProcXXX OTHER DECLARATIONS]\r
function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
\r
var CreatingWindow: PControl;\r
    //ActiveWindow: HWnd;\r
\r
//[Assert OPERATOR DECLARATION]\r
{-}\r
{$IFDEF _D2}\r
// Assert operator was not available in Delphi2. Provide here easy Assert\r
// procedure for Delphi2.\r
procedure Assert( Cond: Boolean; const Msg: String );\r
\r
var AssertErrorProc: procedure( const Message, Filename: AnsiString; LineNumber: Integer );\r
{$ENDIF}\r
{+}\r
\r
\r
//[CUSTOM EXTENSIONS]\r
{$IFDEF USE_CUSTOMEXTENSIONS}\r
  {$I CUSTOM_KOL_EXTENSION.inc} // See comments in TControl\r
{$ENDIF}\r
\r
\r
{$IFDEF DEBUG_ENDSESSION}\r
var EndSession_Initiated: Boolean;\r
{$ENDIF}\r
\r
//[FMMNotify VARIABLE]\r
var\r
  FMMNotify: procedure( var Msg: TMsg );\r
\r
//[procedure ClearText forward declaration]\r
procedure ClearText( Sender: PControl );\r
//[procedure ClearListbox forward declaration]\r
procedure ClearListbox( Sender: PControl );\r
//[procedure ClearCombobox forward declaration]\r
procedure ClearCombobox( Sender: PControl );\r
//[procedure ClearListView forward declaration]\r
procedure ClearListView( Sender: PControl );\r
//[procedure ClearTreeView forward declaration]\r
procedure ClearTreeView( TV: PControl );\r
\r
//[START OF ACTIONS]\r
const\r
  ButtonActions: TCommandActions = (\r
    aClear: ClearText;\r
    aAddText: nil;\r
    aClick: BN_CLICKED;\r
    aEnter: BN_SETFOCUS;\r
    aLeave: BN_KILLFOCUS;\r
    aChange: 0; //BN_CLICKED;\r
    aSelChange: 0;\r
    aGetCount: 0;\r
    aSetCount: 0;\r
    aGetItemLength: 0;\r
    aGetItemText: 0;\r
    aSetItemText: 0;\r
    aGetItemData: 0;\r
    aSetItemData: 0;\r
    aAddItem: 0;\r
    aDeleteItem: 0;\r
    aInsertItem: 0;\r
    aFindItem: 0;\r
    aFindPartial: 0;\r
    aItem2Pos: 0;\r
    aPos2Item: 0;\r
    aGetSelCount: 0;\r
    aGetSelected: 0;\r
    aGetSelRange: 0;\r
    aExGetSelRange: 0;\r
    aGetCurrent: 0;\r
    aSetSelected: 0;\r
    aSetCurrent: 0;\r
    aSetSelRange: 0;\r
    aExSetSelRange: 0;\r
    aGetSelection: 0;\r
    aReplaceSel: 0;\r
    aTextAlignLeft: BS_LEFT;\r
    aTextAlignRight: BS_RIGHT;\r
    aTextAlignCenter: BS_CENTER;\r
    aTextAlignMask: 0;\r
    aVertAlignCenter: BS_VCENTER shr 8;\r
    aVertAlignTop: BS_TOP shr 8;\r
    aVertAlignBottom: BS_BOTTOM shr 8;\r
    aDir: 0;\r
    aSetLimit: 0;\r
    aSetImgList: 0;\r
    aAutoSzX: 14;\r
    aAutoSzY: 0;\r
    aSetBkColor: 0;\r
  );\r
\r
const\r
  LabelActions: TCommandActions = (\r
    aClear: ClearText;\r
    aAddText: nil;\r
    aClick: 0;\r
    aEnter: 0;\r
    aLeave: 0;\r
    aChange: 0;\r
    aSelChange: 0;\r
    aGetCount: 0;\r
    aSetCount: 0;\r
    aGetItemLength: 0;\r
    aGetItemText: 0;\r
    aSetItemText: 0;\r
    aGetItemData: 0;\r
    aSetItemData: 0;\r
    aAddItem: 0;\r
    aDeleteItem: 0;\r
    aInsertItem: 0;\r
    aFindItem: 0;\r
    aFindPartial: 0;\r
    aItem2Pos: 0;\r
    aPos2Item: 0;\r
    aGetSelCount: 0;\r
    aGetSelected: 0;\r
    aGetSelRange: 0;\r
    aExGetSelRange: 0;\r
    aGetCurrent: 0;\r
    aSetSelected: 0;\r
    aSetCurrent: 0;\r
    aSetSelRange: 0;\r
    aExSetSelRange: 0;\r
    aGetSelection: 0;\r
    aReplaceSel: 0;\r
    aTextAlignLeft: SS_LEFT;\r
    aTextAlignRight: SS_RIGHT;\r
    aTextAlignCenter: SS_CENTER;\r
    aTextAlignMask: SS_LEFTNOWORDWRAP;\r
    aVertAlignCenter: SS_CENTERIMAGE shr 8;\r
    aVertAlignTop: 0;\r
    aVertAlignBottom: 0;\r
    aDir: 0;\r
    aSetLimit: 0;\r
    aSetImgList: 0;\r
    aAutoSzX: 1;\r
    aAutoSzY: 1;\r
    aSetBkColor: 0;\r
  );\r
\r
const\r
  EN_LINK                             = $070b;\r
  EditActions: TCommandActions = (\r
    aClear: ClearText;\r
    aAddText: nil;\r
    aClick: 0;\r
    aEnter: EN_SETFOCUS;\r
    aLeave: EN_KILLFOCUS;\r
    aChange: EN_CHANGE;\r
    aSelChange: 0;\r
    aGetCount: EM_GETLINECOUNT;\r
    aSetCount: 0;\r
    aGetItemLength: EM_LINELENGTH;\r
    aGetItemText: EM_GETLINE;\r
    aSetItemText: EM_REPLACESEL;\r
    aGetItemData: 0;\r
    aSetItemData: 0;\r
    aAddItem: 0;\r
    aDeleteItem: 0;\r
    aInsertItem: 0;\r
    aFindItem: 0;\r
    aFindPartial: 0;\r
    aItem2Pos: EM_LINEINDEX;\r
    aPos2Item: EM_LINEFROMCHAR;\r
    aGetSelCount: EM_GETSEL;\r
    aGetSelected: 0;\r
    aGetSelRange: EM_GETSEL;\r
    aExGetSelRange: 0;\r
    aGetCurrent: EM_LINEINDEX;\r
    aSetSelected: 0;\r
    aSetCurrent: 0;\r
    aSetSelRange: EM_SETSEL;\r
    aExSetSelRange: 0;\r
    aGetSelection: 0;\r
    aReplaceSel: EM_REPLACESEL;\r
    aTextAlignLeft: ES_LEFT;\r
    aTextAlignRight: ES_RIGHT;\r
    aTextAlignCenter: ES_CENTER;\r
    aTextAlignMask: 0;\r
    aVertAlignCenter: 0;\r
    aVertAlignTop: 0;\r
    aVertAlignBottom: 0;\r
    aDir: 0;\r
    aSetLimit: EM_SETLIMITTEXT;\r
    aSetImgList: 0;\r
    aAutoSzX: 0;\r
    aAutoSzY: 6;\r
    aSetBkColor: 0;\r
    aItem2XY: EM_POSFROMCHAR;\r
  );\r
\r
const\r
  ListActions: TCommandActions = (\r
    aClear: ClearListbox;\r
    aAddText: nil;\r
    aClick: LBN_DBLCLK;\r
    aEnter: LBN_SETFOCUS;\r
    aLeave: LBN_KILLFOCUS;\r
    aChange: 0;\r
    aSelChange: LBN_SELCHANGE;\r
    aGetCount: LB_GETCOUNT;\r
    aSetCount: LB_SETCOUNT;\r
    aGetItemLength: LB_GETTEXTLEN;\r
    aGetItemText: LB_GETTEXT;\r
    aSetItemText: 0;\r
    aGetItemData: LB_GETITEMDATA;\r
    aSetItemData: LB_SETITEMDATA;\r
    aAddItem: LB_ADDSTRING;\r
    aDeleteItem: LB_DELETESTRING;\r
    aInsertItem: LB_INSERTSTRING;\r
    aFindItem: LB_FINDSTRINGEXACT;\r
    aFindPartial: LB_FINDSTRING;\r
    aItem2Pos: 0;\r
    aPos2Item: 0;\r
    aGetSelCount: LB_GETSELCOUNT;\r
    aGetSelected: LB_GETSEL;\r
    aGetSelRange: 0;\r
    aExGetSelRange: 0;\r
    aGetCurrent: LB_GETCURSEL;\r
    aSetSelected: LB_SETSEL;\r
    aSetCurrent: LB_SETCURSEL;\r
    aSetSelRange: 0;\r
    aExSetSelRange: 0;\r
    aGetSelection: 0;\r
    aReplaceSel: 0;\r
    aTextAlignLeft: 0;\r
    aTextAlignRight: 0;\r
    aTextAlignCenter: 0;\r
    aTextAlignMask: 0;\r
    aVertAlignCenter: 0;\r
    aVertAlignTop: 0;\r
    aVertAlignBottom: 0;\r
    aDir: LB_DIR;\r
    aSetLimit: 0;\r
    aSetImgList: 0;\r
    aAutoSzX: 0;\r
    aAutoSzY: 0;\r
    aSetBkColor: 0;\r
    aItem2XY: LB_GETITEMRECT;\r
  );\r
\r
const\r
  ComboActions: TCommandActions = (\r
    aClear: ClearCombobox;\r
    aAddText: nil;\r
    aClick: CBN_DBLCLK;\r
    aEnter: CBN_SETFOCUS;\r
    aLeave: CBN_KILLFOCUS;\r
    aChange: CBN_EDITCHANGE;\r
    aSelChange: CM_CBN_SELCHANGE; // CBN_SELCHANGE;\r
    aGetCount: CB_GETCOUNT;\r
    aSetCount: 0;\r
    aGetItemLength: CB_GETLBTEXTLEN;\r
    aGetItemText: CB_GETLBTEXT;\r
    aSetItemText: 0;\r
    aGetItemData: CB_GETITEMDATA;\r
    aSetItemData: CB_SETITEMDATA;\r
    aAddItem: CB_ADDSTRING;\r
    aDeleteItem: CB_DELETESTRING;\r
    aInsertItem: CB_INSERTSTRING;\r
    aFindItem: CB_FINDSTRINGEXACT;\r
    aFindPartial: CB_FINDSTRING;\r
    aItem2Pos: 0;\r
    aPos2Item: 0;\r
    aGetSelCount: 0;\r
    aGetSelected: CB_GETCURSEL;\r
    aGetSelRange: 0;\r
    aExGetSelRange: 0;\r
    aGetCurrent: CB_GETCURSEL;\r
    aSetSelected: 0;\r
    aSetCurrent: CB_SETCURSEL;\r
    aSetSelRange: 0;\r
    aExSetSelRange: 0;\r
    aGetSelection: 0;\r
    aReplaceSel: 0;\r
    aTextAlignLeft: 0; //ES_LEFT;\r
    aTextAlignRight: 0; //ES_RIGHT;\r
    aTextAlignCenter: 0; //ES_CENTER;\r
    aTextAlignMask: 0;\r
    aVertAlignCenter: 0;\r
    aVertAlignTop: 0;\r
    aVertAlignBottom: 0;\r
    aDir: CB_DIR;\r
    aSetLimit: 0;\r
    aSetImgList: 0;\r
    aAutoSzX: 0;\r
    aAutoSzY: 6;\r
    aSetBkColor: 0;\r
  );\r
\r
const\r
  ListViewActions: TCommandActions = (\r
    aClear: ClearListView;\r
    aAddText: nil;\r
    aClick: 0;\r
    aEnter: 0;\r
    aLeave: 0;\r
    aChange: LVN_ITEMCHANGED;\r
    aSelChange: 0;\r
    aGetCount: LVM_GETITEMCOUNT;\r
    aSetCount: LVM_SETITEMCOUNT;\r
    aGetItemLength: 0;\r
    aGetItemText: 0;\r
    aSetItemText: 0;\r
    aGetItemData: 0;\r
    aSetItemData: 0;\r
    aAddItem: 0;\r
    aDeleteItem: 0;\r
    aInsertItem: 0;\r
    aFindItem: 0;\r
    aFindPartial: 0;\r
    aItem2Pos: 0;\r
    aPos2Item: 0;\r
    aGetSelCount: $8000 or LVM_GETSELECTEDCOUNT;\r
    aGetSelected: 0;\r
    aGetSelRange: 0;\r
    aExGetSelRange: 0;\r
    aGetCurrent: LVM_GETNEXTITEM;\r
    aSetSelected: 0;\r
    aSetCurrent: 0;\r
    aSetSelRange: 0;\r
    aExSetSelRange: 0;\r
    aGetSelection: 0;\r
    aReplaceSel: 0;\r
    aTextAlignLeft: 0;\r
    aTextAlignRight: 0;\r
    aTextAlignCenter: 0;\r
    aTextAlignMask: 0;\r
    aVertAlignCenter: 0;\r
    aVertAlignTop: 0;\r
    aVertAlignBottom: 0;\r
    aDir: 0;\r
    aSetLimit: 0;\r
    aSetImgList: LVM_SETIMAGELIST;\r
    aAutoSzX: 0;\r
    aAutoSzY: 0;\r
    aSetBkColor: LVM_SETBKCOLOR;\r
    aItem2XY: LVM_GETITEMRECT;\r
  );\r
\r
const\r
  TreeViewActions: TCommandActions = (\r
    aClear: ClearTreeView;\r
    aAddText: nil;\r
    aClick: 0;\r
    aEnter: 0;\r
    aLeave: 0;\r
    aChange: TVN_ENDLABELEDIT;\r
    aSelChange: TVN_SELCHANGED;\r
    aGetCount: TVM_GETCOUNT;\r
    aSetCount: 0;\r
    aGetItemLength: 0;\r
    aGetItemText: 0;\r
    aSetItemText: 0;\r
    aGetItemData: 0;\r
    aSetItemData: 0;\r
    aAddItem: 0;\r
    aDeleteItem: 0;\r
    aInsertItem: 0;\r
    aFindItem: 0;\r
    aFindPartial: 0;\r
    aItem2Pos: 0;\r
    aPos2Item: 0;\r
    aGetSelCount: 0;\r
    aGetSelected: 0;\r
    aGetSelRange: 0;\r
    aExGetSelRange: 0;\r
    aGetCurrent: 0;\r
    aSetSelected: 0;\r
    aSetCurrent: 0;\r
    aSetSelRange: 0;\r
    aExSetSelRange: 0;\r
    aGetSelection: 0;\r
    aReplaceSel: 0;\r
    aTextAlignLeft: 0;\r
    aTextAlignRight: 0;\r
    aTextAlignCenter: 0;\r
    aTextAlignMask: 0;\r
    aVertAlignCenter: 0;\r
    aVertAlignTop: 0;\r
    aVertAlignBottom: 0;\r
    aDir: CB_DIR;\r
    aSetLimit: 0;\r
    aSetImgList: TVM_SETIMAGELIST;\r
    aAutoSzX: 0;\r
    aAutoSzY: 0;\r
    aSetBkColor: TVM_SETBKCOLOR;\r
    aItem2XY: TVM_GETITEMRECT;\r
  );\r
\r
const\r
  TabControlActions: TCommandActions = (\r
    aClear: ClearText;\r
    aAddText: nil;\r
    aClick: 0;\r
    aEnter: 0;\r
    aLeave: 0;\r
    aChange: TCN_SELCHANGE;\r
    aSelChange: TCN_SELCHANGE;\r
    aGetCount: TCM_GETITEMCOUNT;\r
    aSetCount: 0;\r
    aGetItemLength: 0;\r
    aGetItemText: 0;\r
    aSetItemText: 0;\r
    aGetItemData: 0;\r
    aSetItemData: 0;\r
    aAddItem: 0;\r
    aDeleteItem: 0;\r
    aInsertItem: 0;\r
    aFindItem: 0;\r
    aFindPartial: 0;\r
    aItem2Pos: 0;\r
    aPos2Item: 0;\r
    aGetSelCount: 0;\r
    aGetSelected: 0;\r
    aGetSelRange: 0;\r
    aExGetSelRange: 0;\r
    aGetCurrent: TCM_GETCURSEL;\r
    aSetSelected: 0;\r
    aSetCurrent: TCM_SETCURSEL; //TCM_SETCURFOCUS;\r
    aSetSelRange: 0;\r
    aExSetSelRange: 0;\r
    aGetSelection: 0;\r
    aReplaceSel: 0;\r
    aTextAlignLeft: 0;\r
    aTextAlignRight: 0;\r
    aTextAlignCenter: 0;\r
    aTextAlignMask: 0;\r
    aVertAlignCenter: 0;\r
    aVertAlignTop: 0;\r
    aVertAlignBottom: 0;\r
    aDir: CB_DIR;\r
    aSetLimit: 0;\r
    aSetImgList: TCM_SETIMAGELIST;\r
    aAutoSzX: 0;\r
    aAutoSzY: 0;\r
    aSetBkColor: 0;\r
    aItem2XY: TCM_GETITEMRECT;\r
  );\r
\r
const\r
  RichEditActions: TCommandActions = (\r
    aClear: ClearText;\r
    aAddText: nil;\r
    aClick: 0;\r
    aEnter: EN_SETFOCUS;\r
    aLeave: EN_KILLFOCUS;\r
    aChange: EN_CHANGE;\r
    aSelChange: EN_SELCHANGE;\r
    aGetCount: EM_GETLINECOUNT;\r
    aSetCount: 0;\r
    aGetItemLength: EM_LINELENGTH;\r
    aGetItemText: EM_GETLINE;\r
    aSetItemText: EM_REPLACESEL;\r
    aGetItemData: 0;\r
    aSetItemData: 0;\r
    aAddItem: 0;\r
    aDeleteItem: 0;\r
    aInsertItem: 0;\r
    aFindItem: 0;\r
    aFindPartial: 0;\r
    aItem2Pos: EM_LINEINDEX;\r
    aPos2Item: EM_LINEFROMCHAR;\r
    aGetSelCount: 0; //EM_EXGETSEL;\r
    aGetSelected: 0;\r
    aGetSelRange: 0;\r
    aExGetSelRange: EM_EXGETSEL;\r
    aGetCurrent: EM_LINEINDEX;\r
    aSetSelected: 0;\r
    aSetCurrent: 0;\r
    aSetSelRange: 0;\r
    aExSetSelRange: EM_EXSETSEL;\r
    aGetSelection: EM_GETSELTEXT;\r
    aReplaceSel: EM_REPLACESEL;\r
    aTextAlignLeft: ES_LEFT;\r
    aTextAlignRight: ES_RIGHT;\r
    aTextAlignCenter: ES_CENTER;\r
    aTextAlignMask: 0;\r
    aVertAlignCenter: 0;\r
    aVertAlignTop: 0;\r
    aVertAlignBottom: 0;\r
    aDir: 0;\r
    aSetLimit: EM_EXLIMITTEXT;\r
    aSetImgList: 0;\r
    aAutoSzX: 0;\r
    aAutoSzY: 0;\r
    aSetBkColor: EM_SETBKGNDCOLOR;\r
    aItem2XY: EM_POSFROMCHAR;\r
  );\r
\r
//[IMPLEMENTATION]\r
implementation\r
\r
//[USES-2]\r
uses\r
  ShellAPI,\r
  commdlg\r
  ; //, commctrl;\r
            // in Delphi3, including of commctrl.pas increases executable\r
            // onto about 30K. So, all needed definitions are copied here\r
            // (see commctrl.inc).\r
//[END OF USES-2]\r
\r
{$IFDEF _D2orD3}\r
const\r
  OFN_ENABLESIZING = $00800000;\r
{$ENDIF}\r
\r
//[procedure Chk_BitBlt_ShowError]\r
procedure Chk_BitBlt_ShowError;\r
var Rslt: Integer;\r
begin\r
    Rslt := GetLastError;\r
    ShowMessage( 'BitBlt ERROR: ' + Int2Str( Rslt )\r
                 + ' ' + SysErrorMessage( Rslt ) );\r
end;\r
//[ENDe Chk_BitBlt_ShowError]\r
\r
//[procedure Chk_BitBlt]\r
procedure Chk_BitBlt;\r
var Rslt: Integer;\r
begin\r
  asm\r
    MOV Rslt, EAX\r
  end;\r
  if Rslt = 0 then\r
  begin\r
    Chk_BitBlt_ShowError;\r
    asm\r
      int 3;\r
    end;\r
  end;\r
end;\r
//[ENDe Chk_BitBlt]\r
\r
//[FUNCTION MulDiv]\r
{$IFNDEF FPC}\r
function MulDiv( A, B, C: Integer ): Integer;\r
asm\r
  IMUL EDX\r
  IDIV ECX\r
end;\r
{$ENDIF}\r
//[END MulDiv]\r
\r
{-}\r
{$ifdef _D2}\r
\r
//[PROCEDURE Assert]\r
procedure Assert( Cond: Boolean; const Msg: String );\r
begin\r
  if not Cond then\r
  begin\r
    AssertErrorProc( Msg, '', 0 );\r
    //MsgOK( Msg );\r
    asm\r
      int 3;\r
    end;\r
  end;\r
end;\r
\r
//[API CreateDIBSection]\r
function CreateDIBSection(DC: HDC; const p2: TBitmapInfo; p3: UINT;\r
  var p4: Pointer; p5: THandle; p6: DWORD): HBITMAP; stdcall;\r
external gdi32 name 'CreateDIBSection';\r
\r
\r
//[PROCEDURE _LStrFromPCharLen]\r
procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);\r
asm\r
        { ->    EAX     pointer to dest }\r
        {       EDX source              }\r
        {       ECX length              }\r
\r
        PUSH    EBX\r
        PUSH    ESI\r
        PUSH    EDI\r
\r
        MOV     EBX,EAX\r
        MOV     ESI,EDX\r
        MOV     EDI,ECX\r
\r
        { allocate new string }\r
\r
        MOV     EAX,EDI\r
\r
        CALL    System.@NewAnsiString\r
        MOV     ECX,EDI\r
        MOV     EDI,EAX\r
\r
        TEST    ESI,ESI\r
        JE      @@noMove\r
\r
        MOV     EDX,EAX\r
        MOV     EAX,ESI\r
        CALL    Move\r
\r
        { assign the result to dest }\r
\r
@@noMove:\r
        MOV     EAX,EBX\r
        CALL    System.@LStrClr\r
        MOV     [EBX],EDI\r
\r
        POP     EDI\r
        POP     ESI\r
        POP     EBX\r
end;\r
{$endif}\r
{+}\r
\r
//[API InitCommonControls]\r
procedure InitCommonControls; external cctrl name 'InitCommonControls';\r
\r
type\r
  TInitCommonControlsEx = packed record\r
    dwSize: DWORD;\r
    dwICC: DWORD;\r
  end;\r
  PInitCommonControlsEx = ^TInitCommonControlsEx;\r
\r
var ComCtl32_Module: HModule;\r
//[procedure DoInitCommonControls]\r
procedure DoInitCommonControls( dwICC: DWORD );\r
var Proc: procedure( ICC: PInitCommonControlsEx ); stdcall;\r
    ICC: TInitCommonControlsEx;\r
begin\r
  InitCommonControls;\r
  if ComCtl32_Module = 0 then\r
    ComCtl32_Module := LoadLibrary( 'comctl32.dll' );\r
  @ Proc := GetProcAddress( ComCtl32_Module, 'InitCommonControlsEx' );\r
  if Assigned( Proc ) then\r
  begin\r
    ICC.dwSize := Sizeof( ICC );\r
    ICC.dwICC := dwICC;\r
    Proc( @ ICC );\r
  end;\r
end;\r
//[END DoInitCommonControls]\r
\r
const size_TRect = 16; // used often in assembler versions of code\r
{-}\r
\r
{$IFDEF ASM_VERSION}\r
const\r
  EmptyString: String = '';\r
\r
//[PROCEDURE EAX2PChar]\r
procedure EAX2PChar;\r
asm\r
        TEST     EAX, EAX\r
        JNZ      @@exit\r
        MOV      EAX, offset[EmptyString]\r
@@exit:\r
end;\r
\r
//[PROCEDURE EDX2PChar]\r
procedure EDX2PChar;\r
asm\r
        TEST     EDX, EDX\r
        JNZ      @@exit\r
        MOV      EDX, offset[EmptyString]\r
@@exit:\r
end;\r
\r
//[PROCEDURE ECX2PChar]\r
procedure ECX2PChar;\r
asm\r
        JECXZ   @@convert\r
        RET\r
@@convert:\r
        MOV     ECX, offset[EmptyString]\r
@@exit:\r
end;\r
\r
//[PROCEDURE RemoveStr]\r
procedure RemoveStr;\r
asm\r
        { <- [ESP+4] = string to remove\r
          -> ESP := ESP + 4\r
             EAX = 0\r
        }\r
        POP      EAX\r
        XCHG     EAX, [ESP]\r
        PUSH     EAX\r
        MOV      EAX, ESP\r
        CALL     System.@LStrClr\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION}\r
{$ENDIF ASM_VERSION}\r
{+}\r
\r
//[PROCEDURE MsgOK]\r
procedure MsgOK( const S: String );\r
begin\r
  MsgBox( S, MB_OK );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function MsgBox]\r
function MsgBox( const S: String; Flags: DWORD ): DWORD;\r
asm\r
        PUSH      EDX\r
        PUSH      EAX\r
\r
        MOV       ECX, [Applet]\r
        XOR       EAX, EAX\r
        JECXZ     @@1\r
        MOV       EAX, [ECX].TControl.fCaption\r
@@1:\r
        XCHG      EAX, [ESP]\r
        PUSH      EAX\r
        PUSH      0\r
        CALL      MessageBox\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function MsgBox( const S: String; Flags: DWORD ): DWORD;\r
var Title: PChar;\r
begin\r
  Title := nil;\r
  if assigned( Applet ) then\r
  begin\r
    Title := PChar( Applet.fCaption );\r
  end;\r
  Result := MessageBox( 0 {Wnd}, PChar( S ), Title, Flags );\r
end;\r
//[END MsgBox]\r
{$ENDIF ASM_VERSION}\r
\r
//[function ShowMsg]\r
function ShowMsg( const S: String; Flags: DWORD ): DWORD;\r
var Title: PChar;\r
    Wnd: HWnd;\r
begin\r
  Title := nil;\r
  Wnd := 0;\r
  if assigned( Applet ) then\r
  begin\r
     Title := PChar( Applet.fCaption );\r
     Wnd := Applet.Handle;\r
  end;\r
  Result := MessageBox( Wnd, PChar( S ), Title, Flags );\r
end;\r
//[END ShowMsg]\r
\r
//[procedure ShowMessage]\r
procedure ShowMessage( const S: String );\r
begin\r
  ShowMsg( S, MB_OK or MB_SETFOREGROUND );\r
end;\r
//[ENDe ShowMessage]\r
\r
//[procedure OKClick]\r
procedure OKClick( Dialog, Btn: PControl );\r
var Rslt: Integer;\r
begin\r
  Rslt := -1;\r
  if Btn <> nil then\r
    Rslt := Btn.Tag;\r
  Dialog.ModalResult := Rslt;\r
  Dialog.Close;\r
end;\r
//[END OKClick]\r
\r
//[procedure KeyClick]\r
procedure KeyClick( Dialog, Btn: PControl; var Key: Longint; Shift: DWORD );\r
begin\r
  if (Key = VK_RETURN) or (Key = VK_ESCAPE) then\r
  begin\r
    if Key = VK_ESCAPE then\r
      Btn := nil;\r
    OKClick( Dialog, Btn );\r
  end;\r
end;\r
//[ENDe KeyClick]\r
\r
//[procedure CloseMsg]\r
procedure CloseMsg( Dummy, Dialog: PControl; var Accept: Boolean );\r
begin\r
  Accept := FALSE;\r
  Dialog.ModalResult := -1;\r
end;\r
//[ENDe CloseMsg]\r
\r
//[function ShowQuestionEx]\r
function ShowQuestionEx( const S: String; Answers: String; CallBack: TOnEvent ): Integer;\r
{$IFDEF F_P105ORBELOW}\r
type POnEvent = ^TOnEvent;\r
     PONKey = ^TOnKey;\r
var M: TMethod;\r
{$ENDIF F_P105ORBELOW}\r
var Dialog: PControl;\r
    Buttons: PList;\r
    Btn: PControl;\r
    AppTermFlag: Boolean;\r
    Lab: PControl;\r
    Y, W, I: Integer;\r
    Title: String;\r
    DlgWnd: HWnd;\r
    AppCtl: PControl;\r
begin\r
  AppTermFlag := AppletTerminated;\r
  AppCtl := Applet;\r
  AppletTerminated := FALSE;\r
  Title := 'Information';\r
  if pos( '/', Answers ) > 0 then\r
    Title := 'Question';\r
  if Applet <> nil then\r
    Title := Applet.Caption;\r
  Dialog := NewForm( Applet, Title ).SetSize( 300, 40 );\r
  Dialog.Style := Dialog.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX);\r
  Dialog.OnClose := TOnEventAccept( MakeMethod( Dialog, @CloseMsg ) );\r
  Dialog.Margin := 8;\r
  Lab := NewEditbox( Dialog, [ eoMultiline, eoReadonly, eoNoHScroll, eoNoVScroll ] ).SetSize( 278, 20 );\r
  Lab.HasBorder := FALSE;\r
  Lab.Color := clBtnFace;\r
  Lab.Caption := S;\r
  Lab.Style := Lab.Style and not WS_TABSTOP;\r
  Lab.TabStop := FALSE;\r
  //Lab.LikeSpeedButton;\r
\r
  //Lab.CreateWindow; //virtual!!! -- not needed, window created in Perform\r
  while TRUE do\r
  begin\r
    Y := HiWord( Lab.Perform( EM_POSFROMCHAR, Length( S ) - 1, 0 ) );\r
    if Y < Lab.Height - 20 then break;\r
    Lab.Height := Lab.Height + 4;\r
    if Lab.Height + 40 > GetSystemMetrics( SM_CYSCREEN ) then break;\r
  end;\r
\r
  Buttons := NewList;\r
  W := 0;\r
  if Answers = '' then\r
  begin\r
    Btn := NewButton( Dialog, '  OK  ' ).PlaceUnder;\r
    W := Btn.Width;\r
    Buttons.Add( Btn );\r
  end\r
    else\r
  while Answers <> '' do\r
  begin\r
    Btn := NewButton( Dialog, '  ' + Parse( Answers, '/' ) + '  ' );\r
    Buttons.Add( Btn );\r
    if W = 0 then\r
      Btn.PlaceUnder\r
    else\r
      Btn.PlaceRight;\r
    Btn.AutoSize( TRUE );\r
    if W > 0 then\r
    begin\r
      //Inc( W, 6 );\r
      Btn.Left := Btn.Left + 6;\r
    end;\r
    W := Btn.BoundsRect.Right + 12;\r
  end;\r
  if Dialog.ClientWidth < W then\r
    Dialog.ClientWidth := W;\r
  W := (Dialog.ClientWidth - W) div 2;\r
  for I := 0 to Buttons.Count-1 do\r
  begin\r
    Btn := Buttons.Items[ I ];\r
    Btn.Tag := I + 1;\r
    {$IFDEF F_P105ORBELOW}\r
    M := MakeMethod( Dialog, @OKClick );\r
    Btn.OnClick := POnEvent( @ M )^;\r
    M := MakeMethod( Dialog, @KeyClick );\r
    Btn.OnKeyDown := POnKey( @ M )^;\r
    {$ELSE}\r
    Btn.OnClick := TOnEvent( MakeMethod( Dialog, @OKClick ) );\r
    Btn.OnKeyDown := TOnKey( MakeMethod( Dialog, @KeyClick ) );\r
    {$ENDIF}\r
    Btn.Left := Btn.Left + W;\r
    if I = 0 then\r
    begin\r
      Btn.ResizeParentBottom;\r
      Dialog.ActiveControl := Btn;\r
    end;\r
  end;\r
  Dialog.CenterOnParent.Tabulate.CanResize := FALSE;\r
  Buttons.Free;\r
\r
  if Assigned( CallBack ) then\r
    CallBack( Dialog );\r
  Dialog.CreateWindow; // virtual!!!\r
\r
  if (Applet <> nil) and Applet.IsApplet then\r
  begin\r
    Dialog.ShowModal;\r
    Result := Dialog.ModalResult;\r
    Dialog.Free;\r
  end\r
    else\r
  begin\r
    DlgWnd := Dialog.Handle;\r
    while IsWindow( DlgWnd ) and (Dialog.ModalResult = 0) do\r
      Dialog.ProcessMessage;\r
    Result := Dialog.ModalResult;\r
    Dialog.Free;\r
    CreatingWindow := nil;\r
    Applet := AppCtl;\r
  end;\r
\r
  AppletTerminated := AppTermFlag;\r
end;\r
//[END ShowQuestionEx]\r
\r
//[function ShowQuestion]\r
function ShowQuestion( const S: String; Answers: String ): Integer;\r
begin\r
  Result := ShowQuestionEx( S, Answers, nil );\r
end;\r
//[END ShowQuestion]\r
\r
//[procedure ShowMsgModal]\r
procedure ShowMsgModal( const S: String );\r
begin\r
  ShowQuestion( S, '' );\r
end;\r
//[ENDe ShowMsgModal]\r
\r
//[procedure SpeakerBeep]\r
procedure SpeakerBeep( Freq: Word; Duration: DWORD );\r
begin\r
  if WinVer >= wvNT then\r
    Windows.Beep( Freq, Duration )\r
  else\r
  begin\r
    if Freq < 18 then Exit;\r
    Freq := 1193181 div Freq;\r
    if Freq = 0 then Exit;\r
    asm\r
        mov al,0b6H\r
        out 43H,al\r
        mov ax,Freq\r
        //xchg al, ah\r
        out 42h,al\r
        xchg al, ah\r
        out 42h,al\r
        in  al,61H\r
        or  al,03H\r
        out 61H,al\r
    end {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ;\r
    Sleep(Duration);\r
    asm\r
        in  al,61H\r
        and al,0fcH\r
        out 61H,al\r
    end {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ;\r
  end;\r
end;\r
//[ENDe SpeakerBeep]\r
\r
{++}(*\r
//[API FormatMessage]\r
function FormatMessage; external kernel32 name 'FormatMessageA';\r
*){--}\r
\r
//[FUNCTION SysErrorMessage]\r
function SysErrorMessage(ErrorCode: Integer): string;\r
var\r
  Len: Integer;\r
  Buffer: array[0..255] of Char;\r
begin\r
  Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or\r
    FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,\r
    SizeOf(Buffer), nil);\r
  while (Len > 0) and (Buffer[Len - 1] in [#0..#32 {, '.'}]) do Dec(Len);\r
  SetString(Result, Buffer, Len);\r
end;\r
//[END SysErrorMessage]\r
\r
//[function MakeMethod]\r
function MakeMethod( Data, Code: Pointer ): TMethod;\r
begin\r
  Result.Data := Data;\r
  Result.Code := Code;\r
end;\r
//[END MakeMethod]\r
\r
//[function GetShiftState]\r
function GetShiftState: DWORD;\r
begin\r
  Result := 0;\r
  if GetKeyState( VK_SHIFT ) < 0 then\r
    Result := Result or MK_SHIFT;\r
  if GetKeyState( VK_CONTROL ) < 0 then\r
    Result := Result or MK_CONTROL;\r
  //if LONGBOOL(Msg.lParam and $20000000) then\r
  if GetKeyState( VK_MENU ) < 0 then\r
    Result := Result or MK_ALT;\r
end;\r
//[END GetShiftState]\r
\r
//[FUNCTION MakeRect]\r
{$IFDEF ASM_VERSION}\r
function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; stdcall;\r
asm\r
        PUSH       ESI\r
        PUSH       EDI\r
\r
        MOV        EDI, @Result\r
        LEA        ESI, [Left]\r
\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
\r
        POP        EDI\r
        POP        ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; stdcall;\r
begin\r
   Result.Left := Left;\r
   Result.Top  := Top;\r
   Result.Right:= Right;\r
   Result.Bottom := Bottom;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END MakeRect]\r
\r
//[FUNCTION RectsEqual]\r
{$IFDEF ASM_VERSION}\r
function RectsEqual( const R1, R2: TRect ): Boolean;\r
asm\r
        //LEA       EAX, [R1]\r
        //LEA       EDX, [R2]\r
        MOV       ECX, size_TRect\r
        CALL      CompareMem\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function RectsEqual( const R1, R2: TRect ): Boolean;\r
begin\r
  Result := CompareMem( @R1, @R2, Sizeof( TRect ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END RectsEqual]\r
\r
//[function RectsIntersected]\r
function RectsIntersected( const R1, R2: TRect ): Boolean;\r
begin\r
  Result := ((R1.Left <= R2.Left) and (R1.Right > R2.Left ) or\r
             (R1.Left <= R2.Right) and (R1.Right >= R2.Right) or\r
             (R1.Left >= R2.Left) and (R1.Right <= R2.Right))\r
             and\r
            ((R1.Top <= R2.Top) and (R1.Bottom > R2.Top) or\r
             (R1.Top <= R2.Bottom) and (R1.Bottom >= R2.Bottom) or\r
             (R1.Top >= R2.Top) and (R1.Bottom <= R2.Bottom)) ;\r
end;\r
//[END RectsIntersected]\r
\r
\r
//[FUNCTION PointInRect]\r
{$IFDEF ASM_VERSION}\r
function PointInRect( const P: TPoint; const R: TRect ): Boolean;\r
asm\r
        PUSH      ESI\r
        MOV       ECX, EAX\r
        MOV       ESI, EDX\r
        LODSD\r
        CMP       EAX, [ECX]\r
        JG        @@fail\r
        LODSD\r
        CMP       EAX, [ECX+4]\r
        JG        @@fail\r
        LODSD\r
        CMP       [ECX], EAX\r
        JG        @@fail\r
        LODSD\r
        CMP       [ECX+4], EAX\r
@@fail: SETLE     AL\r
        POP       ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function PointInRect( const P: TPoint; const R: TRect ): Boolean;\r
begin\r
   Result := (P.x >= R.Left) and (P.x < R.Right)\r
             and (P.y >= R.Top) and (P.y < R.Bottom);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END PointInRect]\r
\r
//[FUNCTION MakePoint]\r
{$IFDEF ASM_VERSION}\r
function MakePoint( X, Y: Integer ): TPoint;\r
asm\r
        MOV      ECX, @Result\r
        MOV      [ECX].TPoint.x, EAX\r
        MOV      [ECX].TPoint.y, EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function MakePoint( X, Y: Integer ): TPoint;\r
begin\r
   Result.x := X;\r
   Result.y := Y;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END MakePoint]\r
\r
//[FUNCTION MakeFlags]\r
{$IFDEF ASM_VERSION}\r
function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, [EAX]\r
        MOV      ESI, EDX\r
        XOR      EDX, EDX\r
        INC      ECX\r
        JZ       @@exit\r
@@loo:\r
        LODSD\r
        TEST     EAX, EAX\r
        JGE      @@ge\r
        NOT      EAX\r
        TEST     BL, 1\r
        JZ       @@or\r
        DEC      EBX\r
@@ge:\r
        TEST     BL, 1\r
        JZ       @@nx\r
@@or:\r
        OR       EDX, EAX\r
@@nx:\r
        SHR      EBX, 1\r
        LOOP     @@loo\r
\r
@@exit:\r
        XCHG     EAX, EDX\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;\r
var I : Integer;\r
    Mask : DWORD;\r
begin\r
  Result := 0;\r
  Mask := FlgSet^;\r
  for I := 0 to High( FlgArray ) do\r
  begin\r
    if (FlgArray[ I ] < 0) and not LongBool( Mask and 1 ) then\r
       Result := Result or not FlgArray[ I ]\r
    else\r
    if (FlgArray[ I ] >= 0) and LongBool( Mask and 1 ) then\r
       Result := Result or FlgArray[ I ];\r
    Mask := Mask shr 1;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END MakeFlags]\r
\r
//[procedure HelpFastIncNum2Els]\r
procedure HelpFastIncNum2Els( DataArray: Pointer; Value, Count: Integer );\r
asm\r
  PUSH ESI\r
  PUSH EDI\r
  {$IFDEF F_P}\r
  MOV ESI, [DataArray]\r
  MOV EDX, [Value]\r
  MOV ECX, [Count]\r
  {$ELSE DELPHI}\r
  MOV ESI, EAX\r
  {$ENDIF F_P/DELPHI}\r
  MOV EDI, ESI\r
  CLD\r
\r
@@1:\r
  LODSD\r
  ADD EAX, EDX\r
  STOSD\r
  LOOP @@1\r
\r
  POP EDI\r
  POP ESI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
//[ENDe HelpFastIncNum2Els]\r
\r
//[procedure Swap]\r
procedure Swap( var X, Y: Integer );\r
{$IFDEF F_P}\r
var Tmp: Integer;\r
begin\r
  Tmp := X;\r
  X := Y;\r
  Y := Tmp;\r
end;\r
{$ELSE DELPHI}\r
asm\r
  MOV  ECX, [EDX]\r
  XCHG ECX, [EAX]\r
  MOV  [EDX], ECX\r
end;\r
//[ENDe Swap]\r
{$ENDIF F_P/DELPHI}\r
\r
//[function Min]\r
function Min( X, Y: Integer ): Integer;\r
asm\r
  {$IFDEF F_P}\r
  MOV EAX, [X]\r
  MOV EDX, [Y]\r
  {$ENDIF F_P}\r
  {$IFDEF USE_CMOV}\r
  CMP   EAX, EDX\r
  CMOVG EAX, EDX\r
  {$ELSE}\r
  CMP EAX, EDX\r
  JLE @@exit\r
  MOV EAX, EDX\r
@@exit:\r
  {$ENDIF}\r
end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF};\r
//[END Min]\r
\r
//[function Max]\r
function Max( X, Y: Integer ): Integer;\r
asm\r
  {$IFDEF F_P}\r
  MOV EAX, [X]\r
  MOV EDX, [Y]\r
  {$ENDIF F_P}\r
  {$IFDEF USE_CMOV}\r
  CMP EAX, EDX\r
  CMOVL EAX, EDX\r
  {$ELSE}\r
  CMP EAX, EDX\r
  JGE @@exit\r
  MOV EAX, EDX\r
@@exit:\r
  {$ENDIF}\r
end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF};\r
//[END Max]\r
\r
//[function Abs]\r
function Abs( X: Integer ): Integer;\r
asm\r
  {$IFDEF F_P}\r
  MOV EAX, [X]\r
  {$ENDIF F_P}\r
  TEST EAX, EAX\r
  JGE @@1\r
  NEG EAX\r
@@1:\r
end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};\r
//[END Abs]\r
\r
//[function Sgn]\r
function Sgn( X: Integer ): Integer;\r
asm\r
  CMP EAX, 0\r
  {$IFDEF USE_CMOV}\r
  MOV EDX, -1\r
  CMOVL EAX, EDX\r
  MOV EDX, 1\r
  CMOVG EAX, EDX\r
  {$ELSE}\r
  JZ  @@exit\r
  MOV EAX, 1\r
  JG  @@exit\r
  MOV EAX, -1\r
@@exit:\r
  {$ENDIF}\r
end;\r
//[END Sgn]\r
\r
//[function iSqrt]\r
function iSQRT( X: Integer ): Integer;\r
var I, N: Integer;\r
begin\r
  Result := 0;\r
  while Result < X do\r
  begin\r
    I := 1;\r
    while I > 0 do\r
    begin\r
      N := (Result + I) * (Result + I);\r
      if N > X then\r
      begin\r
        I := I shr 1;\r
        break;\r
      end\r
        else\r
      if N = X then\r
      begin\r
        Result := Result + I;\r
        Exit;\r
      end;\r
      I := I shl 1;\r
    end;\r
    if I <= 0 then Exit;\r
    Result := Result + I;\r
  end;\r
end;\r
//[END iSqrt]\r
\r
{$IFDEF ASM_VERSION}\r
//[PROCEDURE StartDC]\r
procedure StartDC;\r
asm\r
  { <- EBX : PBitmap\r
    -> EAX = dc\r
       [ESP+8] = var dc\r
       [ESP+4] = var SaveBmp\r
  }\r
        PUSH     0\r
        CALL     CreateCompatibleDC\r
        POP      EDX\r
        PUSH     EAX\r
        PUSH     EDX\r
        MOV      EAX, EBX\r
        CALL     [EBX].TBitmap.fDetachCanvas\r
        MOV      EAX, EBX\r
        CALL     TBitmap.GetHandle\r
        PUSH     EAX\r
        PUSH     dword ptr [ESP+8]\r
        CALL     SelectObject\r
        POP      EDX\r
        PUSH     EAX\r
        PUSH     EDX\r
        MOV      EAX, [ESP+8]\r
end;\r
//[END StartDC]\r
\r
//[procedure FinishDC]\r
procedure FinishDC;\r
asm\r
        POP      ECX\r
        POP      EAX\r
        POP      EDX\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     EDX\r
        CALL     SelectObject\r
        CALL     DeleteDC\r
end;\r
//[ENDe FinishDC]\r
{$ELSE ASM_VERSION}\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure FastIncNum2Elements]\r
procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer );\r
begin\r
  HelpFastIncNum2Els( @List.fItems[ FromIdx ], Value, Count );\r
end;\r
\r
//[function EnumDynHandlers FORWARD DECLARATION]\r
function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
  forward;\r
\r
//[procedure DummyObjProc]\r
procedure DummyObjProc( Sender: PObj );\r
begin\r
end;\r
\r
//[procedure DummyObjProcParam]\r
procedure DummyObjProcParam( Sender: PObj; Param: Pointer );\r
begin\r
end;\r
\r
//[procedure DummyPaintProc]\r
procedure DummyPaintProc( Sender: PControl; DC: HDC );\r
begin\r
end;\r
\r
//[procedure Free_And_Nil]\r
procedure Free_And_Nil( var Obj );\r
var Obj1: PObj;\r
begin\r
  Obj1 := PObj( Obj );\r
  Pointer( Obj ) := nil;\r
  Obj1.Free;\r
end;\r
//[ENDe Free_And_Nil]\r
\r
\r
\r
\r
\r
\r
\r
{-}\r
{ _TObj }\r
\r
//[procedure _TObj.Init]\r
procedure _TObj.Init;\r
begin\r
{$IFDEF _D2orD3}\r
  FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, 0 );\r
{$ENDIF}\r
end;\r
\r
\r
//[function _TObj.VmtAddr]\r
function _TObj.VmtAddr: Pointer;\r
asm\r
   MOV EAX, [EAX]\r
end;\r
\r
{ TObj }\r
\r
class function TObj.AncestorOfObject(Obj: Pointer): Boolean;\r
asm\r
        MOV     ECX, [EAX]\r
        MOV     EAX, EDX\r
        JMP     @@loop1\r
@@loop:\r
        MOV     EAX,[EAX]\r
@@loop1:\r
        TEST    EAX,EAX\r
        JE      @@exit\r
        CMP     EAX,ECX\r
        JNE     @@loop\r
@@success:\r
        MOV     AL,1\r
@@exit:\r
end;\r
\r
{+}\r
\r
{$IFDEF ASM_VERSION}\r
constructor TObj.Create;\r
asm\r
        //CALL      System.@ObjSetup - Generated always by compiler\r
        //JZ        @@exit\r
\r
        PUSH      EAX\r
        MOV       EDX, [EAX]\r
        CALL      dword ptr [EDX]\r
        POP       EAX\r
\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
constructor TObj.Create;\r
begin\r
  Init;\r
  {++}(* inherited; *){--}\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TObj.DoDestroy]\r
procedure TObj.DoDestroy;\r
asm\r
        MOV       EDX, [EAX].fRefCount\r
        SAR       EDX, 1\r
        JZ        @@1\r
        JC        @@exit\r
        DEC       [EAX].fRefCount\r
        STC\r
\r
@@1:    JC        @@exit\r
        MOV       EDX, [EAX]\r
        CALL      dword ptr [EDX + 4]\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TObj.DoDestroy;\r
begin\r
  if fRefCount <> 0 then\r
  begin\r
    if not LongBool( fRefCount and 1) then\r
       Dec( fRefCount );\r
  end\r
  else\r
     Destroy;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TObj.RefDec]\r
procedure TObj.RefDec;\r
asm\r
        SUB      [EAX].fRefCount, 2\r
        JGE      @@exit\r
        TEST     [EAX].fRefCount, 1\r
        JZ       @@exit\r
        MOV      EDX, [EAX]\r
        PUSH     dword ptr [EDX+4]\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TObj.RefDec;\r
begin\r
  Dec( fRefCount, 2 );\r
  if (fRefCount < 0) and LongBool(fRefCount and 1) then\r
    Destroy;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TObj.RefInc]\r
procedure TObj.RefInc;\r
begin\r
  Inc( fRefCount, 2 );\r
end;\r
\r
{-}\r
//[function TObj.VmtAddr]\r
function TObj.VmtAddr: Pointer;\r
asm\r
       MOV    EAX, [EAX - 4]\r
end;\r
\r
//[function TObj.InstanceSize]\r
function TObj.InstanceSize: Integer;\r
asm\r
       MOV    EAX, [EAX]\r
       MOV    EAX,[EAX-4]\r
end;\r
{+}\r
\r
//[procedure TObj.Free]\r
procedure TObj.Free;\r
{$IFDEF F_P}\r
begin\r
  if Self <> nil then\r
    DoDestroy;\r
end;\r
{$ELSE DELPHI}\r
asm\r
   TEST    EAX,EAX\r
   JNE     DoDestroy\r
end;\r
{$ENDIF F_P/DELPHI}\r
\r
{$IFDEF ASM_VERSION}\r
destructor TObj.Destroy;\r
asm\r
        PUSH      EAX\r
        CALL      Final\r
        POP       EAX\r
        XOR       EDX, EDX\r
        CALL      System.@FreeMem\r
        //CALL      System.@Dispose\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TObj.Destroy;\r
begin\r
  Final;\r
  {$IFDEF DEBUG_ENDSESSION}\r
  if EndSession_Initiated then\r
    LogFileOutput( GetStartDir + 'es_debug.txt',\r
                   'FINALLED: ' + Int2Hex( DWORD( @ Self ), 8 ) );\r
  {$ENDIF}\r
  {-}\r
  Dispose( @Self );\r
  {+} {++}(*\r
  inherited; *){--}\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{++}(*\r
//[procedure TObj.Init]\r
procedure TObj.Init;\r
begin\r
\r
end;\r
*){--}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TObj.Final]\r
procedure TObj.Final;\r
asm     //cmd    //opd\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EAX].fOnDestroy.TMethod.Code\r
        JECXZ    @@doAutoFree\r
        PUSH     EAX\r
        XCHG     EDX, EAX\r
        MOV      EAX, [EDX].fOnDestroy.TMethod.Data\r
        CALL     ECX\r
        POP      EAX\r
@@doAutoFree:\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EAX].fAutoFree\r
        JECXZ    @@exit\r
        PUSH     ESI\r
        PUSH     ECX\r
        MOV      ESI, [ECX].TList.fItems\r
        MOV      ECX, [ECX].TList.fCount\r
@@freeloop:\r
        LODSD\r
        XCHG     EDX, EAX\r
        LODSD\r
        PUSH     ECX\r
        CALL     EDX\r
        POP      ECX\r
        DEC      ECX\r
        LOOP     @@freeloop\r
        POP      EAX\r
        CALL     TObj.Free\r
        POP      ESI\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TObj.Final;\r
var I: Integer;\r
    ProcMethod: TMethod;\r
    Proc: TObjectMethod Absolute ProcMethod;\r
begin\r
  if Assigned( fOnDestroy ) then\r
  begin\r
    fOnDestroy( @Self );\r
    fOnDestroy := nil;\r
  end;\r
  if fAutoFree <> nil then\r
  begin\r
    for I := 0 to fAutoFree.fCount div 2 - 1 do\r
    begin\r
      ProcMethod.Code := fAutoFree.fItems[ I * 2 ];\r
      ProcMethod.Data := fAutoFree.fItems[ I * 2 + 1 ];\r
      {-}\r
      Proc;\r
      {+}{++}(*\r
      asm\r
        MOV  EAX, [ProcMethod.Data]\r
        {$IFDEF F_P}\r
        PUSH EAX\r
        {$ENDIF F_P}\r
        MOV  ECX, [ProcMethod.Code]\r
        CALL ECX\r
      end {$IFDEF F_P}[ 'EAX', 'EDX', 'ECX' ]{$ENDIF};\r
      *){--}\r
    end;\r
    fAutoFree.Free;\r
    fAutoFree := nil;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TObj.Add2AutoFree]\r
procedure TObj.Add2AutoFree(Obj: PObj);\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        PUSH     EDX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].fAutoFree\r
        TEST     EAX, EAX\r
        JNZ      @@1\r
        CALL     NewList\r
        MOV      [EBX].fAutoFree, EAX\r
@@1:    MOV      EBX, EAX\r
        XOR      EDX, EDX\r
        POP      ECX\r
        CALL     TList.Insert\r
        XCHG     EAX, EBX\r
        XOR      EDX, EDX\r
        MOV      ECX, offset TObj.Free\r
        //XOR      ECX, ECX\r
        CALL     TList.Insert\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TObj.Add2AutoFree(Obj: PObj);\r
begin\r
  if fAutoFree = nil then\r
    fAutoFree := NewList;\r
  fAutoFree.Insert( 0, Obj );\r
  fAutoFree.Insert( 0, Pointer( @TObj.Free ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TObj.Add2AutoFreeEx]\r
procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod );\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        XCHG     EAX, EBX\r
        MOV      EAX, [EBX].fAutoFree\r
        TEST     EAX, EAX\r
        JNZ      @@1\r
        CALL     NewList\r
        MOV      [EBX].fAutoFree, EAX\r
@@1:    XOR      EDX, EDX\r
        MOV      ECX, [EBP+12] // Data\r
        MOV      EBX, EAX\r
        CALL     TList.Insert\r
        XCHG     EAX, EBX\r
        XOR      EDX, EDX\r
        MOV      ECX, [EBP+8] // Code\r
        CALL     TList.Insert\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod );\r
{$IFDEF F_P}\r
var Ptr1, Ptr2: Pointer;\r
{$ENDIF F_P}\r
begin\r
  if fAutoFree = nil then\r
    fAutoFree := NewList;\r
  {$IFDEF F_P}\r
  asm\r
    MOV  EAX, [Proc]\r
    MOV  [Ptr1], EAX\r
    MOV  EAX, [Proc+4]\r
    MOV  [Ptr2], EAX\r
  end [ 'EAX' ];\r
  fAutoFree.Insert( 0, Ptr2 );\r
  fAutoFree.Insert( 0, Ptr1 );\r
  {$ELSE DELPHI}\r
  fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Data ) );\r
  fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Code ) );\r
  {$ENDIF}\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ TList }\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewList]\r
function NewList: PList;\r
begin\r
  New( Result, Create );\r
  //Result.fAddBy := 4;\r
end;\r
//[END NewList]\r
\r
//[procedure TList.Init]\r
procedure TList.Init;\r
begin\r
  inherited;\r
  fAddBy := 4;\r
end;\r
{$ELSE not_USE_CONSTRUCTORS}\r
//[function NewList]\r
function NewList: PList;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+} {++}(* Result := PList.Create; *){--}\r
  //Result.fAddBy := 4;\r
end;\r
//[END NewList]\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
{$IFDEF ASM_VERSION}\r
destructor TList.Destroy;\r
asm\r
        PUSH      EAX\r
        CALL      TList.Clear\r
        POP       EAX\r
        CALL      TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TList.Destroy;\r
begin\r
   Clear;\r
   inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TList.Release]\r
procedure TList.Release;\r
asm\r
       TEST      EAX, EAX\r
       JZ        @@e\r
       MOV       ECX, [EAX].fCount\r
       JECXZ     @@e\r
       MOV       EDX, [EAX].fItems\r
       PUSH      EAX\r
@@1:\r
       MOV       EAX, [EDX+ECX*4-4]\r
       TEST      EAX, EAX\r
       JZ        @@2\r
       PUSH      EDX\r
       PUSH      ECX\r
       CALL      System.@FreeMem\r
       POP       ECX\r
       POP       EDX\r
@@2:   LOOP      @@1\r
       POP       EAX\r
@@e:   CALL      TObj.Free\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TList.Release;\r
var I: Integer;\r
begin\r
  if @ Self = nil then Exit;\r
  for I := 0 to fCount - 1 do\r
    if fItems[ I ] <> nil then\r
      FreeMem( fItems[ I ] );\r
  Free;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TList.ReleaseObjects]\r
procedure TList.ReleaseObjects;\r
var I: Integer;\r
begin\r
  if @ Self = nil then Exit;\r
  for I := fCount-1 downto 0 do\r
    PObj( fItems[ I ] ).Free;\r
  Free;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TList.SetCapacity]\r
procedure TList.SetCapacity( Value: Integer );\r
asm\r
        CMP       EDX, [EAX].fCount\r
        {$IFDEF USE_CMOV}\r
        CMOVL     EDX, [EAX].fCount\r
        {$ELSE}\r
        JGE       @@1\r
        MOV       EDX, [EAX].fCount\r
@@1:    {$ENDIF}\r
        CMP       EDX, [EAX].fCapacity\r
        JE        @@exit\r
\r
        MOV       [EAX].fCapacity, EDX\r
        SAL       EDX, 2\r
        LEA       EAX, [EAX].fItems\r
        CALL      System.@ReallocMem\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
//var NewItems: PPointerList;\r
procedure TList.SetCapacity( Value: Integer );\r
begin\r
   if Value < Count then\r
      Value := Count;\r
   if Value = fCapacity then Exit;\r
   ReallocMem( fItems, Value * Sizeof( Pointer ) );\r
   fCapacity := Value;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TList.Clear]\r
procedure TList.Clear;\r
asm\r
        PUSH      [EAX].fItems\r
        XOR       EDX, EDX\r
        MOV       [EAX].fItems, EDX\r
        MOV       [EAX].fCount, EDX\r
        MOV       [EAX].fCapacity, EDX\r
        POP       EAX\r
        CALL      System.@FreeMem\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TList.Clear;\r
begin\r
   if fItems <> nil then\r
      FreeMem( fItems );\r
   fItems := nil;\r
   fCount := 0;\r
   fCapacity := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TList.SetAddBy]\r
procedure TList.SetAddBy(Value: Integer);\r
begin\r
  if Value < 1 then Value := 1;\r
  fAddBy := Value;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TList.Add]\r
procedure TList.Add( Value: Pointer );\r
asm\r
        PUSH      EDX\r
        LEA       ECX, [EAX].fCount\r
        MOV       EDX, [ECX]\r
        INC       dword ptr [ECX]\r
          PUSH      EDX\r
          CMP       EDX, [EAX].fCapacity\r
            PUSH      EAX\r
            JL        @@ok\r
\r
            MOV       ECX, [EAX].fAddBy\r
            TEST      ECX, ECX\r
            JNZ       @@add\r
            MOV       ECX, EDX\r
            SHR       ECX, 2\r
            INC       ECX\r
          @@add:\r
            ADD       EDX, ECX\r
            CALL      TList.SetCapacity\r
@@ok:\r
            POP       ECX  // ECX = Self\r
          POP       EAX    // EAX = fCount -> Result (for TList.Insert)\r
        POP       EDX      // EDX = Value\r
\r
        MOV       ECX, [ECX].fItems\r
        MOV       [ECX + EAX*4], EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TList.Add( Value: Pointer );\r
begin\r
   //if fAddBy <= 0 then fAddBy := 4;\r
   if fCapacity <= Count then\r
   begin\r
     if fAddBy <= 0 then\r
       Capacity := Count + Min( 1000, Count div 4 + 1 )\r
     else\r
       Capacity := Count + fAddBy;\r
   end;\r
   fItems[ fCount ] := Value;\r
   Inc( fCount );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TList.Delete]\r
procedure TList.Delete( Idx: Integer );\r
begin\r
   {Assert( (Idx >= 0) and (Idx < fCount), 'TList.Delete: index out of bounds' );\r
   Move( fItems[ Idx + 1 ], fItems[ Idx ], Sizeof( Pointer ) * (Count - Idx - 1) );\r
   Dec( fCount );}\r
   DeleteRange( Idx, 1 );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TList.DeleteRange]\r
procedure TList.DeleteRange(Idx, Len: Integer);\r
asm     //cmd    //opd\r
        TEST     ECX, ECX\r
        JLE      @@exit\r
        CMP      EDX, [EAX].fCount\r
        JGE      @@exit\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        LEA      EAX, [EDX+ECX]\r
        CMP      EAX, [EBX].fCount\r
        JBE      @@1\r
        MOV      ECX, [EBX].fCount\r
        SUB      ECX, EDX\r
@@1:\r
        MOV      EAX, [EBX].fItems\r
        PUSH     [EBX].fCount\r
        SUB      [EBX].fCount, ECX\r
        MOV      EBX, EDX\r
        LEA      EDX, [EAX+EDX*4]\r
        LEA      EAX, [EDX+ECX*4]\r
        ADD      EBX, ECX\r
        POP      ECX\r
        SUB      ECX, EBX\r
        SHL      ECX, 2\r
        CALL     System.Move\r
        POP      EBX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TList.DeleteRange(Idx, Len: Integer);\r
begin\r
  if Len <= 0 then Exit;\r
  if Idx >= Count then Exit;\r
  Assert( (Idx >= 0), 'TList.DeleteRange: index out of bounds' );\r
  if DWORD( Idx + Len ) > DWORD( Count ) then\r
    Len := Count - Idx;\r
  Move( fItems[ Idx + Len ], fItems[ Idx ], Sizeof( Pointer ) * (Count - Idx - Len) );\r
  Dec( fCount, Len );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TList.Remove]\r
procedure TList.Remove(Value: Pointer);\r
var I: Integer;\r
begin\r
  I := IndexOf( Value );\r
  if I >= 0 then\r
    Delete( I );\r
end;\r
\r
//[procedure TList.Put]\r
procedure TList.Put( Idx: Integer; Value: Pointer );\r
begin\r
   if Idx < 0 then Exit;\r
   if Idx >= Count then Exit;\r
   //Assert( (Idx >= 0) and (Idx < fCount), 'TList.Put: index out of bounds' );\r
   fItems[ Idx ] := Value;\r
end;\r
\r
//[function TList.Get]\r
function TList.Get( Idx: Integer ): Pointer;\r
begin\r
   Result := nil;\r
   if Idx < 0 then Exit;\r
   if Idx >= fCount then Exit;\r
   //Assert( (Idx >= 0) and (Idx < fCount), 'TList.Get: index out of bounds' );\r
   Result := fItems[ Idx ];\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TList.IndexOf]\r
function TList.IndexOf( Value: Pointer ): Integer;\r
asm\r
        PUSH      EDI\r
\r
        MOV       EDI, [EAX].fItems\r
        MOV       ECX, [EAX].fCount\r
          PUSH      EDI\r
          DEC       EAX            // make "NZ" - EAX always <> 1\r
          MOV       EAX, EDX\r
          REPNZ     SCASD\r
          POP       EDX\r
        {$IFDEF USE_CMOV}\r
        CMOVNZ    EDI, EDX\r
        {$ELSE}\r
        JZ        @@succ\r
        MOV       EDI, EDX\r
@@succ: {$ENDIF}\r
\r
        MOV       EAX, EDI\r
        STC\r
        SBB       EAX, EDX\r
        SAR       EAX, 2\r
\r
        POP       EDI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TList.IndexOf( Value: Pointer ): Integer;\r
var I: Integer;\r
begin\r
   Result := -1;\r
   for I := 0 to Count - 1 do\r
   begin\r
      if fItems[ I ] = Value then\r
      begin\r
         Result := I;\r
         break;\r
      end;\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TList.Insert]\r
procedure TList.Insert(Idx: Integer; Value: Pointer);\r
asm\r
        PUSH      ECX\r
        PUSH      EAX\r
        PUSH      [EAX].fCount\r
          PUSH      EDX\r
          CALL      TList.Add   // don't matter what to add\r
          POP       EDX         // EDX = Idx, Eax = Count-1\r
        POP       EAX\r
        SUB       EAX, EDX\r
\r
        SAL       EAX, 2\r
        MOV       ECX, EAX      // ECX = (Count - Idx - 1) * 4\r
        POP       EAX\r
        MOV       EAX, [EAX].fItems\r
        LEA       EAX, [EAX + EDX*4]\r
        JL        @@1\r
          PUSH      EAX\r
          LEA       EDX, [EAX + 4]\r
          CALL      System.Move\r
\r
          POP       EAX          // EAX = @fItems[ Idx ]\r
@@1:\r
        POP       ECX            // ECX = Value\r
        MOV       [EAX], ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TList.Insert(Idx: Integer; Value: Pointer);\r
begin\r
   Assert( (Idx >= 0) and (Idx <= Count), 'List index out of bounds' );\r
   Add( nil );\r
   if fCount > Idx then\r
     Move( FItems[ Idx ], FItems[ Idx + 1 ], (fCount - Idx - 1) * Sizeof( Pointer ) );\r
   FItems[ Idx ] := Value;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TList.MoveItem]\r
procedure TList.MoveItem(OldIdx, NewIdx: Integer);\r
asm\r
        CMP       EDX, ECX\r
        JE        @@exit\r
\r
        CMP       ECX, [EAX].fCount\r
        JGE       @@exit\r
\r
        PUSH      EDI\r
\r
        MOV       EDI, [EAX].fItems\r
        PUSH      dword ptr [EDI + EDX*4]\r
          PUSH      ECX\r
          PUSH      EAX\r
          CALL      TList.Delete\r
          POP       EAX\r
          POP       EDX\r
        POP       ECX\r
\r
        POP       EDI\r
        CALL      TList.Insert\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TList.MoveItem(OldIdx, NewIdx: Integer);\r
var Item: Pointer;\r
    //I: Integer;\r
begin\r
  if OldIdx = NewIdx then Exit;\r
  if NewIdx >= Count then Exit;\r
  Item := Items[ OldIdx ];\r
  Delete( OldIdx );\r
  Insert( NewIdx, Item );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TList.Last]\r
function TList.Last: Pointer;\r
asm     //cmd    //opd\r
        MOV      ECX, [EAX].fCount\r
        JECXZ    @@0\r
        MOV      EAX, [EAX].fItems\r
        DEC      ECX\r
        MOV      ECX, [EAX + ECX*4]\r
@@0:    XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TList.Last: Pointer;\r
begin\r
  if Count = 0 then\r
    Result := nil\r
  else\r
    Result := Items[ Count-1 ];\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TList.Swap]\r
procedure TList.Swap(Idx1, Idx2: Integer);\r
asm\r
        MOV       EAX, [EAX].fItems\r
          PUSH      dword ptr [EAX + EDX*4]\r
            PUSH      ECX\r
            MOV       ECX, [EAX + ECX*4]\r
            MOV       [EAX + EDX*4], ECX\r
            POP       ECX\r
          POP       EDX\r
        MOV       [EAX + ECX*4], EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TList.Swap(Idx1, Idx2: Integer);\r
var Tmp: Pointer;\r
begin\r
  Tmp := FItems[ Idx1 ];\r
  FItems[ Idx1 ] := FItems[ Idx2 ];\r
  FItems[ Idx2 ] := Tmp;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TList.SetCount]\r
procedure TList.SetCount(const Value: Integer);\r
begin\r
  if Value >= Count then exit;\r
  fCount := Value;\r
end;\r
\r
//[procedure TList.Assign]\r
procedure TList.Assign(SrcList: PList);\r
begin\r
  Clear;\r
  if SrcList.fCount > 0 then\r
  begin\r
    Capacity := SrcList.fCount;\r
    fCount := SrcList.fCount;\r
    Move( SrcList.FItems[ 0 ], FItems[ 0 ], Sizeof( Pointer ) * fCount );\r
  end;\r
end;\r
\r
{ TListEx }\r
\r
//[function NewListEx]\r
function NewListEx: PListEx;\r
begin\r
  {-}\r
  new( Result, Create );\r
  {+}{++}(*Result := PListEx.Create;*){--}\r
  Result.fList := NewList;\r
  Result.fObjects := NewList;\r
end;\r
//[END NewListEx]\r
\r
//[procedure TListEx.Add]\r
procedure TListEx.Add(Value: Pointer);\r
begin\r
  AddObj( Value, nil );\r
end;\r
\r
//[procedure TListEx.AddObj]\r
procedure TListEx.AddObj(Value, Obj: Pointer);\r
var C: Integer;\r
begin\r
  C := Count;\r
  fList.Add( Value );\r
  fObjects.Insert( C, Obj );\r
end;\r
\r
//[procedure TListEx.Clear]\r
procedure TListEx.Clear;\r
begin\r
  fList.Clear;\r
  fObjects.Clear;\r
end;\r
\r
//[procedure TListEx.Delete]\r
procedure TListEx.Delete(Idx: Integer);\r
begin\r
  DeleteRange( Idx, 1 );\r
end;\r
\r
//[procedure TListEx.DeleteRange]\r
procedure TListEx.DeleteRange(Idx, Len: Integer);\r
begin\r
  fList.DeleteRange( Idx, Len );\r
  fObjects.DeleteRange( Idx, Len );\r
end;\r
\r
//[destructor TListEx.Destroy]\r
destructor TListEx.Destroy;\r
begin\r
  fList.Free;\r
  fObjects.Free;\r
  inherited;\r
end;\r
\r
//[function TListEx.GetAddBy]\r
function TListEx.GetAddBy: Integer;\r
begin\r
  Result := fList.AddBy;\r
end;\r
\r
//[function TListEx.GetCount]\r
function TListEx.GetCount: Integer;\r
begin\r
  Result := fList.Count;\r
end;\r
\r
//[function TListEx.GetEx]\r
function TListEx.GetEx(Idx: Integer): Pointer;\r
begin\r
  Result := fList.Items[ Idx ];\r
end;\r
\r
//[function TListEx.IndexOf]\r
function TListEx.IndexOf(Value: Pointer): Integer;\r
begin\r
  Result := fList.IndexOf( Value );\r
end;\r
\r
//[function TListEx.IndexOfObj]\r
function TListEx.IndexOfObj(Obj: Pointer): Integer;\r
begin\r
  Result := fObjects.IndexOf( Obj );\r
end;\r
\r
//[procedure TListEx.Insert]\r
procedure TListEx.Insert(Idx: Integer; Value: Pointer);\r
begin\r
  InsertObj( Idx, Value, nil );\r
end;\r
\r
//[procedure TListEx.InsertObj]\r
procedure TListEx.InsertObj(Idx: Integer; Value, Obj: Pointer);\r
begin\r
  fList.Insert( Idx, Value );\r
  fObjects.Insert( Idx, Obj );\r
end;\r
\r
//[function TListEx.Last]\r
function TListEx.Last: Pointer;\r
begin\r
  Result := fList.Last;\r
end;\r
\r
//[function TListEx.LastObj]\r
function TListEx.LastObj: Pointer;\r
begin\r
  Result := fObjects.Last;\r
end;\r
\r
//[procedure TListEx.MoveItem]\r
procedure TListEx.MoveItem(OldIdx, NewIdx: Integer);\r
begin\r
  fList.MoveItem( OldIdx, NewIdx );\r
  fObjects.MoveItem( OldIdx, NewIdx );\r
end;\r
\r
//[procedure TListEx.PutEx]\r
procedure TListEx.PutEx(Idx: Integer; const Value: Pointer);\r
begin\r
  fList.Items[ Idx ] := Value;\r
end;\r
\r
//[procedure TListEx.Set_AddBy]\r
procedure TListEx.Set_AddBy(const Value: Integer);\r
begin\r
  fList.AddBy := Value;\r
  fObjects.AddBy := Value;\r
end;\r
\r
//[procedure TListEx.Swap]\r
procedure TListEx.Swap(Idx1, Idx2: Integer);\r
begin\r
  fList.Swap( Idx1, Idx2 );\r
  fObjects.Swap( Idx1, Idx2 );\r
end;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- Window procedure -- }\r
\r
{$IFDEF ASM_VERSION} //!!//!!\r
//[FUNCTION CallCtlWndProc]\r
function CallCtlWndProc( Ctl: PControl; var Msg: TMsg ): Integer;\r
begin\r
  Result := Ctl.WndProc( Msg );\r
end;\r
//[END CallCtlWndProc]\r
\r
//[function WndFunc]\r
function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )\r
                                   : Integer; stdcall;\r
const   size_TMsg = sizeof( TMsg );\r
asm\r
        ADD       ESP, -size_TMsg\r
        MOV       EDX, ESP\r
\r
        PUSH      ESI\r
        PUSH      EDI\r
\r
        MOV       EDI, EDX\r
        LEA       ESI, [W]\r
\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
\r
        MOV       EDI, EDX\r
        MOV       EAX, [EDI]\r
        TEST      EAX, EAX\r
        JZ        @@self_is_nil\r
\r
        MOV       ECX, [CreatingWindow]\r
        JECXZ     @@get_self_prop\r
\r
        MOV       [ECX].TControl.fHandle, EAX\r
\r
//set_self_prop:\r
        PUSH      ECX\r
          PUSH      ECX\r
          PUSH      Offset[ID_SELF]\r
          PUSH      EAX\r
          CALL      SetProp\r
\r
          XOR       EAX, EAX\r
          MOV       [CreatingWindow], EAX\r
        POP       EAX                 // EAX = self_\r
        JMP       @@self_got\r
\r
@@get_self_prop:\r
        PUSH      Offset[ID_SELF]\r
        PUSH      EAX\r
        CALL      GetProp\r
        TEST      EAX, EAX\r
        JNZ       @@self_got\r
\r
@@self_is_nil:\r
        OR        EAX, [ Applet ]\r
        JNZ       @@self_got\r
\r
//try_defwndproc:\r
        POP       EDI\r
        POP       ESI\r
        MOV       ESP, EBP\r
        POP       EBP\r
        JMP       DefWindowProc\r
\r
//@@id_self:\r
//        DB        'SELF_',0\r
\r
@@self_got:\r
        MOV       EDX, EDI\r
        //CALL      TControl.WndProc\r
        CALL      CallCtlWndProc\r
\r
        POP       EDI\r
        POP       ESI\r
\r
        MOV       ESP, EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )\r
                                   : Integer; stdcall;\r
var M: TMsg;\r
    self_: PControl;\r
begin\r
   M.hwnd := W;\r
   M.message := Msg;\r
   M.wParam := wParam;\r
   M.lParam := lParam;\r
\r
   {$IFDEF DEBUG_ENDSESSION}\r
   if EndSession_Initiated then\r
   begin\r
     LogFileOutput( GetStartDir + 'es_debug.txt',\r
       'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) +\r
       ' WParam: ' + Int2Str( wParam ) + '($' + Int2Hex( wParam, 8 ) + ')' +\r
       ' LParam: ' + Int2Str( lParam ) + '($' + Int2Hex( lParam, 8 ) + ')' );\r
   end;\r
   {$ENDIF}\r
\r
   self_ := nil;\r
   if W <> 0 then\r
   begin\r
     if CreatingWindow <> nil then\r
     begin\r
        {$IFDEF DEBUG_CREATEWINDOW}\r
        LogFileOutput( GetStartDir + 'Session.log',\r
                       'WndFunc: Creating window = ' + Int2Hex( Integer( CreatingWindow ), 4 ) +\r
                       ' hwnd=' + Int2Str( M.hwnd ) +\r
                       ' message=' + Int2Hex( M.message, 4 ) +\r
                       ' wParam=' + Int2Str( M.wParam ) + '=$' + Int2Hex( M.wParam, 4 ) +\r
                       ' lParam=' + Int2Str( M.lParam ) + '=$' + Int2Hex( M.lParam, 4 )\r
                     );\r
        {$ENDIF DEBUG_CREATEWINDOW}\r
        self_ := CreatingWindow;\r
        CreatingWindow.fHandle := W;\r
        SetProp( W, ID_SELF, THandle( CreatingWindow ) );\r
        CreatingWindow := nil;\r
     end\r
        else\r
     self_ := Pointer( GetProp( W, ID_SELF ) );\r
   end;\r
\r
   if self_ <> nil then\r
      Result := self_.WndProc( M )\r
   else\r
   if Assigned( Applet ) then\r
      Result := Applet.WndProc( M )\r
   else\r
      Result := DefWindowProc( W, Msg, wParam, lParam );\r
   {$IFDEF DEBUG_ENDSESSION}\r
   if EndSession_Initiated then\r
   begin\r
     LogFileOutput( GetStartDir + 'es_debug.txt',\r
       'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) +\r
       ' Result: ' + Int2Str( Result ) + '($' + Int2Hex( Result, 8 ) + ')' );\r
   end;\r
   {$ENDIF}\r
end;\r
//[END WndFunc]\r
{$ENDIF ASM_VERSION}\r
\r
var\r
  IdleHandlers: PList;\r
  ProcessIdle: procedure ( Sender: PObj ) = DummyObjProc;\r
\r
//[procedure ProcessIdleProc]\r
procedure ProcessIdleProc( Sender: PObj );\r
var\r
  i: integer;\r
  m: TMethod;\r
begin\r
  if AppletTerminated then exit;  // YS +\r
  i := 0;\r
  with IdleHandlers{-}^{+} do\r
    while i < Count do begin\r
      m.Code:=Items[i];\r
      Inc(i);\r
      m.Data:=Items[i];\r
      Inc(i);\r
      TOnEvent(m)(Sender);\r
    end;\r
end;\r
\r
//[function FindIdleHandler]\r
function FindIdleHandler( const OnIdle: TOnEvent ): integer;\r
var\r
  i: integer;\r
begin\r
  i := 0;\r
  if not AppletTerminated then //+ {Maxim Pushkar}\r
  with TMethod(OnIdle), IdleHandlers{-}^{+} do\r
    while i < Count do begin\r
      if (Items[i] = Code) and (Items[i + 1] = Data) then\r
      begin\r
        Result := i;\r
        exit;\r
      end;\r
      Inc(i, 2);\r
    end;\r
  Result := -1;\r
end;\r
//[END FindIdleHandler]\r
\r
//[procedure RegisterIdleHandler]\r
procedure RegisterIdleHandler( const OnIdle: TOnEvent );\r
begin\r
  if IdleHandlers = nil then begin\r
    IdleHandlers := NewList;\r
    if Applet <> nil then\r
      Applet.Add2AutoFree(IdleHandlers);\r
  end;\r
  with TMethod(OnIdle) do\r
  begin\r
    IdleHandlers.Add(Code);\r
    IdleHandlers.Add(Data);\r
  end;\r
  ProcessIdle := @ProcessIdleProc;\r
end;\r
\r
//[procedure UnRegisterIdleHandler]\r
procedure UnRegisterIdleHandler( const OnIdle: TOnEvent );\r
var\r
  i: integer;\r
begin\r
  i := FindIdleHandler(OnIdle);\r
  if i <> -1 then\r
  with IdleHandlers{-}^{+} do\r
  begin\r
    Delete(i);\r
    Delete(i);\r
  end;\r
end;\r
\r
//[procedure TerminateExecution]\r
procedure TerminateExecution( var AppletWnd: PControl );\r
var App: PControl;\r
    Appalreadyterminated: Boolean;\r
begin\r
  Appalreadyterminated := AppletTerminated;\r
  AppletTerminated := TRUE;\r
  AppletRunning := FALSE;\r
  App := Applet;\r
  Applet := nil;\r
  if (App <> nil) {and (App.RefCount >= 0)} then\r
  begin\r
    App.RefInc;\r
    if not Appalreadyterminated then\r
    begin\r
      App.ProcessMessages;\r
      App.Perform( WM_CLOSE, 0, 0 );\r
    end;\r
    AppletWnd := nil;\r
    App.Free;\r
    App.RefDec;\r
  end;\r
end;\r
\r
//[PROCEDURE CallTControlCreateWindow]\r
{$IFDEF ASM_VERSION}\r
procedure CallTControlCreateWindow( Ctl: PControl );\r
begin\r
  Ctl.CreateWindow;\r
end;\r
//[END CallTControlCreateWindow]\r
\r
//[PROCEDURE Run]\r
procedure Run( var AppletWnd: PControl );\r
asm\r
        PUSH      EBX\r
        XCHG      EBX, EAX\r
\r
        INC       [AppletRunning]\r
        MOV       EAX, [EBX]\r
        MOV       [Applet], EAX\r
        CALL      CallTControlCreateWindow\r
        JMP       @@2\r
@@1:\r
        CALL      WaitMessage\r
        MOV       EAX, [EBX]\r
        CALL      TControl.ProcessMessages\r
        {$IFNDEF NOT_USE_OnIdle}\r
        MOV       EAX, [EBX]\r
        CALL      [ProcessIdle]\r
        {$ENDIF}\r
@@2:\r
        CMP       [AppletTerminated],0\r
        JZ        @@1\r
\r
        XCHG      EAX, EBX\r
\r
        POP       EBX\r
        TEST      EAX, EAX\r
        JNZ       TerminateExecution\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure Run( var AppletWnd: PControl );\r
begin\r
  AppletRunning := True;\r
  Applet := AppletWnd;\r
  AppletWnd.CreateWindow; //virtual!!!\r
  while not AppletTerminated do\r
  begin\r
    WaitMessage;\r
    AppletWnd.ProcessMessages;\r
    {$IFNDEF NOT_USE_OnIdle}\r
    ProcessIdle( AppletWnd );\r
    {$ENDIF}\r
  end;\r
  if AppletWnd <> nil then\r
    TerminateExecution( AppletWnd );\r
end;\r
//[END Run]\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure AppletMinimize]\r
procedure AppletMinimize;\r
begin\r
  if Applet = nil then Exit;\r
  Applet.Perform( WM_SYSCOMMAND, SC_MINIMIZE, 0 );\r
end;\r
\r
//[procedure AppletHide]\r
procedure AppletHide;\r
begin\r
  if Applet = nil then Exit;\r
  AppletMinimize;\r
  Applet.Hide;\r
end;\r
\r
//[procedure AppletRestore]\r
procedure AppletRestore;\r
begin\r
  if Applet = nil then Exit;\r
  Applet.Show;\r
  Applet.Perform( WM_SYSCOMMAND, SC_RESTORE, 0 );\r
end;\r
\r
//[function ScreenWidth]\r
function ScreenWidth: Integer;\r
begin\r
  Result := GetSystemMetrics( SM_CXSCREEN );\r
end;\r
//[END ScreenWidth]\r
\r
//[function ScreenHeight]\r
function ScreenHeight: Integer;\r
begin\r
  Result := GetSystemMetrics( SM_CYSCREEN );\r
end;\r
//[END ScreenHeight]\r
\r
\r
\r
\r
\r
\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
  {$DEFINE WNDPROCAPP_USED}\r
  {$DEFINE WNDPROCAPP_ASM_USED}\r
{$ENDIF USE_CONSTRUCTORS}\r
{$IFNDEF ASM_VERSION}\r
  {$DEFINE WNDPROCAPP_USED}\r
{$ENDIF  ASM_VERSION}\r
\r
  {$DEFINE WNDPROCAPP_USED}\r
\r
\r
\r
{$IFNDEF WNDPROCAPP_USED}\r
//[WndProcXXX FORWARD DECLARATIONS]\r
  {$IFNDEF ASM_VERSION}\r
function WndProcApp( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
  {$ENDIF}\r
{$ENDIF}\r
function WndProcForm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
//function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
//function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
//function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;\r
var fGlobalProcKeybd: function( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean =\r
    WndProcDummy;\r
//[END OF WndProcXXX FORWARD DECLARATIONS]\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- Graphics support -- }\r
\r
//[function _NewGraphicTool]\r
function _NewGraphicTool: PGraphicTool;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}\r
  {++}(*Result := PGraphicTool.Create;*){--}\r
end;\r
//[END _NewGraphicTool]\r
\r
//[FUNCTION SimpleGetCtlBrushHandle]\r
{$IFDEF ASM_VERSION}\r
function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush;\r
asm     //        //\r
@@1:    MOV       ECX, [EAX].TControl.fParent\r
        JECXZ     @@2\r
        MOV       EDX, [EAX].TControl.fColor\r
        CMP       EDX, [ECX].TControl.fColor\r
        XCHG      EAX, ECX\r
        JE        @@1\r
        XCHG      EAX, ECX\r
@@2:    PUSH      EBX\r
        XCHG      EBX, EAX\r
        MOV       ECX, [EBX].TControl.fTmpBrush\r
        JECXZ     @@3\r
        MOV       EAX, [EBX].TControl.fColor\r
        CALL      Color2RGB\r
        CMP       EAX, [EBX].TControl.fTmpBrushColorRGB\r
        JE        @@3\r
        XOR       EAX, EAX\r
        XCHG      [EBX].TControl.fTmpBrush, EAX\r
        PUSH      EAX\r
        CALL      DeleteObject\r
@@3:    MOV       EAX, [EBX].TControl.fTmpBrush\r
        TEST      EAX, EAX\r
        JNE       @@4\r
        MOV       EAX, [EBX].TControl.fColor\r
        CALL      Color2RGB\r
        MOV       [EBX].TControl.fTmpBrushColorRGB, EAX\r
        PUSH      EAX\r
        CALL      CreateSolidBrush\r
        MOV       [EBX].TControl.fTmpBrush, EAX\r
@@4:    POP       EBX\r
end;\r
{$ELSE ASM_VERSION PAS_VERSION}\r
function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush;\r
begin\r
  if (Sender.fParent <> nil) and (Sender.fColor = Sender.fParent.fColor) then\r
    Result := SimpleGetCtlBrushHandle( Sender.fParent )\r
  else\r
  begin\r
    if (Sender.fTmpBrush <> 0) and\r
       (Color2RGB( Sender.fColor ) <> Sender.fTmpBrushColorRGB) then\r
    begin\r
      DeleteObject( Sender.fTmpBrush );\r
      Sender.fTmpBrush := 0;\r
    end;\r
    if Sender.fTmpBrush = 0 then\r
    begin\r
      Sender.fTmpBrushColorRGB := Color2RGB( Sender.fColor );\r
      Sender.fTmpBrush := CreateSolidBrush( Sender.fTmpBrushColorRGB );\r
    end;\r
    Result := Sender.fTmpBrush;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END SimpleGetCtlBrushHandle]\r
\r
//[function NormalGetCtlBrushHandle]\r
function NormalGetCtlBrushHandle( Sender: PControl ): HBrush;\r
begin\r
  if (Sender.fParent <> nil) then\r
    Sender.Brush.fParentGDITool := Sender.fParent.Brush;\r
  {if (Sender.Brush.fHandle <> 0) and\r
     (Color2RGB( Sender.fBrush.fData.Color ) <> Sender.fBrush.fColorRGB) then\r
    DeleteObject( Sender.Brush.ReleaseHandle );}\r
  Result := Sender.Brush.Handle;\r
end;\r
//[END NormalGetCtlBrushHandle]\r
\r
{++}(*\r
//[API CreateFontIndirect]\r
function CreateFontIndirect(const p1: TLogFont): HFONT; stdcall;\r
external gdi32 name 'CreateFontIndirectA';\r
*){--}\r
//[MakeXXXHandle FORWARD DECLARATIONS]\r
function MakeFontHandle( Self_: PGraphicTool ): THandle; forward;\r
function MakeBrushHandle( Self_: PGraphicTool ): THandle; forward;\r
function MakePenHandle( Self_: PGraphicTool ): THandle; forward;\r
function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle; forward;\r
//[END OF MakeXXXHandle FORWARD DECLARATIONS]\r
\r
//[FUNCTION NewBrush]\r
{$IFDEF ASM_VERSION}\r
function NewBrush: PGraphicTool;\r
asm\r
        MOV      [Global_GetCtlBrushHandle], offset NormalGetCtlBrushHandle  \r
        CALL     _NewGraphicTool\r
        MOV      [EAX].TGraphicTool.fNewProc, offset[NewBrush]\r
        MOV      [EAX].TGraphicTool.fType, gttBrush\r
        MOV      [EAX].TGraphicTool.fMakeHandleProc, offset[MakeBrushHandle]\r
        MOV      [EAX].TGraphicTool.fData.Color, clBtnFace\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewBrush: PGraphicTool;\r
begin\r
  Global_GetCtlBrushHandle := NormalGetCtlBrushHandle;\r
  Result := _NewGraphicTool;\r
  with Result {-}^{+} do\r
  begin\r
    fNewProc := @ NewBrush;\r
    fType := gttBrush;\r
    fMakeHandleProc := @ MakeBrushHandle;\r
    Result.fData.Color := clBtnFace;\r
    //Result.fData.Brush.Style := bsSolid;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewBrush]\r
\r
const size_FontData = sizeof( Integer {fFontHeight} ) + sizeof( Integer {fFontWidth} ) +\r
                      sizeof( TFontPitch ) +  sizeof( TFontStyle ) +\r
                      sizeof( Integer {fFontOrientation} ) +\r
                      sizeof( Integer {fFontWeight} ) + sizeof( TFontCharset ) +\r
                      sizeof( TFontQuality );\r
\r
//[FUNCTION NewFont]\r
{$IFDEF ASM_VERSION}\r
function NewFont: PGraphicTool;\r
const FontDtSz = sizeof( TGDIFont );\r
asm\r
        CALL     _NewGraphicTool\r
        MOV      [EAX].TGraphicTool.fNewProc, offset[NewFont]\r
        MOV      [EAX].TGraphicTool.fType, gttFont\r
        MOV      [EAX].TGraphicTool.fMakeHandleProc, offset[MakeFontHandle]\r
        MOV      EDX, [DefFontColor]\r
        MOV      [EAX].TGraphicTool.fData.Color, EDX\r
\r
        PUSH     EAX\r
        LEA      EDX, [EAX].TGraphicTool.fData.Font\r
        MOV      EAX, offset[ DefFont ]\r
        XOR      ECX, ECX\r
        MOV      CL, FontDtSz\r
        CALL     System.Move\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewFont: PGraphicTool;\r
begin\r
  Result := _NewGraphicTool;\r
  with Result {-}^{+} do\r
  begin\r
    fNewProc := @ NewFont;\r
    fType := gttFont;\r
    fMakeHandleProc := @ MakeFontHandle;\r
    fData.Color := DefFontColor;\r
    Move( DefFont, fData.Font, Sizeof( TGDIFont ) );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewFont]\r
\r
//[FUNCTION NewPen]\r
{$IFDEF ASM_VERSION}\r
function NewPen: PGraphicTool;\r
asm\r
        CALL     _NewGraphicTool\r
        MOV      [EAX].TGraphicTool.fNewProc, offset[NewPen]\r
        MOV      [EAX].TGraphicTool.fType, gttPen\r
        MOV      [EAX].TGraphicTool.fMakeHandleProc, offset[MakePenHandle]\r
        MOV      [EAX].TGraphicTool.fData.Pen.Mode, pmCopy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewPen: PGraphicTool;\r
begin\r
  Result := _NewGraphicTool;\r
  with Result{-}^{+} do\r
  begin\r
    fNewProc := @ NewPen;\r
    fType := gttPen;\r
    fMakeHandleProc := @ MakePenHandle;\r
    fData.Pen.Mode := pmCopy;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewPen]\r
\r
//+\r
//[function Color2RGB]\r
function Color2RGB( Color: TColor ): TColor;\r
begin\r
  if Color < 0 then\r
    Result := GetSysColor(Color and $FF) else\r
    Result := Color;\r
end;\r
//[END Color2RGB]\r
\r
//[function ColorsMix]\r
function ColorsMix( Color1, Color2: TColor ): TColor;\r
{$IFDEF F_P}\r
begin\r
  Result := ((Color2RGB( Color1 ) and $FEFEFE) shr 1) +\r
            ((Color2RGB( Color2 ) and $FEFEFE) shr 1);\r
end;\r
{$ELSE DELPHI}\r
asm\r
   PUSH EDX\r
   CALL Color2Rgb\r
   XCHG EAX, [ESP]\r
   CALL Color2Rgb\r
   POP EDX\r
   AND EAX, 0FEFEFEh\r
   AND EDX, 0FEFEFEh\r
   SHR EAX, 1\r
   SHR EDX, 1\r
   ADD EAX, EDX\r
end;\r
{$ENDIF F_P/DELPHI}\r
//[END ColorsMix]\r
\r
//[FUNCTION Color2RGBQuad]\r
{$IFDEF ASM_VERSION}\r
function Color2RGBQuad( Color: TColor ): TRGBQuad;\r
asm\r
        CALL     Color2RGB\r
        // code by bart:\r
        xchg    ah,al                   // xxRRGGBB\r
        ror     eax,16                  // BBGGxxRR\r
        xchg    ah,al                   // BBGGRRxx\r
        shr     eax,8                   // 00BBGGRR\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Color2RGBQuad( Color: TColor ): TRGBQuad;\r
var C: Integer;\r
begin\r
  C := Color2RGB( Color );\r
  C := ((C shr 16) and $FF)\r
    or ((C shl 16) and $FF0000)\r
    or (C and $FF00);\r
  Result := TRGBQuad( C );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Color2RGBQuad]\r
\r
//[FUNCTION Color2Color16]\r
{$IFDEF ASM_VERSION}\r
function Color2Color16( Color: TColor ): WORD;\r
asm\r
  MOV  EDX, EAX\r
  SHR  EDX, 19\r
  AND  EDX, $1F\r
  MOV  ECX, EAX\r
  SHR  ECX, 5\r
  AND  ECX, $7E0;\r
  MOV  AH, AL\r
  AND  EAX, $F800\r
  OR   EAX, EDX\r
  OR   EAX, ECX\r
end;\r
{$ELSE ASM_VERSION}\r
function Color2Color16( Color: TColor ): WORD;\r
begin\r
  Color := Color2RGB( Color );\r
  Result := (Color shr 19) and $1F or\r
            (Color shr 5) and $7E0 or\r
            (Color shl 8) and $F800;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Color2Color16]\r
\r
{ TGraphicTool }\r
\r
{$IFDEF ASM_VERSION}\r
//[function TGraphicTool.Assign]\r
function TGraphicTool.Assign(Value: PGraphicTool): PGraphicTool;\r
const SzfData = sizeof( fData );\r
asm     //        //\r
        TEST      EDX, EDX\r
        JNZ       @@1\r
        TEST      EAX, EAX\r
        JZ        @@0\r
        CALL      TObj.DoDestroy\r
        XOR       EAX, EAX\r
@@0:    RET\r
@@1:    PUSH      EDI\r
        MOV       EDI, EDX\r
        TEST      EAX, EAX\r
        JNZ       @@2\r
        XCHG      EAX, EDX\r
        CALL      dword ptr[EAX].TGraphicTool.fNewProc\r
@@2:    CMP       EAX, EDI\r
        JE        @@exit\r
        PUSH      EBX\r
        XCHG      EBX, EAX\r
\r
        MOV       ECX, [EBX].TGraphicTool.fHandle\r
        JECXZ     @@3\r
        CMP       ECX, [EDI].TGraphicTool.fHandle\r
        JE        @@exit1\r
@@3:\r
        MOV       EAX, EBX\r
        CALL      TGraphicTool.Changed\r
        LEA       EDX, [EBX].TGraphicTool.fData\r
        LEA       EAX, [EDI].TGraphicTool.fData\r
        MOV       ECX, SzfData\r
        CALL      System.Move\r
        MOV       EAX, EBX\r
        CALL      TGraphicTool.Changed\r
\r
@@exit1:\r
        XCHG      EAX, EBX\r
        POP       EBX\r
@@exit: POP       EDI\r
end;\r
{$ELSE ASM_VERSION}\r
function TGraphicTool.Assign(Value: PGraphicTool): PGraphicTool;\r
var _Self: PGraphicTool;\r
begin\r
  Result := nil;\r
  if Value = nil then\r
  begin\r
    if @Self <> nil then\r
       DoDestroy;\r
    Exit;\r
  end;\r
  _Self := @Self;\r
  if _Self = nil then\r
    _Self := Value.fNewProc();\r
  Result := _Self;\r
  if _Self = Value then Exit; // to avoid infinite loop when assigning to itself\r
  if _Self.fHandle <> 0 then\r
     if Value.fHandle = _Self.fHandle then Exit;\r
  _Self.Changed; // to destroy handle if allocated and release it from the canvas (if any uses it)\r
  Assert( Value.fType = _Self.fType, 'Attempt to assign to different GDI tool type' );\r
  Move( Value.fData, _Self.fData, Sizeof( fData ) );\r
  _Self.Changed; // to inform owner control, that its tool (font, brush) changed\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TGraphicTool.AssignHandle]\r
procedure TGraphicTool.AssignHandle(NewHandle: Integer);\r
begin\r
  //------------ by Yury Sidorov --------\r
  //Changed;\r
  //-------------------------------------//\r
  if fHandle <> 0 then                   //\r
    DeleteObject( fHandle );             //\r
  //-------------------------------------//\r
  fHandle := NewHandle;\r
  GetObject( fHandle, Sizeof( TGDIFont ), @ fData.Font );\r
  Changed;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TGraphicTool.Changed]\r
procedure TGraphicTool.Changed;\r
asm\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EAX].fHandle\r
        JECXZ    @@exit\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        CALL     @@CallOnChange\r
\r
        CALL     DeleteObject\r
        POP      EAX\r
@@exit:\r
\r
@@CallOnChange:\r
        MOV      ECX, [EAX].fOnChange.TMethod.Code\r
        JECXZ    @@no_onChange\r
        PUSH     EAX\r
        XCHG     EDX, EAX\r
        MOV      EAX, [EDX].fOnChange.TMethod.Data\r
        CALL     ECX\r
        POP      EAX\r
@@no_onChange:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TGraphicTool.Changed;\r
var H: THandle;\r
begin\r
   if fHandle <> 0 then\r
   begin\r
     H := fHandle;\r
     fHandle := 0;\r
     ////////////////////////////////\r
     if Assigned( fOnChange ) then\r
        fOnChange( @Self );\r
     ////////////////////////////////\r
     DeleteObject( H );\r
      {$IFDEF DEBUG_GDIOBJECTS}\r
      case fType of\r
      gttBrush:  Dec( BrushCount );\r
      gttFont:   Dec( FontCount );\r
      gttPen:    Dec( PenCount );\r
      end;\r
      {$ENDIF}\r
   end;\r
   //////////////////////////////////\r
   if Assigned( fOnChange ) then\r
      fOnChange( @Self );\r
   //////////////////////////////////\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TGraphicTool.Destroy]\r
destructor TGraphicTool.Destroy;\r
asm\r
          PUSH      EAX\r
          CMP       [EAX].fType, gttFont\r
          JE        @@0\r
          MOV       ECX, [EAX].fData.Brush.Bitmap\r
          JECXZ     @@0\r
          PUSH      ECX\r
          CALL      DeleteObject\r
          POP       EAX\r
          PUSH      EAX\r
@@0:\r
        MOV       ECX, [EAX].fHandle\r
        JECXZ     @@1\r
        PUSH      ECX\r
        CALL      DeleteObject\r
@@1:\r
          POP       EAX\r
          CALL      TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TGraphicTool.Destroy;\r
begin\r
  case fType of\r
  gttBrush: if fData.Brush.Bitmap <> 0 then\r
               DeleteObject( fData.Brush.Bitmap );\r
  gttPen:   if fData.Pen.BrushBitmap <> 0 then\r
               DeleteObject( fData.Pen.BrushBitmap )\r
  end;\r
  if fHandle <> 0 then\r
  begin\r
     DeleteObject( fHandle );\r
     {$IFDEF DEBUG_GDIOBJECTS}\r
     case fType of\r
     gttPen:    Dec( PenCount );\r
     gttBrush:  Dec( BrushCount );\r
     gttFont:   Dec( FontCount );\r
     end;\r
     {$ENDIF}\r
     //fHandle := 0; Why to do this? It is now destroying!\r
  end;\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TGraphicTool.HandleAllocated]\r
function TGraphicTool.HandleAllocated: Boolean;\r
begin\r
  Result := fHandle <> 0;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TGraphicTool.ReleaseHandle]\r
function TGraphicTool.ReleaseHandle: Integer;\r
asm     //        //\r
        PUSH      EAX\r
        CALL      Changed\r
        POP       EDX\r
        XOR       EAX, EAX\r
        XCHG      [EDX].fHandle, EAX  \r
end;\r
{$ELSE ASM_VERSION PAS_VERSION}\r
function TGraphicTool.ReleaseHandle: Integer;\r
begin\r
  Changed;\r
  Result := fHandle;\r
  fHandle := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TGraphicTool.SetInt]\r
procedure TGraphicTool.SetInt( const Index: Integer; Value: Integer );\r
asm\r
        LEA    EDX, [EDX+EAX].fData\r
        CMP    [EDX], ECX\r
        JE     @@exit\r
        MOV    [EDX], ECX\r
        CALL   Changed\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TGraphicTool.SetInt( const Index: Integer; Value: Integer );\r
var Where: PInteger;\r
begin\r
  Where := Pointer( Integer( @ fData ) + Index );\r
  if Where^ = Value then Exit;\r
  Where^ := Value;\r
  Changed;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF F_P}\r
//[function TGraphicTool.GetInt]\r
function TGraphicTool.GetInt(const Index: Integer): Integer;\r
var Where: PInteger;\r
begin\r
  Where := Pointer( Integer( @ fData ) + Index );\r
  Result := Where^;\r
end;\r
{$ENDIF}\r
\r
//[procedure TGraphicTool.SetColor]\r
procedure TGraphicTool.SetColor( Value: TColor );\r
begin\r
  SetInt( go_Color, Value );\r
  fColorRGB := Color2RGB( Value );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TGraphicTool.IsFontTrueType]\r
function TGraphicTool.IsFontTrueType: Boolean;\r
asm\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
\r
        PUSH     EBX\r
\r
        PUSH     EAX                  // fHandle\r
\r
        PUSH     0\r
        CALL     GetDC\r
\r
        PUSH     EAX                  // DC\r
        MOV      EBX, EAX\r
        CALL     SelectObject\r
        PUSH     EAX\r
\r
        XOR      ECX, ECX\r
        PUSH     ECX\r
        PUSH     ECX\r
        PUSH     ECX\r
        PUSH     ECX\r
        PUSH     EBX\r
        CALL     GetFontData\r
\r
        XCHG     EAX, [ESP]\r
\r
        PUSH     EAX\r
        PUSH     EBX\r
        CALL     SelectObject\r
\r
        PUSH     EBX\r
        PUSH     0\r
        CALL     ReleaseDC\r
\r
        POP      EAX\r
        INC      EAX\r
        SETNZ    AL\r
\r
        POP      EBX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TGraphicTool.IsFontTrueType: Boolean;\r
var OldFont: HFont;\r
    DC: HDC;\r
begin\r
  Result := False;\r
  if GetHandle = 0 then Exit;\r
  DC := GetDC( 0 );\r
  OldFont := SelectObject( DC, fHandle );\r
  if GetFontData( DC, 0, 0, nil, 0 ) <> GDI_ERROR then\r
     Result := True;\r
  SelectObject( DC, OldFont );\r
  ReleaseDC( 0, DC );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TGraphicTool.SetBrushBitmap]\r
procedure TGraphicTool.SetBrushBitmap(const Value: HBitmap);\r
begin\r
  if fData.Brush.Bitmap = Value then Exit;\r
  if fData.Brush.Bitmap <> 0 then\r
  begin\r
    ///////////\r
    Changed; // !!!\r
    ///////////\r
    DeleteObject( fData.Brush.Bitmap );\r
  end;\r
  fData.Brush.Bitmap := Value;\r
  Changed;\r
end;\r
\r
//[procedure TGraphicTool.SetBrushStyle]\r
procedure TGraphicTool.SetBrushStyle(const Value: TBrushStyle);\r
begin\r
  if fData.Brush.Style = Value then Exit;\r
  fData.Brush.Style := Value;\r
  Changed;\r
end;\r
\r
//[procedure TGraphicTool.SetFontCharset]\r
procedure TGraphicTool.SetFontCharset(const Value: TFontCharset);\r
begin\r
  if fData.Font.Charset = Value then Exit;\r
  fData.Font.Charset := Value;\r
  Changed;\r
end;\r
\r
//[procedure TGraphicTool.SetFontQuality]\r
procedure TGraphicTool.SetFontQuality(const Value: TFontQuality);\r
begin\r
  if fData.Font.Quality = Value then Exit;\r
  fData.Font.Quality := Value;\r
  Changed;\r
end;\r
\r
//[function TGraphicTool.GetFontName]\r
function TGraphicTool.GetFontName: String;\r
begin\r
  Result := fData.Font.Name;\r
end;\r
\r
//[procedure TGraphicTool.SetFontName]\r
procedure TGraphicTool.SetFontName(const Value: String);\r
begin\r
  if fData.Font.Name = Value then Exit;\r
  FillChar( fData.Font.Name[ 0 ], LF_FACESIZE, 0 );\r
  StrLCopy( fData.Font.Name, PChar( Value ), LF_FACESIZE );\r
  Changed;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TextAreaEx]\r
procedure TextAreaEx( Sender: PCanvas; var Sz : TSize; var Pt : TPoint );\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
        PUSH     EDX // [EBP-4] = @Sz\r
        PUSH     ECX // [EBP-8] = @Pt\r
        MOV      EBX, EAX\r
        CALL     TCanvas.GetFont\r
        MOV      ESI, [EAX].TGraphicTool.fData.Font.Orientation\r
        CALL     TGraphicTool.IsFontTrueType\r
        TEST     AL, AL\r
        JZ       @@exit\r
\r
        MOV      EDI, [EBP-8]\r
        XOR      EAX, EAX\r
        STOSD\r
        STOSD\r
        TEST     ESI, ESI\r
        JZ       @@exit\r
\r
        PUSH     EAX // Pts[1].x\r
        PUSH     EAX // Pts[1].y\r
\r
        PUSH     ESI\r
        FILD     dword ptr [ESP]\r
        POP      EDX\r
\r
        FILD     word ptr [@@1800]\r
        FDIV\r
        //FWAIT\r
        FLDPI\r
        FMUL\r
        //FWAIT\r
\r
        FLD      ST(0)\r
        FSINCOS\r
        FWAIT\r
\r
        MOV      ESI, [EBP-4]\r
        LODSD         // Sz.cx\r
        PUSH     EAX\r
        FILD     dword ptr [ESP]\r
        FMUL\r
        FISTP    dword ptr [ESP] // Pts[2].x\r
        FWAIT\r
        NEG      EAX\r
        PUSH     EAX\r
        FILD     dword ptr [ESP]\r
        FMUL\r
        FISTP    dword ptr [ESP] // Pts[2].y\r
        FWAIT\r
\r
        FLDPI\r
        FLD1\r
        FLD1\r
        FADD\r
        FDIV\r
        FADD\r
        FSINCOS\r
        FWAIT\r
\r
        LODSD\r
        NEG      EAX\r
        PUSH     EAX\r
        FILD     dword ptr [ESP]\r
        FMUL\r
        FISTP    dword ptr [ESP] // Pts[4].x\r
        FWAIT\r
        NEG      EAX\r
        PUSH     EAX\r
        FILD     dword ptr [ESP]\r
        FMUL\r
        FISTP    dword ptr [ESP] // Pts[4].y\r
        FWAIT\r
\r
        POP      ECX\r
        POP      EDX\r
        PUSH     EDX\r
        PUSH     ECX\r
        ADD      EDX, [ESP+12]\r
        ADD      ECX, [ESP+8]\r
        PUSH     EDX\r
        PUSH     ECX\r
\r
        MOV      ESI, ESP\r
        XOR      EDX, EDX // MinX\r
        XOR      EDI, EDI // MinY\r
        XOR      ECX, ECX\r
        MOV      CL, 3\r
\r
@@loo1: LODSD\r
        CMP      EAX, EDI\r
        JGE      @@1\r
        XCHG     EDI, EAX\r
@@1:    LODSD\r
        CMP      EAX, EDX\r
        JGE      @@2\r
        XCHG     EDX, EAX\r
@@2:    LOOP     @@loo1\r
\r
        MOV      ESI, [EBP-4]\r
        MOV      [ESI], ECX\r
        MOV      [ESI+4], ECX\r
        MOV      CL, 4\r
@@loo2:\r
        POP      EBX\r
        SUB      EBX, EDI\r
        CMP      EBX, [ESI+4]\r
        JLE      @@3\r
        MOV      [ESI+4], EBX\r
@@3:\r
        POP      EAX\r
        SUB      EAX, EDX\r
        CMP      EAX, [ESI]\r
        JLE      @@4\r
        MOV      [ESI], EAX\r
@@4:\r
        LOOP     @@loo2\r
\r
        MOV      EDI, [EBP-8]\r
        STOSD\r
        XCHG     EAX, EBX\r
        STOSD\r
        JMP      @@exit\r
\r
@@1800: DW  1800\r
\r
@@exit:\r
        MOV      ESP, EBP\r
        POP      EBP\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TextAreaEx( Sender: PCanvas; var Sz : TSize; var Pt : TPoint );\r
var Orient : Integer;\r
    Pts : array[ 1..4 ] of TPoint;\r
    MinX, MinY, I : Integer;\r
    A : Double;\r
begin\r
   if not Sender.Font.IsFontTrueType then Exit;\r
   Orient := Sender.Font.FontOrientation;\r
   Pt.x := 0; Pt.y := 0;\r
   if Orient = 0 then\r
      Exit;\r
   A := Orient / 1800.0 * PI;\r
   Pts[ 1 ] := Pt;\r
   Pts[ 2 ].x := Round( Sz.cx * cos( A ) );\r
   Pts[ 2 ].y := - Round( Sz.cx * sin( A ) );\r
   Pts[ 4 ].x := - Round( Sz.cy * cos( A + PI / 2 ) );\r
   Pts[ 4 ].y := Round( Sz.cy * sin( A + PI / 2 ) );\r
   Pts[ 3 ].x := Pts[ 2 ].x + Pts[ 4 ].x;\r
   Pts[ 3 ].y := Pts[ 2 ].y + Pts[ 4 ].y;\r
   MinX := 0; MinY := 0;\r
   for I := 2 to 4 do\r
   begin\r
      if Pts[ I ].x < MinX then\r
         MinX := Pts[ I ].x;\r
      if Pts[ I ].y < MinY then\r
         MinY := Pts[ I ].y;\r
   end;\r
   Sz.cx := 0;\r
   Sz.cy := 0;\r
   for I := 1 to 4 do\r
   begin\r
      Pts[ I ].x := Pts[ I ].x - MinX;\r
      Pts[ I ].y := Pts[ I ].y - MinY;\r
      if Pts[ I ].x > Sz.cx then\r
         Sz.cx := Pts[ I ].x;\r
      if Pts[ I ].y > Sz.cy then\r
         Sz.cy := Pts[ I ].y;\r
   end;\r
   Pt := Pts[ 1 ];\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TGraphicTool.SetFontOrientation]\r
procedure TGraphicTool.SetFontOrientation(Value: Integer);\r
asm\r
        PUSH     EAX\r
@@1:    MOV      EAX, EDX\r
        MOV      ECX, 3600\r
        CDQ\r
        IDIV     ECX     // EDX = Value mod 3600\r
        POP      EAX\r
\r
        MOV      byte ptr [GlobalGraphics_UseFontOrient], 1\r
        MOV      [GlobalCanvas_OnTextArea], offset[TextAreaEx]\r
\r
        MOV      [EAX].fData.Font.Escapement, EDX\r
        MOV      ECX, EDX\r
        MOV      DX, go_FontOrientation\r
        CALL     SetInt\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TGraphicTool.SetFontOrientation(Value: Integer);\r
begin\r
  GlobalGraphics_UseFontOrient := True;\r
  GlobalCanvas_OnTextArea := TextAreaEx;\r
  Value := Value mod 3600; // -3599..+3599\r
  SetInt( go_FontOrientation, Value );\r
  SetInt( go_FontEscapement, Value );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TGraphicTool.SetFontPitch]\r
procedure TGraphicTool.SetFontPitch(const Value: TFontPitch);\r
begin\r
  if fData.Font.Pitch = Value then Exit;\r
  fData.Font.Pitch := Value;\r
  Changed;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TGraphicTool.GetFontStyle]\r
function TGraphicTool.GetFontStyle: TFontStyle;\r
asm\r
       MOV   EDX, dword ptr [EAX].fData.Font.Italic\r
       AND   EDX, $010101\r
       MOV   EAX, [EAX].fData.Font.Weight\r
       CMP   EAX, 700\r
       SETGE AL       //AL:1 = fsBold\r
       ADD   EDX, EDX\r
       OR    EAX, EDX //AL:2 = fsItalic\r
       SHR   EDX, 7\r
       OR    EAX, EDX //AL:3 = fsUnderline\r
       SHR   EDX, 7\r
       OR    EAX, EDX //AL:4 = fsStrikeOut\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TGraphicTool.GetFontStyle: TFontStyle;\r
type PFontStyle = ^TFontStyle;\r
begin\r
  Result := [ ];\r
  if fData.Font.Weight >= 700 then Result := [ fsBold ];\r
  if fData.Font.Italic        then Result := Result + [ fsItalic ];\r
  if fData.Font.Underline     then Result := Result + [ fsUnderline ];\r
  if fData.Font.StrikeOut     then Result := Result + [ fsStrikeOut ];\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TGraphicTool.SetFontStyle]\r
procedure TGraphicTool.SetFontStyle(const Value: TFontStyle);\r
asm\r
        PUSH     EDI\r
        MOV      EDI, EAX\r
        PUSH     EDX\r
        CALL     GetFontStyle\r
        POP      EDX\r
        CMP      AL, DL\r
        JE       @@exit\r
        PUSH     EDI\r
\r
        LEA      EDI, [EDI].fData.Font.Weight\r
        MOV      ECX, [EDI]\r
        SHR      EDX, 1\r
        JNC      @@1\r
        CMP      ECX, 700\r
        JGE      @@2\r
        MOV      ECX, 700\r
        JMP      @@2\r
@@1:    CMP      ECX, 700\r
        JL       @@2\r
        XOR      ECX, ECX\r
@@2:    XCHG     EAX, ECX\r
        STOSD    // change Weight\r
        SHR      EDX, 1\r
        SETC     AL\r
        STOSB    // change Italic\r
        SHR      EDX, 1\r
        SETC     AL\r
        STOSB    // change Underline\r
        SHR      EDX, 1\r
        SETC     AL\r
        STOSB    // change StrikeOut\r
        POP      EAX\r
        CALL     Changed\r
@@exit: POP      EDI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TGraphicTool.SetFontStyle(const Value: TFontStyle);\r
begin\r
  if FontStyle = Value then Exit;\r
  if fsBold in Value then\r
  begin\r
    if fData.Font.Weight < 700 then\r
      fData.Font.Weight := 700;\r
  end\r
    else\r
  begin\r
    if fData.Font.Weight >= 700 then\r
      fData.Font.Weight := 0;\r
  end;\r
  fData.Font.Italic := fsItalic in Value;\r
  fData.Font.Underline := fsUnderline in Value;\r
  fData.Font.StrikeOut := fsStrikeOut in Value;\r
  Changed;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TGraphicTool.SetPenMode]\r
procedure TGraphicTool.SetPenMode(const Value: TPenMode);\r
begin\r
  if fData.Pen.Mode = Value then Exit;\r
  fData.Pen.Mode := Value;\r
  Changed;\r
end;\r
\r
//[procedure TGraphicTool.SetPenStyle]\r
procedure TGraphicTool.SetPenStyle(const Value: TPenStyle);\r
begin\r
  if fData.Pen.Style = Value then Exit;\r
  fData.Pen.Style := Value;\r
  Changed;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TGraphicTool.GetHandle]\r
function TGraphicTool.GetHandle: THandle;\r
const DataSz = sizeof( TGDIToolData );\r
asm\r
        PUSH      EBX\r
@@start:\r
        XCHG      EBX, EAX\r
        MOV       ECX, [EBX].fHandle\r
        JECXZ     @@1\r
\r
        MOV       EAX, [EBX].fData.Color\r
        CALL      Color2RGB\r
        CMP       EAX, [EBX].fColorRGB\r
        JE        @@1\r
\r
        MOV       EAX, EBX\r
        CALL      ReleaseHandle\r
        PUSH      EAX\r
        CALL      DeleteObject\r
\r
@@1:    MOV       ECX, [EBX].fHandle\r
        INC       ECX\r
        LOOP      @@exit\r
\r
        MOV       ECX, [EBX].fParentGDITool\r
        JECXZ     @@2\r
        LEA       EDX, [ECX].fData\r
        LEA       EAX, [EBX].fData\r
        MOV       ECX, DataSz\r
        CALL      CompareMem\r
        TEST      AL, AL\r
        MOV       EAX, [EBX].fParentGDITool\r
        JNZ       @@start\r
\r
@@2:    MOV       ECX, [EBX].fHandle\r
        INC       ECX\r
        LOOP      @@exit\r
\r
        MOV       EAX, [EBX].fData.Color\r
        CALL      Color2RGB\r
        MOV       [EBX].fColorRGB, EAX\r
        XCHG      EAX, EBX\r
        CALL      dword ptr [EAX].fMakeHandleProc\r
        XCHG      ECX, EAX\r
\r
@@exit: XCHG      EAX, ECX\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TGraphicTool.GetHandle: THandle;\r
begin\r
  Result := fHandle;\r
  if Result <> 0 then\r
  begin\r
    if Color2RGB( fData.Color ) <> fColorRGB then\r
    begin\r
      DeleteObject( ReleaseHandle );\r
      Result := 0;\r
    end;\r
  end;\r
  if Result = 0 then\r
  begin\r
    if Assigned( fParentGDITool ) then\r
    begin\r
      if CompareMem( @ fData, @ fParentGDITool.fData, Sizeof( fData ) ) then\r
      begin\r
        Result := fParentGDITool.Handle;\r
        Exit;\r
      end;\r
    end;\r
\r
    if fHandle = 0 then\r
    begin\r
      fColorRGB := Color2RGB( fData.Color );\r
      fMakeHandleProc( @Self );\r
    end;\r
    Result := fHandle;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[FUNCTION MakeBrushHandle]\r
{$IFDEF ASM_VERSION}\r
function MakeBrushHandle( Self_: PGraphicTool ): THandle;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].TGraphicTool.fHandle\r
        TEST     EAX, EAX\r
        JNZ      @@exit\r
\r
        MOV      EAX, [EBX].TGraphicTool.fData.Color\r
        CALL     Color2RGB   // EAX = ColorRef\r
\r
        XOR      EDX, EDX\r
\r
        MOV      ECX, [EBX].TGraphicTool.fData.Brush.Bitmap\r
        PUSH     ECX\r
        JECXZ    @@1\r
\r
        MOV      DL, BS_PATTERN\r
        JMP      @@2\r
\r
@@1:\r
        MOV      CL, [EBX].TGraphicTool.fData.Brush.Style\r
        MOV      DL, CL\r
        SUB      CL, 2\r
        JL       @@2\r
\r
        XCHG     ECX, [ESP]\r
\r
@@2:    PUSH     EAX\r
        PUSH     EDX\r
\r
        PUSH     ESP\r
        CALL     CreateBrushIndirect\r
        MOV      [EBX].TGraphicTool.fHandle, EAX\r
\r
        ADD      ESP, 12\r
\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function MakeBrushHandle( Self_: PGraphicTool ): THandle;\r
var\r
  LogBrush: TLogBrush;\r
begin\r
  if Self_.fHandle = 0 then\r
  begin\r
   LogBrush.lbColor := Color2RGB( Self_.fData.Color );\r
   if Self_.fData.Brush.Bitmap <> 0 then\r
   begin\r
     LogBrush.lbStyle := BS_PATTERN;\r
     LogBrush.lbHatch := Self_.fData.Brush.Bitmap;\r
   end\r
      else\r
   begin\r
     LogBrush.lbHatch := 0;\r
     case Self_.fData.Brush.Style of\r
       bsSolid: LogBrush.lbStyle := BS_SOLID;\r
       bsClear: LogBrush.lbStyle := BS_NULL;\r
     else\r
       LogBrush.lbStyle := BS_HATCHED;\r
       LogBrush.lbHatch := Ord( Self_.fData.Brush.Style ) - Ord( bsHorizontal );\r
       LogBrush.lbColor := Color2RGB( Self_.fData.Brush.LineColor );\r
     end;\r
   end;\r
   Self_.fHandle := CreateBrushIndirect(LogBrush);\r
   {$IFDEF DEBUG_GDIOBJECTS}\r
   if Self_.fHandle <> 0 then\r
     Inc( BrushCount )\r
   else\r
     ShowMessage( 'Could not create brush, error ' + Int2Str( GetLastError ) +\r
                  ': ' + SysErrorMessage( GetLastError ) );\r
   {$ENDIF}\r
  end;\r
  //GlobalGraphics_OnObjectCreated( @Self );\r
  Result := Self_.fHandle;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END MakeBrushHandle]\r
\r
//[FUNCTION MakeFontHandle]\r
{$IFDEF ASM_VERSION}\r
function MakeFontHandle( Self_: PGraphicTool ): THandle;\r
asm\r
         XCHG   EDX, EAX\r
         MOV    EAX, [EDX].TGraphicTool.fHandle\r
         TEST   EAX, EAX\r
         JNZ    @@exit\r
         PUSH   EDX\r
         LEA    ECX, [EDX].TGraphicTool.fData.Font\r
         PUSH   ECX\r
         CALL   CreateFontIndirect\r
         POP    EDX\r
         MOV    [EDX].TGraphicTool.fHandle, EAX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function MakeFontHandle( Self_: PGraphicTool ): THandle;\r
//var LogFont: TLogFont;\r
begin\r
  with Self_{-}^{+} do\r
  begin\r
    if fHandle = 0 then\r
    begin\r
      fHandle := CreateFontIndirect( PLogFont( @ fData.Font )^ );\r
      {$IFDEF DEBUG_GDIOBJECTS}\r
      Inc( FontCount );\r
      {$ENDIF}\r
    end;\r
    Result := fHandle;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END MakeFontHandle]\r
\r
//[FUNCTION MakePenHandle]\r
{$IFDEF ASM_VERSION}\r
function MakePenHandle( Self_: PGraphicTool ): THandle;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        MOV      EAX, [EBX].TGraphicTool.fHandle\r
        TEST     EAX, EAX\r
        JNZ      @@exit\r
\r
        MOV      EAX, [EBX].TGraphicTool.fData.Color\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     [EBX].TGraphicTool.fData.Pen.Width\r
        MOVZX    EAX, [EBX].TGraphicTool.fData.Pen.Style\r
        PUSH     EAX\r
        PUSH     ESP\r
        CALL     CreatePenIndirect\r
        MOV      [EBX].TGraphicTool.fHandle, EAX\r
        ADD      ESP, 16\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function MakePenHandle( Self_: PGraphicTool ): THandle;\r
var\r
  LogPen: TLogPen;\r
begin\r
  with Self_{-}^{+} do\r
  begin\r
    //GlobalGraphics_OnObjectCreating( @Self );\r
    if fHandle = 0 then\r
    with LogPen do\r
    begin\r
      lopnStyle := Byte( fData.Pen.Style );\r
      lopnWidth.X := fData.Pen.Width;\r
      lopnColor := Color2RGB( fData.Color );\r
      fHandle := CreatePenIndirect( LogPen );\r
      {$IFDEF DEBUG_GDIOBJECTS}\r
      Inc( PenCount );\r
      {$ENDIF}\r
    end;\r
    //GlobalGraphics_OnObjectCreated( @Self );\r
    Result := fHandle;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END MakePenHandle]\r
\r
//+\r
//[procedure TGraphicTool.SetGeometricPen]\r
procedure TGraphicTool.SetGeometricPen(const Value: Boolean);\r
begin\r
  if fData.Pen.Geometric = Value then Exit;\r
  fData.Pen.Geometric := Value;\r
  fMakeHandleProc := MakeGeometricPenHandle;\r
  Changed;\r
end;\r
\r
//[procedure TGraphicTool.SetPenEndCap]\r
procedure TGraphicTool.SetPenEndCap(const Value: TPenEndCap);\r
begin\r
  if fData.Pen.EndCap = Value then Exit;\r
  fData.Pen.EndCap := Value;\r
  Changed;\r
end;\r
\r
//[procedure TGraphicTool.SetPenJoin]\r
procedure TGraphicTool.SetPenJoin(const Value: TPenJoin);\r
begin\r
  if fData.Pen.Join = Value then Exit;\r
  fData.Pen.Join := Value;\r
  Changed;\r
end;\r
\r
//[FUNCTION MakeGeometricPenHandle]\r
{$IFDEF ASM_VERSION}\r
function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle;\r
asm\r
        MOV      ECX, [EAX].TGraphicTool.fHandle\r
        INC      ECX\r
        LOOP     @@exit\r
\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].TGraphicTool.fData.Color\r
        CALL     Color2RGB // EAX = Color2RGB( fColor )\r
        CDQ                // EDX = lbHatch (0)\r
        MOV      ECX, [EBX].TGraphicTool.fData.Pen.BrushBitmap\r
        JECXZ    @@no_brush_bitmap\r
\r
        XCHG     EDX, ECX // lbHatch = fPenBrushBitmap\r
        MOV      CL, BS_PATTERN // = 3\r
        JMP      @@create_pen\r
\r
@@no_brush_bitmap:\r
        MOVZX    ECX, [EBX].TGraphicTool.fData.Pen.BrushStyle\r
        CMP      CL, 1\r
        JLE      @@create_pen\r
        MOV      EDX, ECX\r
        MOV      CL, 2\r
        SUB      EDX, ECX\r
\r
@@create_pen:\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     ECX\r
        MOV      ECX, ESP\r
\r
        CDQ\r
        PUSH     EDX\r
        PUSH     EDX\r
        PUSH     ECX\r
        PUSH     [EBX].TGraphicTool.fData.Pen.Width\r
        MOVZX    ECX, [EBX].TGraphicTool.fData.Pen.Join\r
        SHL      ECX, 12\r
        MOVZX    EDX, [EBX].TGraphicTool.fData.Pen.EndCap\r
        SHL      EDX, 8\r
        OR       EDX, ECX\r
        OR       DL, byte ptr [EBX].TGraphicTool.fData.Pen.Style\r
        OR       EDX, PS_GEOMETRIC\r
        PUSH     EDX\r
        CALL     ExtCreatePen\r
\r
        POP      ECX\r
        POP      ECX\r
        POP      ECX\r
\r
        MOV      [EBX].TGraphicTool.fHandle, EAX\r
        POP      EBX\r
        RET\r
@@exit:\r
        XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle;\r
const\r
  PenStyles: array[ TPenStyle ] of Word =\r
    (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,\r
     PS_INSIDEFRAME);\r
  PenEndCapStyles: array[ TPenEndCap ] of Word =\r
    (PS_ENDCAP_ROUND, PS_ENDCAP_SQUARE, PS_ENDCAP_FLAT);\r
  PenJoinStyles: array[ TPenJoin ] of Word =\r
    (PS_JOIN_ROUND, PS_JOIN_BEVEL, PS_JOIN_MITER );\r
var\r
  LogBrush: TLogBrush;\r
begin\r
  if Self_.fHandle = 0 then\r
  with Self_{-}^{+}, LogBrush do\r
  begin\r
      lbColor := Color2RGB( fData.Color );\r
      lbHatch := 0;\r
      if fData.Pen.BrushBitmap <> 0 then\r
      begin\r
        lbStyle := BS_PATTERN;\r
        lbHatch := fData.Pen.BrushBitmap;\r
      end\r
         else\r
      case fData.Pen.BrushStyle of\r
      bsSolid: lbStyle := BS_SOLID;\r
      bsClear: lbStyle := BS_NULL;\r
      else  begin\r
               lbStyle := BS_HATCHED;\r
               case fData.Pen.BrushStyle of\r
               bsHorizontal: lbHatch := HS_HORIZONTAL;\r
               bsVertical:   lbHatch := HS_VERTICAL;\r
               bsFDiagonal:  lbHatch := HS_FDIAGONAL;\r
               bsBDiagonal:  lbHatch := HS_BDIAGONAL;\r
               bsCross:      lbHatch := HS_CROSS;\r
               bsDiagCross:  lbHatch := HS_DIAGCROSS;\r
               end;\r
            end;\r
      end;\r
  end;\r
  Self_.fHandle := ExtCreatePen( PS_GEOMETRIC or Byte( Self_.fData.Pen.Style ) or\r
                           PenEndCapStyles[ Self_.fData.Pen.EndCap ] or\r
                           PenJoinStyles[ Self_.fData.Pen.Join ],\r
             Self_.fData.Pen.Width, LogBrush, 0, nil );\r
  {Assert( Self_.fHandle <> 0, 'Error ' + Int2Str( GetLastError ) +\r
                              ': ' + SysErrorMessage( GetLastError ) );}\r
  {$IFDEF DEBUG_GDIOBJECTS}\r
  Inc( PenCount );\r
  {$ENDIF}\r
  Result := Self_.fHandle;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END MakeGeometricPenHandle]\r
\r
//[procedure TGraphicTool.SetFontWeight]\r
procedure TGraphicTool.SetFontWeight(const Value: Integer);\r
begin\r
  if fData.Font.Weight = Value then Exit;\r
  fData.Font.Weight := Value;\r
  Changed;\r
end;\r
\r
//[procedure TGraphicTool.SetLogFontStruct]\r
procedure TGraphicTool.SetLogFontStruct(const Value: TLogFont);\r
begin\r
  if  CompareMem(@fData.Font, @Value, SizeOf(TLogFont)) then Exit;\r
  Move(Value, fData.Font, SizeOF(TLogFont));\r
  Changed;\r
end;\r
\r
//[function TGraphicTool.GetLogFontStruct]\r
function TGraphicTool.GetLogFontStruct: TLogFont;\r
begin\r
  Move(fData.Font, Result, SizeOf(TLogFont));\r
end;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ TCanvas }\r
\r
type\r
  TStock = Packed Record\r
    StockPen: HPEN;\r
    StockBrush: HBRUSH;\r
    StockFont: HFONT;\r
  end;\r
\r
var\r
  Stock: TStock;\r
\r
//[destructor TCanvas.Destroy]\r
destructor TCanvas.Destroy;\r
begin\r
  Handle := 0;\r
  fPen.Free;\r
  fBrush.Free;\r
  fFont.Free;\r
  //if Assigned( GlobalCanvas_OnDestroyCanvas ) then\r
  //   GlobalCanvas_OnDestroyCanvas( Self );\r
  inherited;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TCanvas.Assign]\r
function TCanvas.Assign(SrcCanvas: PCanvas): Boolean;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        XCHG     EBX, EAX\r
        MOV      ESI, EDX\r
\r
        MOV      EAX, [EBX].fFont\r
        MOV      EDX, [ESI].fFont\r
        CALL     TGraphicTool.Assign\r
        MOV      [EBX].fFont, EAX\r
\r
        MOV      EAX, [EBX].fBrush\r
        MOV      EDX, [ESI].fBrush\r
        CALL     TGraphicTool.Assign\r
        MOV      [EBX].fBrush, EAX\r
\r
        MOV      EAX, [EBX].fPen\r
        MOV      EDX, [ESI].fPen\r
        CALL     TGraphicTool.Assign\r
        MOV      [EBX].fPen, EAX\r
\r
        CALL     AssignChangeEvents\r
\r
        MOV      ECX, [EBX].fFont\r
        OR       ECX, [EBX].fBrush\r
        OR       ECX, [EBX].fPen\r
        SETNZ    AL\r
\r
        MOV      EDX, [ESI].fPenPos.x\r
        MOV      ECX, [ESI].fPenPos.y\r
        CMP      EDX, [EBX].fPenPos.x\r
        JNE      @@chg_penpos\r
        CMP      ECX, [EBX].fPenPos.y\r
        JE       @@1\r
@@chg_penpos:\r
        MOV      AL, 1\r
        MOV      [EBX].fPenPos.x, EDX\r
        MOV      [EBX].fPenPos.y, ECX\r
@@1:\r
        MOV       EDX, [ESI].fCopyMode\r
        CMP       EDX, [EBX].fCopyMode\r
        JE        @@2\r
        MOV       [EBX].fCopyMode, EDX\r
        MOV       AL, 1\r
@@2:\r
        POP       ESI\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TCanvas.Assign(SrcCanvas: PCanvas): Boolean;\r
begin\r
  fFont := fFont.Assign( SrcCanvas.fFont );\r
  fBrush := fBrush.Assign( SrcCanvas.fBrush );\r
  fPen := fPen.Assign( SrcCanvas.fPen );\r
  AssignChangeEvents;\r
  Result := (fFont <> nil) or (fBrush <> nil) or (fPen <> nil);\r
  if (SrcCanvas.PenPos.x <> PenPos.x) or (SrcCanvas.PenPos.y <> PenPos.y) then\r
  begin\r
     Result := True;\r
     PenPos := SrcCanvas.PenPos;\r
  end;\r
  if SrcCanvas.ModeCopy <> ModeCopy then\r
  begin\r
     Result := True;\r
     ModeCopy := SrcCanvas.ModeCopy;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.CreateBrush]\r
procedure TCanvas.CreateBrush;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        MOV      ECX, [EAX].fBrush\r
        JECXZ    @@chk_owner\r
\r
        MOV      EAX, ECX\r
        CALL     TGraphicTool.GetHandle\r
        PUSH     EAX\r
\r
        MOV      EAX, EBX\r
        CALL     AssignChangeEvents\r
\r
        MOV      EAX, EBX\r
        CALL     TCanvas.GetHandle\r
        PUSH     EAX\r
\r
        CALL     SelectObject\r
\r
        MOV      EDX, [EBX].TCanvas.fBrush\r
        CMP      [EDX].TGraphicTool.fData.Brush.Style, bsSolid\r
\r
        MOV      EAX, [EDX].TGraphicTool.fData.Color\r
@@0:\r
        MOV      EBX, [EBX].TCanvas.fHandle\r
        MOV      ECX, offset[Color2RGB]\r
        JNZ      @@1\r
\r
        PUSH     OPAQUE\r
        PUSH     EBX\r
\r
        CALL     ECX //Color2RGB\r
        PUSH     EAX\r
        PUSH     EBX\r
        JMP      @@2\r
@@1:\r
        PUSH     TRANSPARENT\r
        PUSH     EBX\r
\r
        CALL     ECX //Color2RGB\r
        NOT      EAX\r
        PUSH     EAX\r
        PUSH     EBX\r
@@2:\r
        CALL     SetBkColor\r
        CALL     SetBkMode\r
@@exit:\r
        POP      EBX\r
        RET\r
\r
@@chk_owner:\r
        MOV      ECX, [EBX].fOwnerControl\r
        JECXZ    @@exit\r
\r
        MOV      EAX, [ECX].TControl.fColor\r
        XOR      ECX, ECX\r
        JMP      @@0\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.CreateBrush;\r
begin\r
  //UnrealizeObject( Brush.Handle );\r
  // if GdiObject parameter of UnrealizeObject is brush handle,\r
  // this call does nothing (from Win32.hlp)\r
\r
  if assigned( fBrush ) then\r
  begin\r
    SelectObject( GetHandle, fBrush.Handle );\r
    //fBrush.fOnChange := ObjectChanged;\r
    AssignChangeEvents;\r
    if fBrush.fData.Brush.Style = bsSolid then\r
    begin\r
      SetBkColor( fHandle, Color2RGB( fBrush.fData.Color ) );\r
      SetBkMode( fHandle, OPAQUE );\r
    end\r
       else\r
    begin\r
      { Win95 doesn't draw brush hatches if bkcolor = brush color }\r
      { Since bkmode is transparent, nothing should use bkcolor anyway }\r
      SetBkColor( fHandle, not Color2RGB( fBrush.fData.Color ) );\r
      SetBkMode( fHandle, TRANSPARENT );\r
    end;\r
  end\r
     else\r
  if Assigned( fOwnerControl ) then\r
  begin\r
    SetBkColor( GetHandle, Color2RGB( PControl( fOwnerControl ).fColor ) );\r
    SetBkMode( fHandle, OPAQUE );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.CreateFont]\r
procedure TCanvas.CreateFont;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        MOV      ECX, [EAX].TCanvas.fFont\r
        JECXZ    @@chk_owner\r
\r
        MOV      EAX, [ECX].TGraphicTool.fData.Color\r
        PUSH     ECX\r
        CALL     Color2RGB\r
        XCHG     EAX, [ESP]\r
\r
        CALL     TGraphicTool.GetHandle\r
        PUSH     EAX\r
\r
        MOV      EAX, EBX\r
        CALL     AssignChangeEvents;\r
\r
        MOV      EAX, EBX\r
        CALL     TCanvas.GetHandle\r
        PUSH     EAX\r
        MOV      EBX, EAX\r
\r
        CALL     SelectObject\r
\r
@@set_txcolor:\r
        PUSH     EBX\r
        CALL     SetTextColor\r
\r
@@exit:\r
        POP      EBX\r
        RET\r
\r
@@chk_owner:\r
        MOV      ECX, [EBX].fOwnerControl\r
        JECXZ    @@exit\r
\r
        MOV      EBX, [EBX].fHandle\r
        MOV      EAX, [ECX].TControl.fTextColor\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        JMP      @@set_txcolor\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.CreateFont;\r
begin\r
  if assigned( fFont ) then\r
  begin\r
    SelectObject( GetHandle, fFont.Handle );\r
    SetTextColor( fHandle, Color2RGB( fFont.fData.Color ) );\r
    //fFont.fOnChange := ObjectChanged;\r
    AssignChangeEvents;\r
  end\r
     else\r
  if Assigned( fOwnerControl ) then\r
  begin\r
    SetTextColor( fHandle, Color2RGB( PControl( fOwnerControl ).fTextColor ) );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.CreatePen]\r
procedure TCanvas.CreatePen;\r
asm\r
        MOV      ECX, [EAX].TCanvas.fPen\r
        JECXZ    @@exit\r
\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        MOV      DL, [ECX].TGraphicTool.fData.Pen.Mode\r
        MOVZX    EDX, DL\r
        INC      EDX\r
        PUSH     EDX\r
\r
        MOV      EAX, ECX\r
        CALL     TGraphicTool.GetHandle\r
        PUSH     EAX\r
\r
        MOV      EAX, EBX\r
        CALL     AssignChangeEvents\r
\r
        MOV      EAX, EBX\r
        CALL     TCanvas.GetHandle\r
        PUSH     EAX\r
        MOV      EBX, EAX\r
\r
        CALL     SelectObject\r
        PUSH     EBX\r
        CALL     SetROP2\r
\r
        POP      EBX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.CreatePen;\r
begin\r
  if assigned( fPen ) then\r
  begin\r
    SelectObject( GetHandle, fPen.Handle );\r
    SetROP2( fHandle, Ord( fPen.fData.Pen.Mode ) + 1 );\r
    //fPen.fOnChange := ObjectChanged;\r
    AssignChangeEvents;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TCanvas.GetPixels]\r
function TCanvas.GetPixels(X, Y: Integer): TColor;\r
begin\r
  RequiredState( HandleValid );\r
  Result := Windows.GetPixel(FHandle, X, Y);\r
end;\r
\r
//[procedure TCanvas.SetPixels]\r
procedure TCanvas.SetPixels(X, Y: Integer; const Value: TColor);\r
begin\r
  Changing;\r
  RequiredState( HandleValid );\r
  Windows.SetPixel(FHandle, X, Y, Color2RGB( Value ));\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.DeselectHandles]\r
procedure TCanvas.DeselectHandles;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        LEA      EBX, [EAX].TCanvas.fState\r
        //CALL     TCanvas.GetHandle\r
        MOV      EAX, [EAX].TCanvas.fHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
\r
        MOVZX    EDX, byte ptr[EBX]\r
        AND      DL, PenValid or BrushValid or FontValid\r
        JZ       @@exit\r
\r
        PUSH     EAX\r
        LEA      EDI, [Stock]\r
\r
        MOV      ECX, [EDI]\r
        INC      ECX\r
        LOOP     @@1\r
\r
        MOV      ESI, offset[ GetStockObject ]\r
\r
        PUSH     BLACK_PEN\r
        CALL     ESI\r
        STOSD\r
\r
        PUSH     HOLLOW_BRUSH\r
        CALL     ESI\r
        STOSD\r
\r
        PUSH     SYSTEM_FONT\r
        CALL     ESI\r
        STOSD\r
\r
@@1:\r
        LEA      ESI, [Stock]\r
        POP      EDX\r
\r
        LODSD\r
        PUSH     EAX\r
        PUSH     EDX\r
\r
        LODSD\r
        PUSH     EAX\r
        PUSH     EDX\r
\r
        LODSD\r
        PUSH     EAX\r
        PUSH     EDX\r
\r
        MOV      ESI, offset[ SelectObject ]\r
        CALL     ESI\r
        CALL     ESI\r
        CALL     ESI\r
\r
        AND      byte ptr [EBX], not( PenValid or BrushValid or FontValid )\r
@@exit:\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.DeselectHandles;\r
begin\r
   //if (GetHandle <> 0) and\r
   if (fHandle <> 0) and\r
      LongBool(fState and (PenValid or BrushValid or FontValid)) then\r
   with Stock do\r
   begin\r
     if StockPen = 0 then\r
     begin\r
       StockPen := GetStockObject(BLACK_PEN);\r
       StockBrush := GetStockObject(HOLLOW_BRUSH);\r
       StockFont := GetStockObject(SYSTEM_FONT);\r
     end;\r
     SelectObject( fHandle, StockPen );\r
     SelectObject( fHandle, StockBrush );\r
     SelectObject( fHandle, StockFont );\r
     fState := fState and not( PenValid or BrushValid or FontValid );\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TCanvas.RequiredState]\r
function TCanvas.RequiredState(ReqState: DWORD): Integer; stdcall;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, ReqState\r
        MOV      ESI, [EBP+8] //Self\r
        MOV      EAX, ESI\r
        TEST     BL, ChangingCanvas\r
        JZ       @@1\r
        CALL     Changing\r
@@1:    AND      BL, 0Fh\r
\r
        TEST     BL, HandleValid\r
        JZ       @@2\r
        CALL     TCanvas.GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@ret_0\r
@@2:\r
        MOV      AL, [ESI].TCanvas.fState\r
        NOT      EAX\r
        AND      BL, AL\r
        JZ       @@ret_handle\r
\r
        TEST     BL, FontValid\r
        JZ       @@3\r
        MOV      EAX, ESI\r
        CALL     CreateFont\r
@@3:    TEST     BL, PenValid\r
        JZ       @@5\r
        MOV      EAX, ESI\r
        CALL     CreatePen\r
        MOV      ECX, [ESI].TCanvas.fPen\r
        JCXZ     @@5\r
        MOV      AL, [ECX].TGraphicTool.fData.Pen.Style\r
        DEC      AL\r
        {$IFDEF PARANOIA}\r
        DB $2C, 3\r
        {$ELSE}\r
        SUB      AL, 3\r
        {$ENDIF}\r
        JB       @@6\r
@@5:    TEST     BL, BrushValid\r
        JZ       @@7\r
@@6:    MOV      EAX, ESI\r
        CALL     CreateBrush\r
@@7:    OR       [ESI].TCanvas.fState, BL\r
@@ret_handle:\r
        MOV      EAX, [ESI].TCanvas.fHandle\r
@@ret_0:\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TCanvas.RequiredState(ReqState: DWORD): Integer; stdcall;\r
var\r
  NeededState: Byte;\r
begin\r
  if Boolean(ReqState and ChangingCanvas) then\r
     Changing;\r
  ReqState := ReqState and 15;\r
  NeededState := Byte( ReqState ) and not fState;\r
  Result := 0;\r
    if Boolean(ReqState and HandleValid) then\r
    begin\r
      if GetHandle = 0 then Exit;\r
      // Important!\r
    end;\r
  if NeededState <> 0 then\r
  begin\r
    if Boolean( NeededState and FontValid ) then\r
       CreateFont;\r
    if Boolean( NeededState and PenValid ) then\r
    begin\r
      CreatePen;\r
      if assigned( fPen ) then\r
      if fPen.fData.Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then\r
        NeededState := NeededState or BrushValid;\r
    end;\r
    if Boolean( NeededState and BrushValid ) then\r
       CreateBrush;\r
    fState := fState or NeededState;\r
  end;\r
  Result := fHandle;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.SetHandle]\r
procedure TCanvas.SetHandle(Value: HDC);\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        MOV      ECX, [EBX].fHandle\r
        CMP      ECX, EDX\r
        JZ       @@exit\r
        JECXZ    @@chk_val\r
\r
        PUSH     EDX\r
        PUSH     ECX\r
          CALL     DeselectHandles\r
        POP      EDX\r
\r
        MOV      ECX, [EBX].fOwnerControl\r
        JECXZ    @@chk_Release\r
        CMP      [ECX].TControl.fPaintDC, EDX\r
        JE       @@clr_Handle\r
\r
@@chk_Release:\r
        PUSH     EDX\r
        CMP      [EBX].fOnGetHandle.TMethod.Code, offset[TControl.DC2Canvas]\r
        JNE      @@deldc\r
        PUSH     [ECX].TControl.fHandle\r
        CALL     ReleaseDC\r
        JMP      @@clr_Handle\r
@@deldc:\r
        CALL     DeleteDC\r
\r
@@clr_Handle:\r
        XOR      ECX, ECX\r
        MOV      [EBX].TCanvas.fHandle, ECX\r
        MOV      [EBX].TCanvas.fIsPaintDC, CL\r
        AND      [EBX].TCanvas.fState, not HandleValid\r
\r
        POP      EDX\r
@@chk_val:\r
        TEST     EDX, EDX\r
        JZ       @@exit\r
\r
        OR       [EBX].TCanvas.fState, HandleValid\r
        MOV      [EBX].TCanvas.fHandle, EDX\r
        LEA      EDX, [EBX].TCanvas.fPenPos\r
        MOV      EAX, EBX\r
        CALL     SetPenPos\r
\r
@@exit: POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.SetHandle(Value: HDC);\r
{$IFDEF F_P}\r
var Ptr1: Pointer;\r
{$ENDIF F_P}\r
begin\r
  if fHandle = Value then Exit;\r
  if fHandle <> 0 then\r
  begin\r
    DeselectHandles;\r
    {if not fIsPaintDC and\r
       not( assigned(fOwnerControl) and\r
            PControl(fOwnerControl).fDoubleBuffered )\r
       then}\r
      if not( assigned(fOwnerControl) and\r
              (PControl(fOwnerControl).fPaintDC = fHandle) ) then\r
      begin\r
        {$IFDEF F_P}\r
        Ptr1 := Self;\r
        asm\r
          MOV  EAX, [Ptr1]\r
          MOV  EAX, [EAX].TCanvas.fOnGetHandle\r
          MOV  [Ptr1], EAX\r
        end [ 'EAX' ];\r
        if Ptr1 = @ TControl.DC2Canvas then\r
        {$ELSE DELPHI}\r
      //////////////////// SLAG\r
        if   TMethod(fOnGetHandle).Code =\r
             @TControl.Dc2Canvas then\r
        {$ENDIF F_P/DELPHI}\r
             ReleaseDC(PControl(fOwnerControl).Handle, fHandle )\r
        else\r
             DeleteDC( fHandle );\r
      ////////////////////\r
      end;\r
    fHandle := 0;\r
    fIsPaintDC := False;\r
    fState := fState and not HandleValid;\r
  end;\r
  if Value <> 0 then\r
  begin\r
    fState := fState or HandleValid;\r
    fHandle := Value;\r
    SetPenPos( fPenPos );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.SetPenPos]\r
procedure TCanvas.SetPenPos(const Value: TPoint);\r
asm\r
          MOV     ECX, [EDX].TPoint.y\r
          MOV     EDX, [EDX].TPoint.x\r
          MOV     [EAX].fPenPos.x, EDX\r
          MOV     [EAX].fPenPos.y, ECX\r
          CALL    MoveTo\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.SetPenPos(const Value: TPoint);\r
begin\r
  fPenPos := Value;\r
  MoveTo( Value.x, Value.y );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.Changing]\r
procedure TCanvas.Changing;\r
asm\r
        PUSHAD\r
        MOV      ECX, [EAX].fOnChange.TMethod.Code\r
        JECXZ    @@exit\r
        XCHG     EDX, EAX\r
        MOV      EAX, [EDX].fOnChange.TMethod.Data\r
        CALL     ECX\r
@@exit:\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.Changing;\r
begin\r
  if Assigned( fOnChange ) then\r
     fOnChange( @Self );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.Arc]\r
procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;\r
asm\r
        PUSH     ESI\r
\r
        PUSH     HandleValid or PenValid or ChangingCanvas\r
        PUSH     dword ptr [EBP+8]\r
        CALL     RequiredState\r
\r
        MOV      EDX, EAX\r
\r
        LEA      ESI, [Y4]\r
        STD\r
\r
        XOR      ECX, ECX\r
        MOV      CL, 8\r
@@1:\r
        LODSD\r
        PUSH     EAX\r
\r
        LOOP     @@1\r
\r
        CLD\r
        PUSH     EDX  //Canvas.fHandle\r
        CALL     Windows.Arc\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;\r
begin\r
  RequiredState( HandleValid or PenValid or ChangingCanvas );\r
  Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.Chord]\r
procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;\r
asm\r
        PUSH     HandleValid or PenValid or BrushValid or ChangingCanvas\r
        PUSH     dword ptr [EBP + 8]\r
        CALL     RequiredState\r
\r
        MOV      EDX, EAX\r
\r
        PUSH     ESI\r
        LEA      ESI, [Y4]\r
        STD\r
\r
        XOR      ECX, ECX\r
        MOV      CL, 8\r
@@1:\r
        LODSD\r
        PUSH     EAX\r
\r
        LOOP     @@1\r
\r
        CLD\r
        PUSH     EDX  //Canvas.fHandle\r
        CALL     Windows.Chord\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;\r
begin\r
  RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );\r
  Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.CopyRect]\r
procedure TCanvas.CopyRect(const DstRect: TRect; SrcCanvas: PCanvas;\r
  const SrcRect: TRect);\r
asm\r
        PUSH     ESI\r
        PUSH     EDI\r
\r
        PUSH     [EAX].fCopyMode\r
\r
        PUSH     EDX\r
\r
          PUSH     HandleValid or BrushValid\r
          PUSH     ECX\r
\r
          PUSH     HandleValid or FontValid or BrushValid or ChangingCanvas\r
          PUSH     EAX\r
          MOV      ESI, offset[ RequiredState ]\r
          CALL     ESI\r
          MOV      EDI, EAX     // EDI = @Self.fHandle\r
\r
          CALL     ESI\r
          MOV      EDX, EAX     // EDX = SrcCanvas.fHandle\r
\r
        POP      ECX          // ECX = @DstRect\r
\r
        MOV      ESI, [SrcRect]\r
\r
        MOV      EAX, [ESI].TRect.Bottom\r
        SUB      EAX, [ESI].TRect.Top\r
        PUSH     EAX\r
\r
        MOV      EAX, [ESI].TRect.Right\r
        SUB      EAX, [ESI].TRect.Left\r
        PUSH     EAX\r
\r
        PUSH     [ESI].TRect.Top\r
\r
        LODSD\r
        PUSH     EAX\r
\r
        PUSH     EDX\r
\r
        MOV      EAX, [ECX].TRect.Bottom\r
        MOV      EDX, [ECX].TRect.Top\r
        SUB      EAX, EDX\r
        PUSH     EAX\r
\r
        MOV      EAX, [ECX].TRect.Right\r
        MOV      ESI, [ECX].TRect.Left\r
        SUB      EAX, ESI\r
        PUSH     EAX\r
\r
        PUSH     EDX\r
\r
        PUSH     ESI\r
\r
        PUSH     EDI\r
\r
        CALL     StretchBlt\r
\r
        POP      EDI\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.CopyRect(const DstRect: TRect; SrcCanvas: PCanvas;\r
  const SrcRect: TRect);\r
begin\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  SrcCanvas.RequiredState( HandleValid or BrushValid );\r
  StretchBlt( fHandle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,\r
    DstRect.Bottom - DstRect.Top, SrcCanvas.Handle, SrcRect.Left, SrcRect.Top,\r
    SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, ModeCopy);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.DrawFocusRect]\r
procedure TCanvas.DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);\r
asm\r
        PUSH     EDX\r
\r
        PUSH     HandleValid or BrushValid or FontValid or ChangingCanvas\r
        PUSH     EAX\r
        CALL     RequiredState\r
\r
        PUSH     EAX\r
        CALL     Windows.DrawFocusRect\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);\r
begin\r
  RequiredState( HandleValid or BrushValid or FontValid or ChangingCanvas );\r
  Windows.DrawFocusRect(FHandle, Rect);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.Ellipse]\r
procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);\r
asm\r
        PUSH     [Y2]\r
        PUSH     [X2]\r
        PUSH     ECX\r
        PUSH     EDX\r
\r
        PUSH     HandleValid or PenValid or BrushValid or ChangingCanvas\r
        PUSH     EAX\r
        CALL     RequiredState\r
\r
        PUSH     EAX\r
        CALL     Windows.Ellipse\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);\r
begin\r
  RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );\r
  Windows.Ellipse(FHandle, X1, Y1, X2, Y2);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.FillRect]\r
procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        PUSH     EDX\r
        PUSH     HandleValid or BrushValid or ChangingCanvas\r
        PUSH     EBX\r
        CALL     RequiredState\r
        MOV      ECX, [EBX].fBrush\r
        JECXZ    @@chk_ctl\r
\r
@@fill_with_Brush:\r
        XCHG     EAX, ECX\r
        CALL     TGraphicTool.GetHandle\r
        POP      EDX\r
        PUSH     EAX\r
        JMP      @@fin\r
@@chk_ctl:\r
        MOV      ECX, [EBX].fOwnerControl\r
        JECXZ    @@dflt_fill\r
        XCHG     EAX, ECX\r
        MOV      ECX, [EAX].TControl.fBrush\r
        INC      ECX\r
        LOOP     @@fill_with_Brush\r
        MOV      EAX, [EAX].TControl.fColor\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        CALL     CreateSolidBrush\r
        POP      EDX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     [EBX].fHandle\r
        CALL     Windows.FillRect\r
        CALL     DeleteObject\r
        POP      EBX\r
        RET\r
@@dflt_fill:\r
        POP      EDX\r
        PUSH     COLOR_WINDOW + 1\r
@@fin:\r
        PUSH     EDX\r
        PUSH     [EBX].fHandle\r
        CALL     Windows.FillRect\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);\r
var Br: HBrush;\r
begin\r
  RequiredState( HandleValid or BrushValid or ChangingCanvas );\r
  if assigned( fBrush ) then\r
  begin\r
    Windows.FillRect(fHandle, Rect, fBrush.Handle);\r
  end\r
    else\r
  if assigned( fOwnerControl ) then\r
  begin\r
    if assigned( PControl( fOwnerControl ).fBrush ) then\r
      Windows.FillRect( fHandle, Rect, PControl( fOwnerControl ).fBrush.Handle )\r
    else\r
    begin\r
      Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) );\r
      Windows.FillRect(fHandle, Rect, Br );\r
      DeleteObject( Br );\r
    end;\r
  end\r
  else\r
  begin\r
    Windows.FillRect(fHandle, Rect, HBrush(COLOR_WINDOW + 1) );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.FillRgn]\r
procedure TCanvas.FillRgn(const Rgn: HRgn);\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        PUSH     EDX\r
\r
        PUSH     HandleValid or BrushValid or ChangingCanvas\r
        PUSH     EBX\r
        CALL     RequiredState\r
\r
        MOV      ECX, [EBX].TCanvas.fBrush\r
        JECXZ    @@1\r
\r
        //PUSH     [ECX].TGraphicTool.fData.Color\r
        //JMP      @@cr_br\r
\r
@@fill_rgn_using_Brush:\r
        XCHG     EAX, ECX\r
        CALL     TGraphicTool.GetHandle\r
        POP      EDX\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     [EBX].fHandle\r
        CALL     Windows.FillRgn\r
        JMP      @@fin\r
\r
@@1:    MOV      ECX, [EBX].TCanvas.fOwnerControl\r
        MOV      EAX, -1 // clWhite\r
        JECXZ    @@2\r
\r
        XCHG     EAX, ECX\r
        MOV      ECX, [EAX].TControl.fBrush\r
        INC      ECX\r
        LOOP     @@fill_rgn_using_Brush\r
\r
        MOV      EAX, [EAX].TControl.fColor\r
@@2:\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        CALL     CreateSolidBrush // EAX = Br\r
\r
        POP      EDX // Rgn\r
\r
        PUSH     EAX //-------------------//\r
        PUSH     EAX           // Br\r
        PUSH     EDX           // Rgn\r
        PUSH     [EBX].FHandle // fHandle\r
        CALL     Windows.FillRgn\r
\r
        CALL     DeleteObject\r
\r
@@fin:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.FillRgn(const Rgn: HRgn);\r
var Br : HBrush;\r
begin\r
  RequiredState( HandleValid or BrushValid or ChangingCanvas );\r
  if assigned( fBrush ) then\r
    Windows.FillRgn(FHandle, Rgn, fBrush.Handle )\r
    else\r
  if assigned( fOwnerControl ) then\r
  begin\r
    if Assigned( PControl( fOwnerControl ).fBrush ) then\r
      Windows.FillRgn( FHandle, Rgn, PControl( fOwnerControl ).fBrush.Handle )\r
    else\r
    begin\r
      Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) );\r
      Windows.FillRgn( fHandle, Rgn, Br );\r
      DeleteObject( Br );\r
    end;\r
  end\r
     else\r
  begin\r
    Br := CreateSolidBrush( DWORD(clWindow) );\r
    Windows.FillRgn( fHandle, Rgn, Br );\r
    DeleteObject( Br );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_!VERSION}\r
//[procedure TCanvas.FloodFill]\r
procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;\r
  FillStyle: TFillStyle);\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        MOVZX    EAX, [FillStyle]\r
        TEST     EAX, EAX\r
        MOV      EAX, FLOODFILLSURFACE   // = 1\r
        JZ       @@1\r
        //MOV      EAX, FLOODFILLBORDER  // = 0\r
        DEC      EAX\r
@@1:\r
        PUSH     EAX\r
        PUSH     [Color]\r
        PUSH     ECX\r
        PUSH     EDX\r
\r
        PUSH     HandleValid or BrushValid or ChangingCanvas\r
        PUSH     EBX\r
        CALL     RequiredState\r
        PUSH     EAX\r
        CALL     Windows.ExtFloodFill\r
\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;\r
  FillStyle: TFillStyle);\r
const\r
  FillStyles: array[TFillStyle] of Word =\r
    (FLOODFILLSURFACE, FLOODFILLBORDER);\r
begin\r
  RequiredState( HandleValid or BrushValid or ChangingCanvas );\r
  Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.FrameRect]\r
procedure TCanvas.FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        PUSH     EDX\r
\r
        MOV      ECX, [EBX].TCanvas.fBrush\r
        JECXZ    @@1\r
\r
        PUSH     [ECX].TGraphicTool.fData.Color\r
        JMP      @@cr_br\r
\r
@@1:    MOV      ECX, [EBX].TCanvas.fOwnerControl\r
        JECXZ    @@2\r
\r
        PUSH     [ECX].TControl.fColor\r
        JMP      @@cr_br\r
\r
@@2:    PUSH     clWhite\r
@@cr_br:POP      EAX                  // @Rect\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        CALL     CreateSolidBrush\r
        POP      EDX\r
          PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EDX\r
\r
        PUSH     HandleValid or ChangingCanvas\r
        PUSH     EBX\r
        ///MOV      EBX, EDX\r
        CALL     RequiredState\r
\r
        PUSH     EAX\r
        CALL     Windows.FrameRect\r
\r
        ///PUSH     EBX\r
        CALL     DeleteObject\r
\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);\r
var SolidBr : HBrush;\r
begin\r
  RequiredState( HandleValid or ChangingCanvas );\r
  if assigned( fBrush ) then\r
    SolidBr := CreateSolidBrush( Color2RGB( fBrush.fData.Color ) )\r
  else\r
  if assigned( fOwnerControl ) then\r
    SolidBr := CreateSolidBrush( PControl(fOwnerControl).fColor )\r
  else\r
    SolidBr := CreateSolidBrush( clWhite );\r
  Windows.FrameRect(FHandle, Rect, SolidBr);\r
  DeleteObject( SolidBr );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.LineTo]\r
procedure TCanvas.LineTo(X, Y: Integer);\r
asm\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     HandleValid or PenValid or BrushValid or ChangingCanvas\r
        PUSH     EAX\r
        CALL     RequiredState\r
        PUSH     EAX  //Canvas.fHandle\r
        CALL     Windows.LineTo\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.LineTo(X, Y: Integer);\r
begin\r
  RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );\r
  Windows.LineTo( fHandle, X, Y );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.MoveTo]\r
procedure TCanvas.MoveTo(X, Y: Integer);\r
asm\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     HandleValid\r
        PUSH     EAX\r
        CALL     RequiredState\r
        PUSH     EAX  //Canvas.fHandle\r
        CALL     Windows.MoveToEx\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.MoveTo(X, Y: Integer);\r
begin\r
  RequiredState( HandleValid );\r
  Windows.MoveToEx( fHandle, X, Y, nil );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TCanvas.ObjectChanged]\r
procedure TCanvas.ObjectChanged(Sender: PGraphicTool);\r
begin\r
  DeselectHandles;\r
  //if Assigned( GlobalCanvas_OnObjectChanged ) then\r
  //   GlobalCanvas_OnObjectChanged( Sender );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.Pie]\r
procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;\r
asm\r
        PUSH     HandleValid or PenValid or BrushValid or ChangingCanvas\r
        PUSH     dword ptr [EBP + 8]\r
        CALL     RequiredState\r
\r
        MOV      EDX, EAX\r
\r
        PUSH     ESI\r
        LEA      ESI, [Y4]\r
        STD\r
\r
        XOR      ECX, ECX\r
        MOV      CL, 8\r
@@1:\r
        LODSD\r
        PUSH     EAX\r
\r
        LOOP     @@1\r
\r
        CLD\r
        PUSH     EDX  //Canvas.fHandle\r
        CALL     Windows.Pie\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;\r
begin\r
  RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );\r
  Windows.Pie( fHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{++}(*\r
{$IFDEF F_P}\r
//[Windows API FUNCTIONS ADDITIONAL DECLARATIONS FOR Free Pascal]\r
function Windows_Polygon; external gdi32 name 'Polygon';\r
function Windows_Polyline; external gdi32 name 'Polyline';\r
function FillRect; external user32 name 'FillRect';\r
function OffsetRect; external user32 name 'OffsetRect';\r
function CreateAcceleratorTable; external user32 name 'CreateAcceleratorTableA';\r
function TrackPopupMenu; external user32 name 'TrackPopupMenu';\r
function AdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;\r
  const NewState: TTokenPrivileges; BufferLength: DWORD;\r
  var PreviousState: TTokenPrivileges; var ReturnLength: DWORD): BOOL; external advapi32 name 'AdjustTokenPrivileges';\r
function InflateRect; external user32 name 'InflateRect';\r
{$IFDEF F_P105ORBELOW}\r
function InvalidateRect; external user32 name 'InvalidateRect';\r
function ValidateRect; external user32 name 'ValidateRect';\r
{$ENDIF F_P105ORBELOW}\r
//[END OF Windows API FUNCTIONS ADDITIONAL DECLARATIONS FOR Free Pascal]\r
{$ENDIF}\r
*){--}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.Polygon]\r
procedure TCanvas.Polygon(const Points: array of TPoint);\r
asm\r
        INC      ECX\r
        PUSH     ECX\r
        PUSH     EDX\r
\r
        PUSH     HandleValid or PenValid or BrushValid or ChangingCanvas\r
        PUSH     EAX\r
        CALL     RequiredState\r
\r
        PUSH     EAX\r
        CALL     Windows.Polygon\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.Polygon(const Points: array of TPoint);\r
type\r
  PPoints = ^TPoints;\r
  TPoints = array[0..0] of TPoint;\r
begin\r
  RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );\r
  {$IFDEF F_P} Windows_Polygon\r
  {$ELSE DELPHI} Windows.Polygon\r
  {$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.Polyline]\r
procedure TCanvas.Polyline(const Points: array of TPoint);\r
asm\r
        INC      ECX\r
        PUSH     ECX\r
        PUSH     EDX\r
\r
        PUSH     HandleValid or PenValid or BrushValid or ChangingCanvas\r
        PUSH     EAX\r
        CALL     RequiredState\r
\r
        PUSH     EAX\r
        CALL     Windows.Polyline\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.Polyline(const Points: array of TPoint);\r
type\r
  PPoints = ^TPoints;\r
  TPoints = array[0..0] of TPoint;\r
begin\r
  RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );\r
  {$IFDEF F_P}Windows_Polyline\r
  {$ELSE DELPHI}Windows.Polyline\r
  {$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.Rectangle]\r
procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);\r
asm\r
        PUSH     [Y2]\r
        PUSH     [X2]\r
        PUSH     ECX\r
        PUSH     EDX\r
\r
        PUSH     HandleValid or BrushValid or PenValid or ChangingCanvas\r
        PUSH     EAX\r
        CALL     RequiredState\r
\r
        PUSH     EAX\r
        CALL     Windows.Rectangle\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);\r
begin\r
  RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );\r
  Windows.Rectangle( fHandle, X1, Y1, X2, Y2);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.RoundRect]\r
procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);\r
asm\r
        PUSH     [Y3]\r
        PUSH     [X3]\r
        PUSH     [Y2]\r
        PUSH     [X2]\r
        PUSH     ECX\r
        PUSH     EDX\r
\r
        PUSH     HandleValid or BrushValid or PenValid or ChangingCanvas\r
        PUSH     EAX\r
        CALL     RequiredState\r
\r
        PUSH     EAX\r
        CALL     Windows.RoundRect\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);\r
begin\r
  RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );\r
  Windows.RoundRect( fHandle, X1, Y1, X2, Y2, X3, Y3);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.TextArea]\r
procedure TCanvas.TextArea(const Text: String; var Sz: TSize;\r
  var P0: TPoint);\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        PUSH     ECX\r
        CALL     TextExtent\r
        POP      EDX\r
\r
        MOV      ECX, [P0]\r
        XOR      EAX, EAX\r
        MOV      [ECX].TPoint.x, EAX\r
        MOV      [ECX].TPoint.y, EAX\r
\r
        CMP      [GlobalCanvas_OnTextArea], EAX\r
        JZ       @@exit\r
        MOV      EAX, EBX\r
        CALL     [GlobalCanvas_OnTextArea]\r
\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.TextArea(const Text: String; var Sz: TSize;\r
  var P0: TPoint);\r
begin\r
  Sz := TextExtent( Text );\r
  P0.x := 0; P0.y := 0;\r
  if Assigned( GlobalCanvas_OnTextArea ) then\r
     GlobalCanvas_OnTextArea( @Self, Sz, P0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TCanvas.TextExtent]\r
function TCanvas.TextExtent(const Text: string): TSize;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, EAX\r
\r
        PUSH     ECX               // prepare @Result\r
\r
        MOV      EAX, EDX\r
        CALL     System.@LStrLen\r
        PUSH     EAX               // prepare Length(Text)\r
\r
        CALL     EDX2PChar\r
        PUSH     EDX               // prepare PChar(Text)\r
\r
        PUSH     HandleValid or FontValid\r
        PUSH     EBX\r
        CALL     RequiredState\r
\r
        XCHG     ESI, EAX\r
        TEST     ESI, ESI          // ESI = fHandle before\r
        JNZ      @@1\r
\r
        PUSH     ESI\r
        CALL     CreateCompatibleDC\r
\r
        MOV      EDX, EBX\r
        XCHG     EAX, EDX // EAX := @Self; EDX := DC\r
        CALL     SetHandle\r
@@1:\r
//********************************************************** // Added By M.Gerasimov\r
//*\r
        CMP      [EBX].TCanvas.fIsPaintDC, 1\r
        JZ       @@2\r
        XOR      ESI,ESI\r
@@2:\r
//*\r
//********************************************************** // Added By M.Gerasimov\r
        PUSH     HandleValid or FontValid\r
        PUSH     EBX\r
        CALL     RequiredState\r
        PUSH     EAX               // prepare DC\r
\r
        CALL     Windows.GetTextExtentPoint32\r
\r
        TEST     ESI, ESI\r
        JNZ      @@exit\r
\r
        XOR      EDX, EDX\r
        XCHG     EAX, EBX\r
        CALL     SetHandle\r
\r
@@exit:\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TCanvas.TextExtent(const Text: string): TSize;\r
var DC : HDC;\r
    ClearHandle : Boolean;\r
begin\r
  //Result.cX := 0;\r
  //Result.cY := 0;\r
  ClearHandle := False;\r
  RequiredState( HandleValid or FontValid );\r
  DC := fHandle;\r
  if DC = 0 then\r
  begin\r
     DC := CreateCompatibleDC( 0 );\r
     ClearHandle := True;\r
     SetHandle( DC );\r
  end;\r
//********************************************************** // Added By Gerasimov\r
//*\r
  If Not fIsPaintDC then ClearHandle := True;\r
//*\r
//********************************************************** // Added By Gerasimov\r
  RequiredState( HandleValid or FontValid );\r
  Windows.GetTextExtentPoint32( fHandle, PChar(Text), Length(Text), Result);\r
  if ClearHandle then\r
    SetHandle( 0 );\r
    { DC must be freed here automatically (never leaks):\r
      if Canvas created on base of existing DC, no memDC created,\r
      if Canvas has fHandle:HDC = 0, it is not fIsPaintDC always. }\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TCanvas.TextHeight]\r
function TCanvas.TextHeight(const Text: string): Integer;\r
begin\r
  Result := TextExtent(Text).cY;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.TextOut]\r
procedure TCanvas.TextOut(X, Y: Integer; const Text: String); stdcall;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, [EBP+8]\r
\r
        MOV      EAX, [Text]\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        XCHG     EAX, [ESP]             // prepare Length(Text)\r
\r
        //CALL     System.@LStrToPChar  // string does not need to be null-terminated !\r
        PUSH     EAX                    // prepare PChar(Text)\r
        PUSH     [Y]                    // prepare Y\r
        PUSH     [X]                    // prepare X\r
\r
        PUSH     HandleValid or FontValid or BrushValid or ChangingCanvas\r
        PUSH     EBX\r
        CALL     RequiredState\r
        PUSH     EAX                    // prepare fHandle\r
        CALL     Windows.TextOut\r
\r
        { -- by suggetion of Alexey (Lecha2002)\r
        MOV      EAX, EBX\r
        MOV      EDX, [Text]\r
        CALL     TextWidth\r
        MOV      EDX, [X]\r
        ADD      EDX, EAX\r
\r
        MOV      ECX, [Y]\r
        MOV      EAX, EBX\r
        CALL     MoveTo\r
        }\r
\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.TextOut(X, Y: Integer; const Text: String); stdcall;\r
begin\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  Windows.TextOut(FHandle, X, Y, PChar(Text), Length(Text));\r
  //MoveTo(X + TextWidth(Text), Y); -- by suggestion of Alexey (Lecha2002)\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.TextRect]\r
procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: string);\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
\r
        PUSH     0              // prepare 0\r
\r
        PUSH     EDX\r
        PUSH     ECX\r
\r
        MOV      EAX, [Text]\r
        //CALL     System.@LStrToPChar\r
        PUSH     EAX\r
\r
        //MOV      EAX, [Text]\r
        CALL     System.@LStrLen\r
\r
        POP      ECX            // ECX = @Text[1]\r
\r
        POP      EDX            // EDX = X\r
        XCHG     EAX, [ESP]     // prepare Length(Text), EAX = @Rect\r
        PUSH     ECX            // prepare PChar(Text)\r
        PUSH     EAX            // prepare @Rect\r
\r
        XOR      EAX, EAX\r
        MOV      AL, ETO_CLIPPED // = 4\r
        MOV      ECX, [EBX].fBrush\r
        JECXZ    @@opaque\r
\r
        CMP      [ECX].TGraphicTool.fData.Brush.Style, bsClear\r
        JZ       @@txtout\r
\r
@@opaque:\r
        DB $0C, ETO_OPAQUE //OR       AL, ETO_OPAQUE\r
@@txtout:\r
        PUSH     EAX            // prepare Options\r
        PUSH     [Y]            // prepare Y\r
        PUSH     EDX            // prepare X\r
\r
        PUSH     HandleValid or FontValid or BrushValid or ChangingCanvas\r
        PUSH     EBX\r
        CALL     RequiredState  // EAX = fHandle\r
        PUSH     EAX            // prepare fHandle\r
\r
        CALL     Windows.ExtTextOut\r
\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: string);\r
var\r
  Options: Integer;\r
begin\r
  //Changing;\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  Options := ETO_CLIPPED;\r
  if assigned( fBrush ) and (fBrush.fData.Brush.Style <> bsClear)\r
  or not assigned( fBrush ) then Inc(Options, ETO_OPAQUE);\r
  Windows.ExtTextOut( fHandle, X, Y, Options,\r
                      @Rect, PChar(Text),\r
                      Length(Text), nil);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TCanvas.ExtTextOut]\r
procedure TCanvas.ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: String;\r
          const Spacing: array of Integer );\r
begin\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  Windows.ExtTextOut(FHandle, X, Y, Options, @Rect, PChar(Text), Length(Text), @Spacing[ 0 ]);\r
end;\r
\r
//[procedure TCanvas.DrawText]\r
procedure TCanvas.DrawText(Text:String; var Rect:TRect; Flags:DWord);\r
begin\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  Windows.DrawText(Handle,PChar(Text),Length(Text),Rect,Flags);\r
end;\r
\r
//[function TCanvas.ClipRect]\r
function TCanvas.ClipRect: TRect;\r
begin\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  GetClipBox(Handle, Result);\r
end;\r
\r
//[function TCanvas.TextWidth]\r
function TCanvas.TextWidth(const Text: string): Integer;\r
begin\r
  Result := TextExtent(Text).cX;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TCanvas.GetBrush]\r
function TCanvas.GetBrush: PGraphicTool;\r
asm\r
        MOV      ECX, [EAX].fBrush\r
        INC      ECX\r
        LOOP     @@exit\r
\r
        PUSH     EAX\r
        CALL     NewBrush\r
        POP      EDX\r
        PUSH     EAX\r
\r
        MOV      [EDX].fBrush, EAX\r
\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Code, Offset[TCanvas.ObjectChanged]\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Data, EDX\r
        MOV      ECX, [EDX].fOwnerControl\r
        JECXZ    @@1\r
\r
        PUSH     [ECX].TControl.fBrush\r
        MOV      ECX, [ECX].TControl.fColor\r
        MOV      [EAX].TGraphicTool.fData.Color, ECX\r
        POP      EDX\r
        TEST     EDX, EDX\r
        JZ       @@1\r
\r
        CALL     TGraphicTool.Assign\r
\r
@@1:    POP      ECX\r
\r
@@exit: XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TCanvas.GetBrush: PGraphicTool;\r
begin\r
  if not assigned( fBrush ) then\r
  begin\r
    fBrush := NewBrush;\r
    if assigned( fOwnerControl ) then\r
    begin\r
      fBrush.fData.Color := PControl(fOwnerControl).fColor;\r
      if assigned( PControl(fOwnerControl).fBrush ) then\r
         {fBrush := }fBrush.Assign( PControl(fOwnerControl).fBrush );\r
      // both statements above needed\r
    end;\r
    //fBrush.OnChange := ObjectChanged;\r
    AssignChangeEvents;\r
  end;\r
  Result := fBrush;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TCanvas.GetFont]\r
function TCanvas.GetFont: PGraphicTool;\r
asm\r
        MOV      ECX, [EAX].TCanvas.fFont\r
        INC      ECX\r
        LOOP     @@exit\r
\r
        PUSH     EAX\r
        CALL     NewFont\r
        POP      EDX\r
        PUSH     EAX\r
\r
        MOV      [EDX].TCanvas.fFont, EAX\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Code, Offset[TCanvas.ObjectChanged]\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Data, EDX\r
\r
        MOV      ECX, [EDX].fOwnerControl\r
        JECXZ    @@1\r
\r
        PUSH     [ECX].TControl.fFont\r
        MOV      ECX, [ECX].TControl.fTextColor\r
        MOV      [EAX].TGraphicTool.fData.Color, ECX\r
        POP      EDX\r
        TEST     EDX, EDX\r
        JZ       @@1\r
\r
        CALL     TGraphicTool.Assign\r
\r
@@1:    POP      ECX\r
\r
@@exit: MOV      EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TCanvas.GetFont: PGraphicTool;\r
begin\r
  if not assigned( fFont ) then\r
  begin\r
    fFont := NewFont;\r
    if assigned( fOwnerControl ) then\r
    begin\r
      fFont.Color := PControl(fOwnerControl).fTextColor;\r
      if assigned( PControl(fOwnerControl).fFont ) then\r
        {fFont := }fFont.Assign( PControl(fOwnerControl).fFont );\r
    end;\r
    //fFont.OnChange := ObjectChanged;\r
    AssignChangeEvents;\r
  end;\r
  Result := fFont;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TCanvas.GetPen]\r
function TCanvas.GetPen: PGraphicTool;\r
asm\r
        MOV      ECX, [EAX].TCanvas.fPen\r
        INC      ECX\r
        LOOP     @@exit\r
\r
        PUSH     EAX\r
        CALL     NewPen\r
        POP      EDX\r
        MOV      [EDX].fPen, EAX\r
        PUSH     EAX\r
        MOV      EAX, EDX\r
        CALL     AssignChangeEvents\r
        POP      ECX\r
\r
@@exit: MOV      EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TCanvas.GetPen: PGraphicTool;\r
begin\r
  if not assigned( fPen ) then\r
  begin\r
    fPen := NewPen;\r
    AssignChangeEvents;\r
  end;\r
  Result := fPen;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TCanvas.GetHandle]\r
function TCanvas.GetHandle: HDC;\r
asm\r
        CMP      word ptr[EAX].fOnGetHandle.TMethod.Code+2, 0\r
        MOV      EDX, EAX\r
        MOV      EAX, [EDX].fHandle\r
        JZ       @@exit\r
        MOV      EAX, [EDX].fOnGetHandle.TMethod.Data\r
        PUSH     EDX\r
        CALL     [EDX].fOnGetHandle.TMethod.Code\r
        XCHG     EAX, [ESP]\r
        POP      EDX\r
        PUSH     EDX\r
        CALL     SetHandle\r
        POP      EAX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TCanvas.GetHandle: HDC;\r
begin\r
  if assigned( fOnGetHandle ) then\r
  begin\r
    Result := fOnGetHandle( @Self );\r
    //fHandle := Result;\r
    SetHandle( Result );\r
  end\r
  else\r
    Result := fHandle;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TCanvas.AssignChangeEvents]\r
procedure TCanvas.AssignChangeEvents;\r
asm\r
        PUSH     ESI\r
        LEA      ESI, [EAX].fBrush\r
        MOV      CL, 3\r
        MOV      EDX, EAX\r
@@1:    LODSD\r
        TEST     EAX, EAX\r
        JZ       @@nxt\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Data, EDX\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Code, offset[ ObjectChanged ]\r
@@nxt:  DEC      CL\r
        JNZ      @@1\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TCanvas.AssignChangeEvents;\r
begin\r
  if assigned( fFont ) then\r
     fFont.fOnChange := ObjectChanged;\r
  if assigned( fBrush ) then\r
     fBrush.fOnChange := ObjectChanged;\r
  if assigned( fPen ) then\r
     fPen.fOnChange := ObjectChanged;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[procedure TCanvas.WDrawText]\r
procedure TCanvas.WDrawText(WText: WideString; var Rect: TRect;\r
  Flags: DWord);\r
begin\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  Windows.DrawTextW(Handle,PWideChar(WText),Length(WText),Rect,Flags);\r
end;\r
\r
//[procedure TCanvas.WExtTextOut]\r
procedure TCanvas.WExtTextOut(X, Y: Integer; Options: DWORD;\r
  const Rect: TRect; const WText: WideString;\r
  const Spacing: array of Integer);\r
begin\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  Windows.ExtTextOutW(FHandle, X, Y, Options, @Rect, PWideChar(WText), Length(WText), @Spacing[ 0 ]);\r
end;\r
\r
//[procedure TCanvas.WTextOut]\r
procedure TCanvas.WTextOut(X, Y: Integer; const WText: WideString);\r
begin\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  Windows.TextOutW(FHandle, X, Y, PWideChar(WText), Length(WText));\r
  MoveTo(X + WTextWidth(WText), Y);\r
end;\r
\r
//[procedure TCanvas.WTextRect]\r
procedure TCanvas.WTextRect(const Rect: TRect; X, Y: Integer;\r
  const WText: WideString);\r
var\r
  Options: Integer;\r
begin\r
  //Changing;\r
  RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
  Options := ETO_CLIPPED;\r
  if assigned( fBrush ) and (fBrush.fData.Brush.Style <> bsClear)\r
  or not assigned( fBrush ) then Inc(Options, ETO_OPAQUE);\r
  Windows.ExtTextOutW( fHandle, X, Y, Options,\r
                      @Rect, PWideChar(WText),\r
                      Length(WText), nil);\r
end;\r
\r
//[function TCanvas.WTextExtent]\r
function TCanvas.WTextExtent(const WText: WideString): TSize;\r
var DC : HDC;\r
    ClearHandle : Boolean;\r
begin\r
  ClearHandle := False;\r
  RequiredState( HandleValid or FontValid );\r
  DC := fHandle;\r
  if DC = 0 then\r
  begin\r
     DC := CreateCompatibleDC( 0 );\r
     ClearHandle := True;\r
     SetHandle( DC );\r
  end;\r
  RequiredState( HandleValid or FontValid );\r
  Windows.GetTextExtentPoint32W( fHandle, PWideChar(WText), Length(WText), Result);\r
  if ClearHandle then\r
    SetHandle( 0 );\r
end;\r
\r
//[function TCanvas.WTextHeight]\r
function TCanvas.WTextHeight(const WText: WideString): Integer;\r
begin\r
  Result := WTextExtent( WText ).cy;\r
end;\r
\r
//[function TCanvas.WTextWidth]\r
function TCanvas.WTextWidth(const WText: WideString): Integer;\r
begin\r
  Result := WTextExtent( WText ).cx;\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{-}\r
//[function MakeInt64]\r
function MakeInt64( Lo, Hi: DWORD ): I64;\r
begin\r
  Result.Lo := Lo;\r
  Result.Hi := Hi;\r
end;\r
\r
//[function Int2Int64]\r
function Int2Int64( X: Integer ): I64;\r
asm\r
  MOV  [EDX], EAX\r
  MOV  ECX, EDX\r
  CDQ\r
  MOV  [ECX+4], EDX\r
end;\r
\r
//[procedure IncInt64]\r
procedure IncInt64( var I64: I64; Delta: Integer );\r
asm\r
  ADD  [EAX], EDX\r
  ADC  dword ptr [EAX+4], 0\r
end;\r
\r
//[procedure DecInt64]\r
procedure DecInt64( var I64: I64; Delta: Integer );\r
asm\r
  SUB  [EAX], EDX\r
  SBB  dword ptr [EDX], 0\r
end;\r
\r
//[function Add64]\r
function Add64( const X, Y: I64 ): I64;\r
asm\r
  PUSH  ESI\r
  XCHG  ESI, EAX\r
  LODSD\r
  ADD   EAX, [EDX]\r
  MOV   [ECX], EAX\r
  LODSD\r
  ADC   EAX, [EDX+4]\r
  MOV   [ECX+4], EAX\r
  POP   ESI\r
end;\r
\r
//[function Sub64]\r
function Sub64( const X, Y: I64 ): I64;\r
asm\r
  PUSH  ESI\r
  XCHG  ESI, EAX\r
  LODSD\r
  SUB   EAX, [EDX]\r
  MOV   [ECX], EAX\r
  LODSD\r
  SBB   EAX, [EDX+4]\r
  MOV   [ECX+4], EAX\r
  POP   ESI\r
end;\r
\r
//[function Neg64]\r
function Neg64( const X: I64 ): I64;\r
asm\r
  MOV  ECX, [EAX]\r
  NEG  ECX\r
  MOV  [EDX], ECX\r
  MOV  ECX, 0\r
  SBB  ECX, [EAX+4]\r
  MOV  [EDX+4], ECX\r
end;\r
\r
//[function Mul64EDX]\r
function Mul64EDX( const X: I64; M: Integer ): I64;\r
asm\r
  PUSH  ESI\r
  PUSH  EDI\r
  XCHG  ESI, EAX\r
  MOV   EDI, ECX\r
  MOV   ECX, EDX\r
  LODSD\r
  MUL   ECX\r
  STOSD\r
  XCHG  EDX, ECX\r
  LODSD\r
  MUL  EDX\r
  ADD   EAX, ECX\r
  STOSD\r
  POP   EDI\r
  POP   ESI\r
end;\r
\r
//[FUNCTION Mul64i]\r
{$IFDEF ASM_VERSION}\r
function Mul64i( const X: I64; Mul: Integer ): I64;\r
asm     //cmd    //opd\r
        TEST     EDX, EDX\r
        PUSHFD\r
        JGE      @@1\r
        NEG      EDX\r
@@1:    PUSH     ECX\r
        CALL     Mul64EDX\r
        POP      EAX\r
        POPFD\r
        JGE      @@2\r
        MOV      EDX, EAX\r
        CALL     Neg64\r
@@2:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Mul64i( const X: I64; Mul: Integer ): I64;\r
var Minus: Boolean;\r
begin\r
  Minus := FALSE;\r
  if Mul < 0 then\r
  begin\r
    Minus := TRUE;\r
    Mul := -Mul;\r
  end;\r
  Result := Mul64EDX( X, Mul );\r
  if Minus then\r
    Result := Neg64( Result );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Mul64i]\r
\r
//[function Div64EDX]\r
function Div64EDX( const X: I64; D: Integer ): I64;\r
asm\r
  PUSH  ESI\r
  PUSH  EDI\r
  XCHG  ESI, EAX\r
  MOV   EDI, ECX\r
  MOV   ECX, EDX\r
  MOV   EAX, [ESI+4]\r
  CDQ\r
  DIV  ECX\r
  MOV   [EDI+4], EAX\r
  LODSD\r
  DIV  ECX\r
  STOSD\r
  POP   EDI\r
  POP   ESI\r
end;\r
\r
//[FUNCTION Div64i]\r
{$IFDEF ASM_VERSION}\r
function Div64i( const X: I64; D: Integer ): I64;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        XOR      EBX, EBX\r
        PUSH     ESI\r
        XCHG     ESI, EAX\r
        LODSD\r
        MOV      [ECX], EAX\r
        LODSD\r
        MOV      [ECX+4], EAX\r
        MOV      ESI, ECX\r
        PUSH     EDX\r
        XCHG     EAX, ECX\r
        CALL     Sgn64\r
        TEST     EAX, EAX\r
        JGE      @@1\r
        INC      EBX\r
        MOV      EAX, ESI\r
        MOV      EDX, ESI\r
        CALL     Neg64\r
@@1:    POP      EDX\r
        TEST     EDX, EDX\r
        JGE      @@2\r
        XOR      EBX, 1\r
        NEG      EDX\r
@@2:    MOV      EAX, ESI\r
        MOV      ECX, ESI\r
        CALL     Div64EDX\r
        DEC      EBX\r
        JNZ      @@3\r
        MOV      EDX, ESI\r
        XCHG     EAX, ESI\r
        CALL     Neg64\r
@@3:    POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Div64i( const X: I64; D: Integer ): I64;\r
var Minus: Boolean;\r
begin\r
  Minus := FALSE;\r
  if D < 0 then\r
  begin\r
    D := -D;\r
    Minus := TRUE;\r
  end;\r
  Result := X;\r
  if Sgn64( Result ) < 0 then\r
  begin\r
    Result := Neg64( Result );\r
    Minus := not Minus;\r
  end;\r
  Result := Div64EDX( Result, D );\r
  if Minus then\r
    Result := Neg64( Result );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Div64i]\r
\r
//[function Mod64i]\r
function Mod64i( const X: I64; D: Integer ): Integer;\r
begin\r
  Result := Sub64( X, Mul64i( Div64i( X, D ), D ) ).Lo;\r
end;\r
\r
//[function Sgn64]\r
function Sgn64( const X: I64 ): Integer;\r
asm\r
  XOR  EDX, EDX\r
  CMP  [EAX+4], EDX\r
  XCHG EAX, EDX\r
  JG   @@ret_1\r
  JL   @@ret_neg\r
  CMP  [EDX], EAX\r
  JZ   @@exit\r
@@ret_1:\r
  INC  EAX\r
  RET\r
@@ret_neg:\r
  DEC  EAX\r
@@exit:\r
end;\r
\r
//[function Cmp64]\r
function Cmp64( const X, Y: I64 ): Integer;\r
begin\r
  Result := Sgn64( Sub64( X, Y ) );\r
end;\r
\r
//[function Int64_2Str]\r
function Int64_2Str( X: I64 ): String;\r
var M: Boolean;\r
    Y: Integer;\r
    Buf: array[ 0..31 ] of Char;\r
    I: Integer;\r
begin\r
  M := FALSE;\r
  case Sgn64( X ) of\r
  -1: begin M := TRUE; X := Neg64( X ); end;\r
  0:  begin Result := '0'; Exit; end;\r
  end;\r
  I := 31;\r
  Buf[ 31 ] := #0;\r
  while Sgn64( X ) > 0 do\r
  begin\r
    Dec( I );\r
    Y := Mod64i( X, 10 );\r
    Buf[ I ] := Char( Y + Integer( '0' ) );\r
    X := Div64i( X, 10 );\r
  end;\r
  if M then\r
  begin\r
    Dec( I );\r
    Buf[ I ] := '-';\r
  end;\r
  Result := PChar( @Buf[ I ] );\r
end;\r
\r
//[function Str2Int64]\r
function Str2Int64( const S: String ): I64;\r
var I: Integer;\r
    M: Boolean;\r
begin\r
  Result.Lo := 0;\r
  Result.Hi := 0;\r
  I := 1;\r
  if S = '' then Exit;\r
  M := FALSE;\r
  if S[ 1 ] = '-' then\r
  begin\r
    M := TRUE;\r
    Inc( I );\r
  end\r
    else\r
  if S[ 1 ] = '+' then\r
    Inc( I );\r
  while I <= Length( S ) do\r
  begin\r
    if not( S[ I ] in [ '0'..'9' ] ) then\r
      break;\r
    Result := Mul64i( Result, 10 );\r
    IncInt64( Result, Integer( S[ I ] ) - Integer( '0' ) );\r
    Inc( I );\r
  end;\r
  if M then\r
    Result := Neg64( Result );\r
end;\r
\r
//[function Int64_2Double]\r
function Int64_2Double( const X: I64 ): Double;\r
asm\r
  FILD qword ptr [EAX]\r
  FSTP @Result\r
end;\r
\r
//[function Double2Int64]\r
function Double2Int64( D: Double ): I64;\r
asm\r
  FLD   D\r
  FISTP qword ptr [EAX]\r
end;\r
\r
{+}\r
function IsNan(const AValue: Double): Boolean;\r
{$IFDEF _D2orD3}\r
type PI64 = ^I64;\r
{$ENDIF}\r
begin\r
  {-}\r
  Result := (PI64(@AValue).Hi and $7FF00000 = $7FF00000) and\r
            ((PI64(@AValue).Hi and $000FFFFF <> 0) or (PI64(@AValue).Lo <> 0));\r
  {+}{++}(*Result := AValue = NAN;*){--}\r
end;\r
\r
//[function IntPower]\r
function IntPower(Base: Extended; Exponent: Integer): Extended;\r
{$IFDEF F_P}\r
begin\r
  if Exponent = 0 then\r
  begin\r
    Result := 1.0;\r
    Exit;\r
  end;\r
  if Exponent < 0 then\r
  begin\r
    Exponent := -Exponent;\r
    Base := 1.0 / Base;\r
  end;\r
  Result := Base;\r
  REPEAT\r
    Result := Result * Base;\r
    Dec( Exponent );\r
  UNTIL Exponent <= 0;\r
end;\r
{$ELSE DELPHI}\r
// This version of code by Galkov:\r
// Changes in comparison to Delphi standard:\r
// no Overflow exception if Exponent is very big negative value\r
// (just 0 in result in such case).\r
asm\r
        fld1             { Result := 1 }\r
        test    eax,eax  // check Exponent for 0, return 0 ** 0 = 1\r
        jz      @@3      // (though Mathematics says that this is not so...)\r
        fld     Base\r
        jg      @@2\r
        fdivr   ST,ST(1) { Base := 1 / Base }\r
        neg     eax\r
        jmp     @@2\r
@@1:    fmul    ST,ST    { X := Base * Base }\r
@@2:    shr     eax,1\r
        jnc     @@1\r
        fmul    ST(1),ST { Result := Result * X }\r
        jnz     @@1\r
        fstp    st       { pop X from FPU stack }\r
@@3:    fwait\r
end;\r
(* version of code by Borland:\r
asm\r
        mov     ecx, eax\r
        cdq\r
        fld1                      { Result := 1 }\r
        xor     eax, edx\r
        sub     eax, edx          { eax := Abs(Exponent) }\r
        jz      @@3\r
        fld     Base\r
        jmp     @@2\r
@@1:    fmul    ST, ST            { X := Base * Base }\r
@@2:    shr     eax,1\r
        jnc     @@1\r
        fmul    ST(1),ST          { Result := Result * X }\r
        jnz     @@1\r
        fstp    st                { pop X from FPU stack }\r
        cmp     ecx, 0\r
        jge     @@3\r
        fld1\r
        fdivrp                    { Result := 1 / Result }\r
@@3:\r
        fwait\r
end;*)\r
{$ENDIF F_P/DELPHI}\r
\r
//[function Str2Double]\r
function Str2Double( const S: String ): Double;\r
var I: Integer;\r
    M, Pt: Boolean;\r
    D: Double;\r
    Ex: Integer;\r
begin\r
  Result := 0.0;\r
  if S = '' then Exit;\r
  M := FALSE;\r
  I := 1;\r
  if S[ 1 ] = '-' then\r
  begin\r
    M := TRUE;\r
    Inc( I );\r
  end;\r
  Pt := FALSE;\r
  D := 1.0;\r
  while I <= Length( S ) do\r
  begin\r
    case S[ I ] of\r
    '.': if not Pt then Pt := TRUE else break;\r
    '0'..'9': if not Pt then\r
                 Result := Result * 10.0 + Integer( S[ I ] ) - Integer( '0' )\r
              else\r
              begin\r
                D := D * 0.1;\r
                Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D;\r
              end;\r
    'e', 'E': begin\r
                Ex := Str2Int( CopyEnd( S, I + 1 ) );\r
                Result := Result * IntPower( 10.0, Ex );\r
                break;\r
              end;\r
    end;\r
    Inc( I );\r
  end;\r
  if M then\r
    Result := -Result;\r
end;\r
\r
//[function TruncD]\r
function TruncD( D: Double ): Double;\r
{-}\r
asm\r
  FLD    D\r
  PUSH   ECX\r
  FNSTCW [ESP]\r
  POP    ECX\r
  PUSH   ECX\r
  OR     byte ptr [ESP+1], $0C\r
  FLDCW  [ESP]\r
  PUSH   ECX\r
  FRNDINT\r
  FSTP   @Result\r
  FLDCW  [ESP]\r
  POP    ECX\r
  POP    ECX\r
end;\r
{+}{++}(*\r
begin\r
  Result := Trunc( D );\r
end;\r
*){--}\r
\r
// Precision 15\r
//[function Extended2Str]\r
function Extended2Str( E: Extended ): String;\r
    function UnpackFromBuf( const Buf: array of Byte; N: Integer ): String;\r
    var I, J, K, L: Integer;\r
    begin\r
      SetLength( Result, 16 );\r
      J := 1;\r
      for I := 7 downto 0 do\r
      begin\r
        K := Buf[ I ] shr 4;\r
        Result[ J ] := Char( Ord('0') + K );\r
        Inc( J );\r
        K := Buf[ I ] and $F;\r
        Result[ J ] := Char( Ord('0') + K );\r
        Inc( J );\r
      end;\r
\r
      Assert( Result[ 1 ] = '0', 'error!' );\r
      Delete( Result, 1, 1 );\r
\r
      if N <= 0 then\r
      begin\r
        while N < 0 do\r
        begin\r
          Result := '0' + Result;\r
          Inc( N );\r
        end;\r
        Result := '0.' + Result;\r
      end\r
        else\r
      if N < Length( Result ) then\r
      begin\r
        Result := Copy( Result, 1, N ) + '.' + CopyEnd( Result, N + 1 );\r
      end\r
        else\r
      begin\r
        while N > Length( Result ) do\r
        begin\r
          Result := Result + '0';\r
        end;\r
        Exit;\r
      end;\r
\r
      L := Length( Result );\r
      while L > 1 do\r
      begin\r
        if not (Result[ L ] in ['0','.']) then break;\r
        Dec( L );\r
        if Result[ L + 1 ] = '.' then break;\r
      end;\r
      if L < Length( Result ) then Delete( Result, L + 1, MaxInt );\r
\r
    end;\r
\r
var\r
  S: Boolean;\r
var F: Extended;\r
    N: Integer;\r
    Buf1: array[ 0..9 ] of Byte;\r
    I10: Integer;\r
begin\r
  Result := '0';\r
  if E = 0 then Exit;\r
  S := E < 0;\r
  if S then E := -E;\r
\r
  N := 15;\r
  F := 5E12;\r
  I10 := 10;\r
  while E < F do\r
  begin\r
    Dec( N );\r
    E := E * I10;\r
  end;\r
  if N = 15 then\r
  while E >= 1E13 do\r
  begin\r
    Inc( N );\r
    E := E / I10;\r
  end;\r
\r
  while TRUE do\r
  begin\r
    asm\r
      FLD    [E]\r
      FBSTP  [Buf1]\r
    end;\r
    if Buf1[ 7 ] <> 0 then break;\r
    E := E * I10;\r
    Dec( N );\r
  end;\r
\r
  Result := UnpackFromBuf( Buf1, N );\r
\r
  if S then Result := '-' + Result;\r
end;\r
\r
//[function Double2Str]\r
function Double2Str( D: Double ): String;\r
begin\r
  Result := Extended2Str( D );\r
end;\r
\r
//[function Double2StrEx]\r
function Double2StrEx( D: Double ): String;\r
var E, E1, E2: Double;\r
    S: String;\r
begin\r
  Result := Double2Str( D );\r
  E := Str2Double( Result );\r
  E1 := E - D;\r
  if E1 < 0.0 then E1 := -E1;\r
  if E1 < 1e-307 then Exit;\r
  while TRUE do\r
  begin\r
    E := D - (E - D) * 0.3;\r
    S := Double2Str( E );\r
    if S = Result then break;\r
    E := Str2Double( S );\r
    E2 := E - D;\r
    if E2 < 0.0 then E2 := -E2;\r
    if E2 > E1 * 0.75 then break;\r
    Result := S;\r
    if E2 < E1 * 0.1 then break;\r
  end;\r
end;\r
\r
//[function GetBits]\r
function GetBits( N: DWORD; first, last: Byte ): DWord;\r
{$IFDEF F_P}\r
begin\r
  Result := 0;\r
  if last > 31 then last := 31;\r
  if first > last then Exit;\r
  Result := (N and not ($FFFFFFFF shl last)) shr first;\r
end;\r
{$ELSE DELPHI}\r
asm\r
   XCHG EAX, EDX  // (1) EDX=N, AL=first\r
   {$IFDEF PARANOIA}\r
   DB $3C, 31\r
   {$ELSE}\r
   CMP AL, 31 // first(AL) > 31 ?\r
   {$ENDIF}\r
   JBE  @@1       // (2) åñëè äà, òî Result := 0;\r
@@0:\r
   XOR  EAX, EAX  // (2)\r
   RET            // (1)\r
@@1:\r
\r
   XCHG EAX, ECX  // (1) AL = last CL = first\r
   SHR  EDX, CL   // (2) EDX = N shr first\r
   SUB  AL,  CL   // (2) AL = last - first\r
   JL @@0         // (2) åñëè last < first òî Result := 0;\r
\r
   {$IFDEF PARANOIA}\r
   DB $3C, 32\r
   {$ELSE}\r
   CMP AL, 32     // (2) last - first >= 32 ?\r
   {$ENDIF}\r
   XCHG ECX, EAX  // (1) CL = last - first\r
   XCHG EAX, EDX  // (1) EAX = N shr first\r
   JAE  @@exit    // (2) åñëè last - first > 31, òî Result := EAX;\r
   SBB  EDX, EDX  // (2) EDX = -1\r
   DEC  EDX       // (1) EDX = 1111...10 = -2\r
   SHL  EDX, CL   // (2) EDX = 111...100..0 (ãäå n(0)=last-first+1)\r
   NOT  EDX       // (2) EDX = ìàñêà 000..0111...1 (ãäå n(1)=last-first+1)\r
   AND  EAX, EDX  // (2)\r
@@exit:\r
   // EAX = ðåçóëüòàò, (1 áàéò íà êîìàíäó RET)\r
end;\r
{$ENDIF F_P/DELPHI}\r
\r
//[function GetBitsL]\r
function GetBitsL( N: DWORD; from, len: Byte ): DWord;\r
{$IFDEF F_P}\r
begin\r
  Result := GetBits( N, from, from + len - 1 );\r
end;\r
{$ELSE DELPHI}\r
asm\r
   ADD  CL, DL\r
   DEC  CL\r
   JMP  GetBits\r
end;\r
{$ENDIF F_P/DELPHI}\r
\r
//[FUNCTION Int2Hex]\r
{$IFDEF ASM_VERSION}\r
function Int2Hex( Value : DWord; Digits : Integer ) : String;\r
asm\r
\r
        // EAX = Value\r
        // EDX = Digits (actually DL needed)\r
        // ECX = @Result\r
\r
        PUSH      0\r
        ADD       ESP, -0Ch\r
\r
        PUSH      EBX\r
        PUSH      ECX\r
\r
        LEA       EBX, [ESP+8+0Fh]  // EBX := @Buf[ 15 ]\r
        AND       EDX, $F\r
\r
@@loop: DEC       EBX\r
        DEC       EDX\r
\r
        PUSH      EAX\r
        {$IFDEF PARANOIA}\r
        DB $24, $0F\r
        {$ELSE}\r
        AND       AL, 0Fh\r
        {$ENDIF}\r
        {$IFDEF PARANOIA}\r
        DB $3C, 9\r
        {$ELSE}\r
        CMP       AL, 9\r
        {$ENDIF}\r
        JA        @@10\r
        {$IFDEF PARANOIA}\r
        DB $04, 30h-41h+0Ah\r
        {$ELSE}\r
        ADD       AL,30h-41h+0Ah\r
        {$ENDIF}\r
@@10:\r
        {$IFDEF PARANOIA}\r
        DB $04, 41h-0Ah\r
        {$ELSE}\r
        ADD       AL,41h-0Ah\r
        {$ENDIF}\r
        MOV       byte ptr [EBX], AL\r
        POP       EAX\r
        SHR       EAX, 4\r
\r
        JNZ       @@loop\r
\r
        TEST      EDX, EDX\r
        JG        @@loop\r
\r
        POP       EAX      // EAX = @Result\r
        MOV       EDX, EBX // EDX = @resulting string\r
        CALL      System.@LStrFromPChar\r
\r
        POP       EBX\r
        ADD       ESP, 10h\r
\r
{== by KSer - to test it only.\r
function Int2Hex( Value : DWord; Digits : Integer ) : shortString;\r
asm\r
        MOV       [ECX], DL\r
        XADD      EDX, ECX\r
@@loop1:\r
        PUSH      EAX\r
        db   $24, $0F    // and  al,$0F\r
        AAM\r
        //AAD\r
        DB $D5, $11\r
        db   $04, $30    // add  al,$30\r
        MOV       [EDX], AL\r
        POP       EAX\r
        SHR       EAX, 4\r
        DEC       EDX\r
        LOOP      @@loop1\r
}\r
end;\r
{$ELSE ASM_VERSION} //Pascal (mixed)\r
function Int2Hex( Value : DWord; Digits : Integer ) : String;\r
var Buf: array[ 0..8 ] of Char;\r
    Dest : PChar;\r
\r
    function HexDigit( B : Byte ) : Char;\r
    {$IFDEF F_P}\r
    const\r
      HexDigitChr: array[ 0..15 ] of Char = ( '0','1','2','3','4','5','6','7',\r
                                              '8','9','A','B','C','D','E','F' );\r
    begin\r
      Result := HexDigitChr[ B and $F ];\r
    end;\r
    {$ELSE DELPHI}\r
    asm\r
            {$IFDEF PARANOIA}\r
             DB $3C,9\r
             {$ELSE}\r
             CMP  AL,9\r
             {$ENDIF}\r
             JA   @@1\r
             {$IFDEF PARANOIA}\r
             DB $04, $30-$41+$0A\r
             {$ELSE}\r
             ADD  AL,30h-41h+0Ah\r
             {$ENDIF}\r
    @@1:\r
             {$IFDEF PARANOIA}\r
             DB $04, $41-$0A\r
             {$ELSE}\r
             ADD  AL,41h-0Ah\r
             {$ENDIF}\r
    end;\r
    {$ENDIF F_P/DELPHI}\r
begin\r
  Dest := @Buf[ 8 ];\r
  Dest^ := #0;\r
  repeat\r
    Dec( Dest );\r
    Dest^ := '0';\r
    if Value <> 0 then\r
    begin\r
      Dest^ := HexDigit( Value and $F );\r
      Value := Value shr 4;\r
    end;\r
    Dec( Digits );\r
  until (Value = 0) and (Digits <= 0);\r
  Result := Dest;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Int2Hex]\r
\r
//[FUNCTION Hex2Int]\r
{$IFDEF ASM_VERSION}\r
function Hex2Int( const Value : String) : Integer;\r
asm\r
        CALL     EAX2PChar\r
        PUSH     ESI\r
        XCHG     ESI, EAX\r
        XOR      EDX, EDX\r
        TEST     ESI, ESI\r
        JE       @@exit\r
        LODSB\r
        {$IFDEF PARANOIA}\r
        DB $3C, '$'\r
        {$ELSE}\r
        CMP      AL, '$'\r
        {$ENDIF}\r
        JNE      @@1\r
@@0:    LODSB\r
@@1:    TEST     AL, AL\r
        JE       @@exit\r
        {$IFDEF PARANOIA}\r
        DB $2C, '0'\r
        {$ELSE}\r
        SUB      AL, '0'\r
        {$ENDIF}\r
        {$IFDEF PARANOIA}\r
        DB $3C, 9\r
        {$ELSE}\r
        CMP      AL, '9' - '0'\r
        {$ENDIF}\r
        JBE      @@3\r
\r
        {$IFDEF PARANOIA}\r
        DB $2C, $11\r
        {$ELSE}\r
        SUB      AL, 'A' - '0'\r
        {$ENDIF}\r
        {$IFDEF PARANOIA}\r
        DB $3C, 5\r
        {$ELSE}\r
        CMP      AL, 'F' - 'A'\r
        {$ENDIF}\r
        JBE      @@2\r
\r
        {$IFDEF PARANOIA}\r
        DB $2C, 32\r
        {$ELSE}\r
        SUB      AL, 32\r
        {$ENDIF}\r
        {$IFDEF PARANOIA}\r
        DB $3C, 5\r
        {$ELSE}\r
        CMP      AL, 'F' - 'A'\r
        {$ENDIF}\r
        JA       @@exit\r
@@2:\r
        {$IFDEF PARANOIA}\r
        DB $04, 0Ah\r
        {$ELSE}\r
        ADD      AL, 0Ah\r
        {$ENDIF}\r
@@3:\r
        SHL      EDX, 4\r
        ADD      DL, AL\r
        JMP      @@0\r
\r
@@exit: XCHG     EAX, EDX\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Hex2Int( const Value : String) : Integer;\r
var I : Integer;\r
begin\r
  Result := 0;\r
  I := 1;\r
  if Value = '' then Exit;\r
  if Value[ 1 ] = '$' then Inc( I );\r
  while I <= Length( Value ) do\r
  begin\r
    if Value[ I ] in [ '0'..'9' ] then\r
       Result := (Result shl 4) or (Ord(Value[I]) - Ord('0'))\r
    else\r
    if Value[ I ] in [ 'A'..'F' ] then\r
       Result := (Result shl 4) or (Ord(Value[I]) - Ord('A') + 10)\r
    else\r
    if Value[ I ] in [ 'a'..'f' ] then\r
       Result := (Result shl 4) or (Ord(Value[I]) - Ord('a') + 10)\r
    else\r
      break;\r
    Inc( I );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Hex2Int]\r
\r
//[FUNCTION Octal2Int]\r
function Octal2Int( const Value: String ) : Integer;\r
var I: Integer;\r
begin\r
  Result := 0;\r
  for I := 1 to Length( Value ) do\r
  begin\r
    if Value[ I ] in [ '0'..'7' ] then\r
      Result := Result * 8 + Ord( Value[ I ] ) - Ord( '0' )\r
    else break;\r
  end;\r
end;\r
//[END Octal2Int]\r
\r
//[FUNCTION Binary2Int]\r
function Binary2Int( const Value: String ) : Integer;\r
var I: Integer;\r
begin\r
  Result := 0;\r
  for I := 1 to Length( Value ) do\r
  begin\r
    if Value[ I ] in [ '0'..'1' ] then\r
      Result := Result * 2 + Ord( Value[ I ] ) - Ord( '0' )\r
    else break;\r
  end;\r
end;\r
//[END Binary2Int]\r
\r
//[FUNCTION cHex2Int]\r
{$IFDEF ASM_VERSION}\r
function cHex2Int( const Value : String) : Integer;\r
asm\r
     TEST  EAX, EAX\r
     JZ    @@exit\r
     CMP   word ptr [EAX], '0x'\r
     JZ    @@skip_2_chars\r
     CMP   word ptr [EAX], '0X'\r
     JNZ   @@2Hex2Int\r
@@skip_2_chars:\r
     INC   EAX\r
     INC   EAX\r
@@2Hex2Int:\r
     JMP   Hex2Int\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION}\r
function cHex2Int( const Value : String) : Integer;\r
begin\r
  if StrEq( Copy( Value, 1, 2 ), '0x' ) then\r
    Result := Hex2Int( CopyEnd( Value, 3 ) )\r
  else Result := Hex2Int( Value );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END cHex2Int]\r
\r
//[FUNCTION Int2Str]\r
{$IFDEF ASM_VERSION}\r
function Int2Str( Value : Integer ) : String;\r
asm\r
        XOR       ECX, ECX\r
        PUSH      ECX\r
        ADD       ESP, -0Ch\r
\r
        PUSH      EBX\r
        LEA       EBX, [ESP + 15 + 4]\r
        PUSH      EDX\r
        CMP       EAX, ECX\r
        PUSHFD\r
        JGE       @@1\r
        NEG       EAX\r
@@1:\r
        MOV       CL, 10\r
\r
@@2:\r
        DEC       EBX\r
        XOR       EDX, EDX\r
        DIV       ECX\r
        ADD       DL, 30h\r
        MOV       [EBX], DL\r
        TEST      EAX, EAX\r
        JNZ       @@2\r
\r
        POPFD\r
        JGE       @@3\r
\r
        DEC       EBX\r
        MOV       byte ptr [EBX], '-'\r
@@3:\r
        POP       EAX\r
        MOV       EDX, EBX\r
        CALL      System.@LStrFromPChar\r
\r
        POP       EBX\r
        ADD       ESP, 10h\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Int2Str( Value : Integer ) : String;\r
var Buf : array[ 0..15 ] of Char;\r
    Dst : PChar;\r
    Minus : Boolean;\r
    D: DWORD;\r
begin\r
  Dst := @Buf[ 15 ];\r
  Dst^ := #0;\r
  Minus := False;\r
  if Value < 0 then\r
  begin\r
    Value := -Value;\r
    Minus := True;\r
  end;\r
  D := Value;\r
  repeat\r
    Dec( Dst );\r
    Dst^ := Char( (D mod 10) + Byte( '0' ) );\r
    D := D div 10;\r
  until D = 0;\r
  if Minus then\r
  begin\r
    Dec( Dst );\r
    Dst^ := '-';\r
  end;\r
  Result := Dst;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Int2Str]\r
\r
//[function UInt2Str]\r
function UInt2Str( Value: DWORD ): String;\r
var Buf : array[ 0..15 ] of Char;\r
    Dst : PChar;\r
    D: DWORD;\r
begin\r
  Dst := @Buf[ 15 ];\r
  Dst^ := #0;\r
  D := Value;\r
  repeat\r
    Dec( Dst );\r
    Dst^ := Char( (D mod 10) + Byte( '0' ) );\r
    D := D div 10;\r
  until D = 0;\r
  Result := Dst;\r
end;\r
\r
//[function Int2StrEx]\r
function Int2StrEx( Value, MinWidth: Integer ): String;\r
begin\r
  Result := Int2Str( Value );\r
  while Length( Result ) < MinWidth do\r
    Result := ' ' + Result;\r
end;\r
\r
//[function Int2Rome]\r
function Int2Rome( Value: Integer ): String;\r
const RomeDigs: String = 'IVXLCDMT';\r
  function RomeNum( N, FromIdx: Integer ): String;\r
  begin\r
    CASE N OF\r
    1, 2, 3:    Result := StrRepeat( RomeDigs[ FromIdx ], N );\r
    4:          Result := RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 1 ];\r
    5, 6, 7, 8: Result := RomeDigs[ FromIdx + 1 ] + StrRepeat( RomeDigs[ FromIdx ],\r
                       N - 5 );\r
    9:          Result := RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 2 ]\r
    else Result := '';\r
    END;\r
  end;\r
var I, J: Integer;\r
begin\r
  Result := '';\r
  if Value < 1 then Exit;\r
  if Value > 8999 then Exit;\r
  // maximum possible is TMMMCMXCIX, i.e. 8999\r
  J := 1;\r
  for I := 1 to 3 do\r
  begin\r
    Result := RomeNum( Value mod 10, J ) + Result;\r
    Value := Value div 10;\r
    if Value = 0 then Exit;\r
    Inc( J, 2 );\r
  end;\r
end;\r
\r
//[FUNCTION Int2Ths]\r
{$IFDEF ASM_VERSION}\r
function Int2Ths( I : Integer ) : String;\r
asm\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
        PUSH     EAX\r
        PUSH     EDX\r
        CALL     Int2Str\r
        POP      EDX\r
        POP      EAX\r
        CMP      EAX, 1000\r
        JL       @@Exit\r
        PUSH     EDX\r
        MOV      EAX, [EDX]\r
        PUSH     EAX\r
        CALL     System.@LStrLen         // EAX = Length(Result)\r
        POP      EDX\r
        PUSH     EDX                     // EDX = @Result[ 1 ]\r
        XOR      ECX, ECX\r
\r
@@1:\r
        ROL      ECX, 8\r
        DEC      EAX\r
        MOV      CL, [EDX+EAX]\r
        JZ       @@fin\r
        CMP      ECX, 300000h\r
        JL       @@1\r
\r
        PUSH     ECX\r
        XOR      ECX, ECX\r
        MOV      CL, ','\r
        JMP      @@1\r
\r
@@fin:  CMP      CX, ',-'\r
        JNE      @@fin1\r
        MOV      CH, 0                   // this corrects -,ddd,...\r
@@fin1: CMP      ECX, 01000000h\r
        JGE      @@fin2\r
        INC      EAX\r
        ROL      ECX, 8\r
        JMP      @@fin1\r
@@fin2: PUSH     ECX\r
\r
        LEA      EDX, [ESP+EAX]\r
        MOV      EAX, [EBP-4]\r
        CALL     System.@LStrFromPChar\r
@@Exit:\r
        MOV      ESP, EBP\r
        POP      EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Int2Ths( I : Integer ) : String;\r
var S : String;\r
begin\r
  S := Int2Str( I );\r
  Result := '';\r
  while S <> '' do\r
  begin\r
    if Result <> '' then\r
       Result := ',' + Result;\r
    Result := CopyTail( S, 3 ) + Result;\r
    S := Copy( S, 1, Length( S ) - 3 );\r
  end;\r
  if Copy( Result, 1, 2 ) = '-,' then\r
     Result := '-' + CopyEnd( Result, 3 );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Int2Ths]\r
\r
//[FUNCTION Int2Digs]\r
{$IFDEF ASM_VERSION}\r
function Int2Digs( Value, Digits : Integer ) : String;\r
asm\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
        PUSH     EDX             // [EBP-4] = Digits\r
        PUSH     ECX\r
        MOV      EDX, ECX\r
        CALL     Int2Str\r
        POP      ECX\r
        PUSH     ECX             // [EBP-8] = @Result\r
        MOV      EAX, [ECX]\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        POP      EDX             // EDX = @Result[1]\r
        MOV      ECX, EAX        // ECX = Length( Result )\r
        ADD      EAX, EAX\r
        SUB      ESP, EAX\r
        MOV      EAX, ESP\r
        PUSHAD\r
        CALL     StrCopy\r
        POPAD\r
        MOV      EDX, EAX\r
        ADD      ESP, -100\r
        CMP      byte ptr [EDX], '-'\r
        PUSHFD\r
        JNE      @@1\r
        INC      EDX\r
@@1:\r
        MOV      EAX, [EBP-4]    // EAX = Digits\r
        CMP      ECX, EAX\r
        JGE      @@2\r
        DEC      EDX\r
        MOV      byte ptr [EDX], '0'\r
        INC      ECX\r
        JMP      @@1\r
@@2:\r
        POPFD\r
        JNE      @@3\r
        DEC      EDX\r
        MOV      byte ptr [EDX], '-'\r
@@3:\r
        MOV      EAX, [EBP-8]\r
        CALL     System.@LStrFromPChar\r
        MOV      ESP, EBP\r
        POP      EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Int2Digs( Value, Digits : Integer ) : String;\r
var M : String;\r
begin\r
  Result := Int2Str( Value );\r
  M := '';\r
  if Value < 0 then\r
  begin\r
    M := '-';\r
    Result := CopyEnd( Result, 2 );\r
  end;\r
  if Digits >= 0 then\r
    while Length( M + Result ) < Digits do\r
          Result := '0' + Result\r
  else\r
    while Length( Result ) < -Digits do\r
          Result := '0' + Result;\r
  Result := M + Result;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Int2Digs]\r
\r
//[FUNCTION Num2Bytes]\r
{$IFDEF ASM_VERSION}\r
function Num2Bytes( Value : Double ) : String;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        MOV      EBX, ESP\r
        MOV      ESI, EAX\r
\r
        MOV      ECX, 4\r
        MOV      EDX, 'TGMk'\r
@@1:\r
        FLD      [Value]\r
@@10:\r
        FICOM    dword ptr [@@1024]\r
        FSTSW    AX\r
        SAHF\r
        JB       @@2\r
\r
        FIDIV    dword ptr [@@1024]\r
        FST      [Value]\r
        WAIT\r
\r
        TEST     DL, 20h\r
        JE       @@ror\r
        AND      DL, not 20h\r
        JMP      @@nxt\r
@@1024: DD       1024\r
@@100:  DD       100\r
\r
@@ror:\r
        ROR      EDX, 8\r
@@nxt:\r
        LOOP     @@10\r
@@2:\r
        TEST     DL, 20h\r
        JZ       @@3\r
        MOV      DL, 0\r
@@3:    MOV      DH, 0\r
        PUSH     DX\r
        MOV      EDI, ESP\r
\r
        FLD      ST(0)\r
        CALL     System.@TRUNC\r
        {$IFDEF _D2orD3}\r
        PUSH     0\r
        {$ELSE}\r
        PUSH     EDX\r
        {$ENDIF}\r
        PUSH     EAX\r
        FILD     qword ptr [ESP]\r
        POP      EDX\r
        POP      EDX\r
\r
        MOV      EDX, ESI\r
        CALL     Int2Str\r
\r
        FSUBP    ST(1), ST\r
        FIMUL    dword ptr [@@100]\r
        CALL     System.@TRUNC\r
\r
        TEST     EAX, EAX\r
        JZ       @@4\r
\r
        XOR      ECX, ECX\r
        MOV      CL, 0Ah\r
        CDQ\r
        IDIV     ECX\r
        TEST     EDX, EDX\r
        JZ       @@5\r
\r
        MOV      AH, DL\r
        SHL      EAX, 16\r
        ADD      EAX, '00. '\r
        PUSH     EAX\r
        MOV      EDI, ESP\r
        INC      EDI\r
        JMP      @@4\r
\r
@@5:    SHL      EAX, 8\r
        ADD      AX, '0.'\r
        PUSH     AX\r
        MOV      EDI, ESP\r
\r
@@4:\r
        MOV      EAX, [ESI]\r
        CALL     System.@LStrLen\r
        ADD      ESP, -100\r
\r
        SUB      EDI, EAX\r
        PUSH     ESI\r
        PUSH     EDI\r
        MOV      ESI, [ESI]\r
        MOV      ECX, EAX\r
        REP      MOVSB\r
\r
        POP      EDX\r
        POP      EAX\r
        CALL     System.@LStrFromPChar\r
\r
        MOV      ESP, EBX\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Num2Bytes( Value : Double ) : String;\r
const Suffix = 'KMGT';\r
var V, I : Integer;\r
begin\r
  Result := '';\r
  I := 0;\r
  while (Value >= 1024) and (I < 4) do\r
  begin\r
    Inc( I );\r
    Value := Value / 1024.0;\r
  end;\r
  Result := Int2Str( Trunc( Value ) );\r
  V := Trunc( (Value - Trunc( Value )) * 100 );\r
  if V <> 0 then\r
  begin\r
    if (V mod 10) = 0 then\r
       V := V div 10;\r
    Result := Result + ',' + Int2Str( V );\r
  end;\r
  if I > 0 then\r
     Result := Result + Suffix[ I ];\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Num2Bytes]\r
\r
//[FUNCTION S2Int]\r
{$IFDEF ASM_VERSION}\r
function S2Int( S: PChar ): Integer;\r
asm\r
        XCHG     EDX, EAX\r
        XOR      EAX, EAX\r
        TEST     EDX, EDX\r
        JZ       @@exit\r
\r
        XOR      ECX, ECX\r
        MOV      CL, [EDX]\r
        INC      EDX\r
        CMP      CL, '-'\r
        PUSHFD\r
        JE       @@0\r
@@1:    CMP      CL, '+'\r
        JNE      @@2\r
@@0:    MOV      CL, [EDX]\r
        INC      EDX\r
@@2:    SUB      CL, '0'\r
        CMP      CL, '9'-'0'\r
        JA       @@fin\r
        LEA      EAX, [EAX+EAX*4] //\r
        LEA      EAX, [ECX+EAX*2] //\r
        JMP      @@0\r
@@fin:  POPFD\r
        JNE      @@exit\r
        NEG      EAX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function S2Int( S: PChar ): Integer;\r
var M : Integer;\r
begin\r
   Result := 0;\r
   if S = '' then Exit;\r
   M := 1;\r
   if S^ = '-' then\r
   begin\r
      M := -1;\r
      Inc( S );\r
   end\r
     else\r
   if S^ = '+' then\r
     Inc( S );\r
   while S^ in [ '0'..'9' ] do\r
   begin\r
      Result := Result * 10 + Integer( S^ ) - Integer( '0' );\r
      Inc( S );\r
   end;\r
   if M < 0 then\r
      Result := -Result;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END S2Int]\r
\r
//[FUNCTION Str2Int]\r
{$IFDEF ASM_VERSION}\r
function Str2Int(const Value : String) : Integer;\r
asm\r
        CALL     EAX2PChar\r
        CALL     S2Int\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Str2Int(const Value : String) : Integer;\r
begin\r
  Result := S2Int( PChar( Value ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Str2Int]\r
\r
//[function StrCopy]\r
function StrCopy( Dest, Source: PChar ): PChar; assembler;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Dest]\r
        MOV     EDX, [Source]\r
  {$ENDIF F_P}\r
        PUSH    EDI\r
        PUSH    ESI\r
        MOV     ESI,EAX\r
        MOV     EDI,EDX\r
        OR      ECX, -1\r
        XOR     AL,AL\r
        REPNE   SCASB\r
        NOT     ECX\r
        MOV     EDI,ESI\r
        MOV     ESI,EDX\r
        MOV     EDX,ECX\r
        MOV     EAX,EDI\r
        SHR     ECX,2\r
        REP     MOVSD\r
        MOV     ECX,EDX\r
        AND     ECX,3\r
        REP     MOVSB\r
        POP     ESI\r
        POP     EDI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
function StrCat( Dest, Source: PChar ): PChar;\r
begin\r
  StrCopy( StrScan( Dest, #0 ), Source );\r
  Result := Dest;\r
end;\r
\r
//[function StrScan]\r
function StrScan(Str: PChar; Chr: Char): PChar; assembler;\r
asm\r
  {$IFDEF F_P}\r
  MOV   EAX, [Str]\r
  MOVZX EDX, [Chr]\r
  {$ENDIF}\r
        PUSH    EDI\r
        PUSH    EAX\r
        MOV     EDI,Str\r
        OR      ECX, -1\r
        XOR     AL,AL\r
        REPNE   SCASB\r
        NOT     ECX\r
        POP     EDI\r
        XCHG    EAX, EDX\r
        REPNE   SCASB\r
\r
        XCHG    EAX, EDI\r
        POP     EDI\r
\r
        JE      @@1\r
        XOR     EAX, EAX\r
        RET\r
\r
@@1:    DEC     EAX\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
//[function StrRScan]\r
function StrRScan(const Str: PChar; Chr: Char): PChar; assembler;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Str]\r
        MOVZX   EDX, [Chr]\r
  {$ENDIF F_P}\r
        PUSH    EDI\r
        MOV     EDI,Str\r
        MOV     ECX,0FFFFFFFFH\r
        XOR     AL,AL\r
        REPNE   SCASB\r
        NOT     ECX\r
        STD\r
        DEC     EDI\r
        MOV     AL,Chr\r
        REPNE   SCASB\r
        MOV     EAX,0\r
        JNE     @@1\r
        MOV     EAX,EDI\r
        INC     EAX\r
@@1:    CLD\r
        POP     EDI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
//[function StrScanLen]\r
function StrScanLen(Str: PChar; Chr: Char; Len: Integer): PChar; assembler;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Str]\r
        MOVZX   EDX, [Chr]\r
        MOV     ECX, [Len]\r
  {$ENDIF F_P}\r
        PUSH    EDI\r
        XCHG    EDI, EAX\r
        XCHG    EAX, EDX\r
        REPNE   SCASB\r
\r
        XCHG    EAX, EDI\r
        POP     EDI\r
        { -> EAX => to next character after found or to the end of Str,\r
             ZF = 0 if character found. }\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
//[FUNCTION TrimLeft]\r
{$IFDEF ASM_VERSION}\r
function TrimLeft(const S: string): string;\r
asm\r
        XCHG     EAX, EDX\r
        CALL     EDX2PChar\r
        DEC      EDX\r
@@1:    INC      EDX\r
        MOVZX    ECX, byte ptr [EDX]\r
        JECXZ    @@fin\r
        CMP      CL, ' '\r
        JBE      @@1\r
@@fin:\r
        CALL     System.@LStrFromPChar\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TrimLeft(const S: string): string;\r
var\r
  I, L: Integer;\r
begin\r
  L := Length(S);\r
  I := 1;\r
  while (I <= L) and (S[I] <= ' ') do Inc(I);\r
  Result := Copy(S, I, Maxint);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END TrimLeft]\r
\r
//[FUNCTION TrimRight]\r
{$IFDEF ASM_VERSION}\r
function TrimRight(const S: string): string;\r
asm\r
        PUSH     EDX\r
        PUSH     EAX\r
\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        XCHG     EAX, [ESP]\r
        //CALL     System.@LStrToPChar\r
        CALL     EAX2PChar\r
        POP      ECX\r
        INC      ECX\r
@@1:    DEC      ECX\r
        MOV      DL, [EAX+ECX]\r
        JL       @@fin\r
        CMP      DL, ' '\r
        JBE      @@1\r
@@fin:\r
        INC      ECX\r
        POP      EAX\r
        XOR      EDX, EDX\r
        INC      EDX\r
        CALL     System.@LStrCopy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TrimRight(const S: string): string;\r
var\r
  I: Integer;\r
begin\r
  I := Length(S);\r
  while (I > 0) and (S[I] <= ' ') do Dec(I);\r
  Result := Copy(S, 1, I);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END TrimRight]\r
\r
//[FUNCTION Trim]\r
{$IFDEF ASM_VERSION}\r
function Trim( const S : string): string;\r
asm\r
        PUSH     EDX\r
        CALL     TrimRight\r
        POP      EDX\r
        MOV      EAX, [EDX]\r
        CALL     TrimLeft\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Trim( const S : string): string;\r
begin\r
   Result := TrimLeft( TrimRight( S ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Trim]\r
\r
//[function RemoveSpaces]\r
function RemoveSpaces( const S: String ): String;\r
var I: Integer;\r
begin\r
  Result := S;\r
  for I := Length( S ) downto 1 do\r
    if S[ I ] <= ' ' then Delete( Result, I, 1 );\r
end;\r
\r
//[procedure Str2LowerCase]\r
procedure Str2LowerCase( S: PChar );\r
asm\r
  {$IFDEF F_P}\r
        MOV      EAX, [S]\r
  {$ENDIF}\r
        XOR      ECX, ECX\r
@@1:\r
        MOV      CL, byte ptr [EAX]\r
        JECXZ    @@exit\r
        SUB      CL, 'A'\r
        CMP      CL, 'Z'-'A'\r
        JA       @@2\r
        ADD      byte ptr [EAX], 32\r
@@2:    INC      EAX\r
        JMP      @@1\r
@@exit:\r
end {$IFDEF F_P} [ 'EAX', 'ECX' ] {$ENDIF};\r
\r
//[FUNCTION LowerCase]\r
{$IFDEF ASM_VERSION}\r
function LowerCase(const S: string): string;\r
asm\r
        PUSH     ESI\r
        XCHG     EAX, EDX\r
        PUSH     EAX\r
        CALL     System.@LStrAsg\r
        POP      EAX\r
\r
        CALL     UniqueString\r
\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        POP      ESI\r
\r
        XCHG     ECX, EAX\r
\r
        JECXZ    @@exit\r
\r
@@go:\r
        LODSB\r
        {$IFDEF PARANOIA}\r
        DB $2C, 'A'\r
        {$ELSE}\r
        SUB      AL, 'A'\r
        {$ENDIF}\r
        {$IFDEF PARANOIA}\r
        DB $3C, 26\r
        {$ELSE}\r
        CMP      AL, 'Z'-'A'+1\r
        {$ENDIF}\r
        JNB      @@1\r
\r
        ADD      byte ptr [ESI - 1], 20h\r
@@1:\r
        LOOP     @@go\r
@@exit:\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function LowerCase(const S: string): string;\r
var I : Integer;\r
begin\r
  Result := S;\r
  for I := 1 to Length( S ) do\r
    if Result[ I ] in [ 'A'..'Z' ] then\r
       Inc( Result[ I ], 32 );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END LowerCase]\r
\r
//[FUNCTION UpperCase]\r
{$IFDEF ASM_VERSION}\r
function UpperCase(const S: string): string;\r
asm\r
        PUSH     ESI\r
        XCHG     EAX, EDX\r
        PUSH     EAX\r
        CALL     System.@LStrAsg\r
        POP      EAX\r
\r
        CALL     UniqueString\r
\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        POP      ESI\r
\r
        XCHG     ECX, EAX\r
\r
        JECXZ    @@exit\r
\r
@@go:\r
        LODSB\r
        {$IFDEF PARANOIA}\r
        DB $2C, 'a'\r
        {$ELSE}\r
        SUB      AL, 'a'\r
        {$ENDIF}\r
        {$IFDEF PARANOIA}\r
        DB $3C, $1A\r
        {$ELSE}\r
        CMP      AL, 'z'-'a'+1\r
        {$ENDIF}\r
        JNB      @@1\r
\r
        SUB      byte ptr [ESI - 1], 20h\r
@@1:\r
        LOOP     @@go\r
@@exit:\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function UpperCase(const S: string): string;\r
var I : Integer;\r
begin\r
  Result := S;\r
  for I := 1 to Length( S ) do\r
    if Result[ I ] in [ 'a'..'z' ] then\r
       Dec( Result[ I ], 32 );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END UpperCase]\r
\r
{$IFDEF F_P}\r
//[function DummyStrFun]\r
function DummyStrFun( const S: String ): String;\r
begin\r
  Result := S;\r
end;\r
{$ENDIF F_P}\r
\r
//[FUNCTION CopyEnd]\r
{$IFDEF ASM_VERSION}\r
function CopyEnd( const S : String; Idx : Integer ) : String;\r
asm\r
        PUSH     ECX\r
        PUSH     EAX\r
        PUSH     EDX\r
\r
        CALL     System.@LStrLen\r
\r
        POP      EDX\r
        TEST     EDX, EDX\r
        JG       @@1\r
        XOR      EDX, EDX\r
        INC      EDX\r
@@1:\r
        SUB      EAX, EDX\r
        MOV      ECX, EAX\r
\r
        POP      EAX\r
        JGE      @@ret_end\r
\r
        POP      EAX\r
        JL       System.@LStrClr\r
\r
@@ret_end:\r
        INC      ECX\r
        CALL     System.@LStrCopy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CopyEnd( const S : String; Idx : Integer ) : String;\r
begin\r
  Result := Copy( S, Idx, MaxInt );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CopyEnd]\r
\r
//[FUNCTION CopyTail]\r
{$IFDEF ASM_VERSION}\r
function CopyTail( const S : String; Len : Integer ) : String;\r
asm\r
        PUSH     ECX\r
        PUSH     EAX\r
          PUSH     EDX\r
            CALL     System.@LStrLen\r
          POP      ECX\r
          CMP      ECX, EAX\r
          {$IFDEF USE_CMOV}\r
          CMOVG    ECX, EAX\r
          {$ELSE}\r
          JLE      @@1\r
          MOV      ECX, EAX\r
@@1:      {$ENDIF}\r
\r
        MOV      EDX, EAX\r
        SUB      EDX, ECX\r
        INC      EDX\r
        POP      EAX\r
        CALL     System.@LStrCopy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CopyTail( const S : String; Len : Integer ) : String;\r
var L : Integer;\r
begin\r
  L := Length( S );\r
  if L < Len then\r
     Len := L;\r
  Result := '';\r
  if Len = 0 then Exit;\r
  Result := Copy( S, L - Len + 1, Len );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CopyTail]\r
\r
//[PROCEDURE DeleteTail]\r
{$IFDEF ASM_VERSION}\r
procedure DeleteTail( var S : String; Len : Integer );\r
asm\r
        PUSH     EAX\r
        PUSH     EDX\r
        MOV      EAX, [EAX]\r
        CALL     System.@LStrLen\r
        POP      ECX\r
        CMP      ECX, EAX\r
        {$IFDEF USE_CMOV}\r
        CMOVG    ECX, EAX\r
        {$ELSE}\r
        JLE      @@1\r
        MOV      ECX, EAX\r
@@1:    {$ENDIF}\r
\r
        MOV      EDX, EAX\r
        SUB      EDX, ECX\r
        INC      EDX\r
        POP      EAX\r
        CALL     System.@LStrDelete\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure DeleteTail( var S : String; Len : Integer );\r
var L : Integer;\r
begin\r
  L := Length( S );\r
  if Len > L then\r
     Len := L;\r
  Delete( S, L - Len + 1, Len );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END DeleteTail]\r
\r
//[FUNCTION IndexOfChar]\r
{$IFDEF ASM_VERSION}\r
function IndexOfChar( const S : String; Chr : Char ) : Integer;\r
asm\r
        //PUSH     EDX\r
        //CALL     System.@LStrToPChar\r
        //POP      EDX\r
        CALL     EAX2PChar\r
        PUSH     EAX\r
        CALL     StrScan\r
        POP      EDX\r
        TEST     EAX, EAX\r
        JE       @@exit__1\r
        SUB      EAX, EDX\r
        INC      EAX\r
        RET\r
@@exit__1:\r
        DEC      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function IndexOfChar( const S : String; Chr : Char ) : Integer;\r
var P, F : PChar;\r
begin\r
   P := PChar( S );\r
   F := StrScan( P, Chr );\r
   Result := -1;\r
   if F = nil then Exit;\r
   Result := Integer( F ) - Integer( P ) + 1;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END IndexOfChar]\r
\r
//[FUNCTION IndexOfCharsMin]\r
{$IFDEF ASM_VERSION}\r
function IndexOfCharsMin( const S, Chars : String ) : Integer;\r
asm\r
        PUSH     ESI\r
        PUSH     EAX\r
        CALL     EDX2PChar\r
        MOV      ESI, EDX\r
\r
        XOR      ECX, ECX\r
        DEC      ECX\r
\r
@@1:    LODSB\r
        TEST     AL, AL\r
        JZ       @@exit\r
\r
        XCHG     EDX, EAX\r
        POP      EAX\r
        PUSH     EAX\r
\r
        PUSH     ECX\r
        CALL     IndexOfChar\r
        POP      ECX\r
        TEST     EAX, EAX\r
        JLE      @@1\r
\r
        TEST     ECX, ECX\r
        JLE      @@2\r
        CMP      EAX, ECX\r
        JGE      @@1\r
@@2:    //XCHG     ECX, EAX\r
        //JMP      @@1\r
\r
@@exit: XCHG     EAX, ECX\r
          JL     @@1\r
        POP      ECX\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function IndexOfCharsMin( const S, Chars : String ) : Integer;\r
var I, J : Integer;\r
begin\r
  Result := -1;\r
  for I := 1 to Length( Chars ) do\r
  begin\r
    J := IndexOfChar( S, Chars[ I ] );\r
    if J > 0 then\r
    begin\r
      if (Result < 0) or (J < Result) then\r
         Result := J;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END IndexOfCharsMin]\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function IndexOfWideCharsMin]\r
function IndexOfWideCharsMin( const S, Chars : WideString ) : Integer;\r
var I, J : Integer;\r
begin\r
  Result := -1;\r
  for I := 1 to Length( Chars ) do\r
  begin\r
    J := pos( Chars[ I ], S );\r
    if J > 0 then\r
    begin\r
      if (Result < 0) or (J < Result) then\r
         Result := J;\r
    end;\r
  end;\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[FUNCTION IndexOfStr]\r
{$IFDEF ASM_VERSION}\r
function IndexOfStr( const S, Sub : String ) : Integer;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
\r
        PUSH     EAX\r
        MOV      EAX, EDX\r
        PUSH     EDX\r
        CALL     System.@LStrLen\r
        MOV      EDI, EAX\r
        POP      EAX\r
        //CALL     System.@LStrToPChar\r
        CALL     EAX2PChar\r
        MOV      BL, [EAX]\r
        XCHG     EAX, [ESP]\r
        //CALL     System.@LStrToPChar\r
        CALL     EAX2PChar\r
\r
        MOV      ESI, EAX\r
\r
        DEC      EAX\r
@@1:    INC      EAX\r
        MOV      DL, BL\r
        CALL     StrScan\r
        TEST     EAX, EAX\r
        JE       @@exit__1\r
\r
        POP      EDX\r
        PUSH     EDX\r
\r
        MOV      ECX, EDI\r
        PUSH     EAX\r
        CALL     StrLComp\r
        POP      EAX\r
        JNE      @@1\r
\r
        SUB      EAX, ESI\r
        INC      EAX\r
        JMP      @@exit\r
\r
@@exit__1:\r
        DEC      EAX\r
@@exit:\r
        POP      EDX\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function IndexOfStr( const S, Sub : String ) : Integer;\r
var I : Integer;\r
begin\r
  Result := Length( S );\r
  if Sub = '' then Exit;\r
  Result := 0;\r
  if S = '' then Exit;\r
  if Length( Sub ) > Length( S ) then Exit;\r
  Result := 1;\r
  while Result + Length( Sub ) - 1 <= Length( S ) do\r
  begin\r
    I := IndexOfChar( CopyEnd( S, Result ), Sub[ 1 ] );\r
    if I <= 0 then break;\r
    Result := Result + I - 1;\r
    if Result <= 0 then Exit;\r
    if Copy( S, Result, Length( Sub ) ) = Sub then Exit;\r
    Inc( Result );\r
  end;\r
  Result := -1;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END IndexOfStr]\r
\r
//[FUNCTION Parse]\r
{$IFDEF ASM_VERSION} //???\r
function Parse( var S : String; const Separators : String ) : String;\r
asm\r
         PUSH    EBX\r
         PUSH    EDI\r
         MOV     EBX, EAX\r
\r
         PUSH    ECX\r
         MOV     EAX, [EBX]\r
         CALL    IndexOfCharsMin\r
         INC     EAX\r
         JNE     @@1\r
         MOV     EAX, [EBX]\r
         CALL    System.@LStrLen\r
         INC     EAX\r
         INC     EAX\r
@@1:\r
         DEC     EAX\r
         MOV     EDI, EAX\r
         MOV     ECX, EAX\r
         DEC     ECX\r
         XOR     EDX, EDX\r
         INC     EDX\r
         MOV     EAX, [EBX]\r
         CALL    System.@LStrCopy\r
\r
         MOV     EAX, [EBX]\r
         MOV     EDX, EDI\r
         INC     EDX\r
         MOV     ECX, EBX\r
         CALL    CopyEnd\r
\r
         POP     EDI\r
         POP     EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Parse( var S : String; const Separators : String ) : String;\r
var Pos : Integer;\r
begin\r
  Pos := IndexOfCharsMin( S, Separators );\r
  if Pos <= 0 then\r
     Pos := Length( S ) + 1;\r
  Result := S;\r
  S := Copy( Result, Pos + 1, MaxInt );\r
  Result := Copy( Result, 1, Pos - 1 );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Parse]\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function WParse]\r
function WParse( var S : WideString; const Separators : WideString ) : WideString;\r
var Pos : Integer;\r
begin\r
  Pos := IndexOfWideCharsMin( S, Separators );\r
  if Pos <= 0 then\r
     Pos := Length( S ) + 1;\r
  Result := S;\r
  S := Copy( Result, Pos + 1, MaxInt );\r
  Result := Copy( Result, 1, Pos - 1 );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[function ParsePascalString]\r
function ParsePascalString( var S : String; const Separators : String ) : String;\r
var Pos, Idx : Integer;\r
    Hex, Spc : boolean;\r
    procedure SkipSpaces;\r
    begin\r
      if not Spc then\r
        while (Length( S ) >= Pos) and (S[ Pos ] = ' ') do\r
          Inc( Pos );\r
    end;\r
var Buf : String;\r
    Ou, Val : Integer;\r
begin\r
  Pos := 1;\r
  Spc := IndexOfChar( Separators, ' ' ) >= 0;\r
  SkipSpaces;\r
  if Length( S ) < Pos then\r
  begin\r
    Result := S;\r
    S := '';\r
    exit;\r
  end;\r
  Buf := PChar( S );\r
  Ou := 1;\r
  if S[ Pos ] in [ '''', '#' ] then\r
  begin\r
    // skip here string constant expression\r
    while Pos <= Length( S ) do\r
    begin\r
      if S[ Pos ] = '''' then\r
      begin\r
        Inc( Pos );\r
        while Pos <= Length( S ) do\r
        begin\r
          if S[ Pos ] = '''' then\r
            if (Pos = Length( S )) or (S[ Pos+1 ] <> '''') then\r
            begin\r
              Inc( Pos );\r
              break;\r
            end\r
            else Inc( Pos );\r
          Buf[ Ou ] := S[ Pos ];\r
          Inc( Ou );\r
          Inc( Pos );\r
        end;\r
        //if Pos < Length( S ) then Inc( Pos );\r
      end\r
         else\r
      if S[ Pos ] = '#' then\r
      begin\r
        Inc( Pos ); Hex := False; Val := 0;\r
        if (Pos < Length( S )) and (S[ Pos ] = '$') then\r
        begin\r
           Inc( Pos ); Hex := True;\r
        end;\r
        Dec( Pos );\r
        while Pos < Length( S ) do\r
        begin\r
          Inc( Pos );\r
          if (S[ Pos ] in [ '0'..'9' ]) or\r
             Hex and (S[ Pos ] in [ 'a'..'f', 'A'..'F' ]) then\r
          begin\r
            if Hex then\r
               Val := Val * 16\r
            else\r
               Val := Val * 10;\r
            if S[ Pos ] <= '9' then\r
               Val := Val + Integer( S[ Pos ] ) - Integer( '0' )\r
            else\r
            if S[ Pos ] <= 'F' then\r
               Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'A' )\r
            else\r
               Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'a' );\r
            continue;\r
          end;\r
          Inc( Pos ); break;\r
        end;\r
        Buf[ Ou ] := Char( Val );\r
        Inc( Ou );\r
      end\r
         else break;\r
      SkipSpaces;\r
      if S[ Pos ] <> '+' then break;\r
      SkipSpaces;\r
    end;\r
  end;\r
  Idx := IndexOfCharsMin( CopyEnd( S, Pos ), Separators );\r
  if Idx <= 0 then\r
  begin\r
    Result := Copy( Buf, 1, Ou - 1 ) + CopyEnd( S, Pos );\r
    S := '';\r
  end\r
     else\r
  begin\r
    Result := Copy( Buf, 1, Ou - 1 ) + Copy( S, Pos, Idx - 1 );\r
    S := CopyEnd( S, Pos + Idx );\r
  end;\r
end;\r
\r
//[function String2PascalStrExpr]\r
function String2PascalStrExpr( const S : String ) : String;\r
var I, Strt : Integer;\r
  function String2DoubleQuotas( const S : String ) : String;\r
  var I, J : Integer;\r
  begin\r
    if IndexOfChar( S, '''' ) <= 0 then\r
       Result := S\r
    else\r
    begin\r
      J := 0;\r
      for I := 1 to Length( S ) do\r
        if S[ I ] = '''' then Inc( J );\r
      SetLength( Result, Length( S ) + J );\r
      J := 1;\r
      for I := 1 to Length( S ) do\r
      begin\r
        Result[ J ] := S[ I ];\r
        Inc( J );\r
        if S[ I ] = '''' then\r
        begin\r
          Result[ J ] := '''';\r
          Inc( J );\r
        end;\r
      end;\r
    end;\r
  end;\r
begin\r
  Result := '';\r
  if S = '' then\r
  begin\r
    Result := '''''';\r
    exit;\r
  end;\r
  Strt := 1;\r
  for I := 1 to Length( S ) + 1 do\r
  begin\r
    if (I > Length( S )) or (S[ I ] < ' ') then\r
    begin\r
      if (I > Strt) and (I > 1) then\r
      begin\r
        if Result <> '' then\r
           Result := Result + '+';\r
        Result := Result + '''' + String2DoubleQuotas( Copy( S, Strt, I - Strt ) ) + '''';\r
      end;\r
      if I > Length( S ) then break;\r
      if Result <> '' then\r
         Result := Result + '+'\r
      else\r
         Result := Result + '''''+';\r
      Result := Result + '#' + Int2Str( Integer( S[ I ] ) );\r
      Strt := I + 1;\r
    end;\r
  end;\r
end;\r
\r
//[function CompareMem]\r
function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [P1]\r
        MOV     EDX, [P2]\r
        MOV     ECX, [Length]\r
  {$ENDIF}\r
        PUSH    ESI\r
        PUSH    EDI\r
        MOV     ESI,P1\r
        MOV     EDI,P2\r
        MOV     EDX,ECX\r
        XOR     EAX,EAX\r
        AND     EDX,3\r
        SHR     ECX,1\r
        SHR     ECX,1\r
        REPE    CMPSD\r
        JNE     @@2\r
        MOV     ECX,EDX\r
        REPE    CMPSB\r
        JNE     @@2\r
@@1:    INC     EAX\r
@@2:    POP     EDI\r
        POP     ESI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
//[FUNCTION AllocMem]\r
{$IFDEF ASM_VERSION}\r
function AllocMem( Size : Integer ) : Pointer;\r
asm     //cmd    //opd\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        PUSH     EAX\r
        CALL     System.@GetMem\r
        POP      EDX\r
        PUSH     EAX\r
        MOV      CL, 0\r
        CALL     System.@FillChar\r
        POP      EAX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function AllocMem( Size : Integer ) : Pointer;\r
begin\r
   Result := nil;\r
   if Size > 0 then\r
   begin\r
     GetMem( Result, Size );\r
     FillChar( Result^, Size, 0 );\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END AllocMem]\r
\r
//[procedure DisposeMem]\r
procedure DisposeMem( var Addr : Pointer );\r
begin\r
   if Addr <> nil then\r
      FreeMem( Addr );\r
   Addr := nil;\r
end;\r
\r
//[function AnsiUpperCase]\r
function AnsiUpperCase(const S: string): string;\r
var\r
  Len: Integer;\r
begin\r
  Len := Length(S);\r
  SetString(Result, PChar(S), Len);\r
  if Len > 0 then CharUpperBuff(Pointer(Result), Len);\r
end;\r
\r
//[function AnsiLowerCase]\r
function AnsiLowerCase(const S: string): string;\r
var\r
  Len: Integer;\r
begin\r
  Len := Length(S);\r
  SetString(Result, PChar(S), Len);\r
  if Len > 0 then CharLowerBuff(Pointer(Result), Len);\r
end;\r
\r
{$IFNDEF _D2}\r
{$IFNDEF _FPC}\r
//[function WAnsiUpperCase]\r
function WAnsiUpperCase(const S: WideString): WideString;\r
var Len: Integer;\r
begin\r
  Len := Length(S);\r
  Result := S;\r
  if Len > 0 then CharUpperBuffW(Pointer(Result), Len);\r
end;\r
\r
//[function WAnsiLowerCase]\r
function WAnsiLowerCase(const S: WideString): WideString;\r
var Len: Integer;\r
begin\r
  Len := Length(S);\r
  Result := S;\r
  if Len > 0 then CharLowerBuffW(Pointer(Result), Len);\r
end;\r
{$ENDIF _FPC}\r
{$ENDIF _D2}\r
\r
//[function AnsiCompareStr]\r
function AnsiCompareStr(const S1, S2: string): Integer;\r
begin\r
  Result := CompareString(LOCALE_USER_DEFAULT, 0, PChar(S1), -1,\r
    PChar(S2), -1 ) - 2;\r
end;\r
\r
//[function _AnsiCompareStr]\r
function _AnsiCompareStr(S1, S2: PChar): Integer;\r
begin\r
  Result := CompareString( LOCALE_USER_DEFAULT, 0, S1, -1,\r
                           S2, -1) - 2;\r
end;\r
\r
//[function AnsiCompareStrNoCase]\r
function AnsiCompareStrNoCase(const S1, S2: string): Integer;\r
begin\r
  Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1), -1,\r
    PChar(S2), -1 ) - 2;\r
end;\r
\r
//[function _AnsiCompareStrNoCase]\r
function _AnsiCompareStrNoCase(S1, S2: PChar): Integer;\r
begin\r
  Result := CompareString( LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1,\r
                           S2, -1) - 2;\r
end;\r
\r
//[function AnsiCompareText]\r
function AnsiCompareText( const S1, S2: String ): Integer;\r
begin\r
  Result := AnsiCompareStrNoCase( S1, S2 );\r
end;\r
\r
//[function StrLCopy]\r
function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Dest]\r
        MOV     EDX, [Source]\r
        MOV     ECX, [MaxLen]\r
  {$ENDIF F_P}\r
        PUSH    EDI\r
        PUSH    ESI\r
        PUSH    EBX\r
        MOV     ESI,EAX\r
        MOV     EDI,EDX\r
        MOV     EBX,ECX\r
        XOR     AL,AL\r
        TEST    ECX,ECX\r
        JZ      @@1\r
        REPNE   SCASB\r
        JNE     @@1\r
        INC     ECX\r
@@1:    SUB     EBX,ECX\r
        MOV     EDI,ESI\r
        MOV     ESI,EDX\r
        MOV     EDX,EDI\r
        MOV     ECX,EBX\r
        SHR     ECX,2\r
        REP     MOVSD\r
        MOV     ECX,EBX\r
        AND     ECX,3\r
        REP     MOVSB\r
        STOSB\r
        MOV     EAX,EDX\r
        POP     EBX\r
        POP     ESI\r
        POP     EDI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
//[FUNCTION StrPCopy]\r
{$IFDEF ASM_VERSION}\r
function StrPCopy(Dest: PChar; const Source: string): PChar;\r
asm\r
        PUSH     EAX\r
        MOV      EAX, EDX\r
        CALL     System.@LStrLen\r
        MOV      ECX, EAX\r
        POP      EAX\r
        CALL     EDX2PChar\r
        CALL     StrLCopy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function StrPCopy(Dest: PChar; const Source: string): PChar;\r
begin\r
  Result := StrLCopy(Dest, PChar(Source), Length(Source));\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END StrPCopy]\r
\r
//[FUNCTION StrEq]\r
{$IFDEF ASM_VERSION}\r
function StrEq( const S1, S2 : String ) : Boolean;\r
asm\r
        TEST     EDX, EDX\r
        JNZ      @@1\r
@@0:    CMP      EAX, EDX\r
        JMP      @@exit\r
@@1:    TEST     EAX, EAX\r
        JZ       @@0\r
        MOV      ECX, [EAX-4]\r
        CMP      ECX, [EDX-4]\r
        JNE      @@exit\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     0\r
        MOV      EDX, ESP\r
        CALL     LowerCase\r
        PUSH     0\r
        MOV      EAX, [ESP + 8]\r
        MOV      EDX, ESP\r
        CALL     LowerCase\r
        POP      EAX\r
        POP      EDX\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     System.@LStrCmp\r
        MOV      EAX, ESP\r
        PUSHFD\r
        XOR      EDX, EDX\r
        MOV      DL, 2\r
        CALL     System.@LStrArrayClr\r
        POPFD\r
        POP      EDX\r
        POP      EDX\r
        POP      EDX\r
        POP      EDX\r
@@exit:\r
        SETZ     AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function StrEq( const S1, S2 : String ) : Boolean;\r
begin\r
  Result := (Length( S1 ) = Length( S2 )) and\r
            (LowerCase( S1 ) = LowerCase( S2 ));\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END StrEq]\r
\r
//[FUNCTION AnsiEq]\r
{$IFDEF ASM_VERSION}\r
function AnsiEq( const S1, S2 : String ) : Boolean;\r
asm\r
        CALL     AnsiCompareStrNoCase\r
        TEST     EAX, EAX\r
        SETZ     AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function AnsiEq( const S1, S2 : String ) : Boolean;\r
begin\r
  Result := AnsiCompareStrNoCase( S1, S2 ) = 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END AnsiEq]\r
\r
{$IFNDEF _D2}\r
{$IFNDEF _FPC}\r
//[function WAnsiEq]\r
function WAnsiEq( const S1, S2 : WideString ) : Boolean;\r
begin\r
  Result := WAnsiLowerCase( S1 )=WAnsiLowerCase( S2 );\r
end;\r
{$ENDIF _FPC}\r
{$ENDIF _D2}\r
\r
//[FUNCTION StrIn]\r
{$IFDEF ASM_VERSION}\r
function StrIn(const S: String; const A: array of String): Boolean;\r
asm\r
@@1:\r
        TEST     ECX, ECX\r
        JL       @@ret_0\r
\r
        PUSH     EDX\r
        MOV      EDX, [EDX+ECX*4]\r
        DEC      ECX\r
\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     StrEq\r
        DEC      AL\r
        POP      EAX\r
        POP      ECX\r
\r
        POP      EDX\r
        JNZ      @@1\r
\r
        MOV      AL, 1\r
        RET\r
\r
@@ret_0:XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function StrIn(const S: String; const A: array of String): Boolean;\r
var I : Integer;\r
begin\r
  for I := Low( A ) to High( A ) do\r
      if StrEq( S, A[ I ] ) then\r
      begin\r
        Result := True;\r
        Exit;\r
      end;\r
  Result := False;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END StrIn]\r
\r
{$IFNDEF _D2}\r
{$IFNDEF _FPC}\r
//[function WStrIn]\r
function WStrIn( const S : WideString; const A : array of WideString ) : Boolean;\r
var I : Integer;\r
begin\r
  for I := Low( A ) to High( A ) do\r
      if WAnsiEq( S, A[ I ] ) then\r
      begin\r
        Result := True;\r
        Exit;\r
      end;\r
  Result := False;\r
end;\r
{$ENDIF _FPC}\r
{$ENDIF _D2}\r
\r
//[function StrIs]\r
function StrIs( const S : String; const A : array of String; var Idx: Integer ) : Boolean;\r
var I : Integer;\r
begin\r
  Idx := -1;\r
  for I := Low( A ) to High( A ) do\r
      if StrEq( S, A[ I ] ) then\r
      begin\r
        Idx := I;\r
        Result := True;\r
        Exit;\r
      end;\r
  Result := False;\r
end;\r
\r
//[function IntIn]\r
function IntIn( Value: Integer; const List: array of Integer ): Boolean;\r
var I: Integer;\r
begin\r
  Result := FALSE;\r
  for I := 0 to High( List ) do\r
  begin\r
    if Value = List[ I ] then\r
    begin\r
      Result := TRUE;\r
      break;\r
    end;\r
  end;\r
end;\r
\r
//[FUNCTION _StrSatisfy]\r
{$IFDEF ASM_VERSION}\r
function _StrSatisfy( S, Mask : PChar ) : Boolean;\r
asm\r
    TEST EAX, EAX\r
    JZ   @@exit\r
        XCHG     ECX, EAX\r
        //       EDX <- Mask\r
        //       ECX <- S\r
        XOR      EAX, EAX\r
        MOV      AL, '*'\r
@@rest_satisfy:\r
        PUSH     ECX\r
        PUSH     EDX\r
\r
@@nx_char:\r
        MOV      AH, [EDX]\r
        OR       AH, [ECX]\r
        JZ       @@fin //@@ret_true\r
\r
        MOV      AH, 0\r
\r
        CMP      word ptr [EDX], AX //'*'\r
        JE       @@fin //@@ret_true\r
\r
        CMP      byte ptr [ECX], AH\r
        JNE      @@10\r
\r
        DEC      EDX\r
@@1:\r
        INC      EDX\r
        CMP      byte ptr [EDX], AL //'*'\r
        JE       @@1\r
        //CMP      byte ptr [EDX], '?'\r
        //JE       @@1\r
\r
        CMP      byte ptr [EDX], AH\r
        SETZ     AL\r
        JMP      @@fin\r
\r
@@10:   CMP      byte ptr [EDX], AH\r
        JE       @@ret_false\r
\r
        CMP      byte ptr [EDX], '?'\r
        JNE      @@11\r
\r
@@go_nx_char:\r
        INC      ECX\r
        INC      EDX\r
        JMP      @@nx_char\r
\r
@@11:\r
        CMP      byte ptr [EDX], AL //'*'\r
        JNE      @@20\r
\r
        INC      EDX\r
@@12:   CMP      byte ptr [ECX], AH\r
        JE       @@ret_false\r
\r
        CALL     @@rest_satisfy\r
        TEST     AL, AL\r
        JNE      @@fin\r
        MOV      AL, '*'\r
\r
        INC      ECX\r
        JMP      @@12\r
\r
@@20:   MOV      AH, [EDX]\r
        XOR      AH, [ECX]\r
\r
        JE       @@go_nx_char\r
@@ret_false:\r
        XOR      EAX, EAX\r
\r
@@fin:\r
        POP      EDX\r
        POP      ECX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function _StrSatisfy( S, Mask : PChar ) : Boolean;\r
label next_char;\r
begin\r
next_char:\r
  Result := True;\r
  if (S^ = #0) and (Mask^ = #0) then exit;\r
  if (Mask^ = '*') and (Mask[1] = #0) then exit;\r
  if S^ = #0 then\r
  begin\r
    while Mask^ = '*' do\r
          Inc( Mask );\r
    Result := Mask^ = #0;\r
    exit;\r
  end;\r
  Result := False;\r
  if Mask^ = #0 then exit;\r
  if Mask^ = '?' then\r
  begin\r
    Inc( S ); Inc( Mask ); goto next_char;\r
  end;\r
  if Mask^ = '*' then\r
  begin\r
    Inc( Mask );\r
    while S^ <> #0 do\r
    begin\r
      Result := _StrSatisfy( S, Mask );\r
      if Result then exit;\r
      Inc( S );\r
    end;\r
    exit; // (Result = False)\r
  end;\r
  Result := S^ = Mask^;\r
  Inc( S ); Inc( Mask );\r
  if Result then goto next_char;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _StrSatisfy]\r
\r
//[FUNCTION StrSatisfy]\r
{$IFDEF ASM_VERSION}\r
function StrSatisfy( const S, Mask: String ): Boolean;\r
asm\r
        PUSH     ESI\r
        XCHG     ESI, EAX\r
        PUSH     0\r
        XCHG     EAX, EDX\r
        CALL     EAX2PChar\r
        MOV      EDX, ESP\r
\r
        CMP      byte ptr [EAX], 0\r
        JZ       @@0\r
        CALL     AnsiLowerCase\r
@@0:\r
        XCHG     EAX, ESI\r
        PUSH     0\r
        CALL     EAX2PChar\r
        MOV      EDX, ESP\r
\r
        CMP      byte ptr [EAX], 0\r
        JZ       @@1\r
        CALL     AnsiLowerCase\r
@@1:\r
        POP      EAX\r
        POP      EDX\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     _StrSatisfy\r
\r
        XCHG     ESI, EAX\r
\r
        CALL     RemoveStr\r
        CALL     RemoveStr\r
        XCHG     EAX, ESI\r
\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function StrSatisfy( const S, Mask: String ): Boolean;\r
begin\r
  Result := _StrSatisfy( PChar( AnsiLowerCase( S ) ),\r
                         PChar( AnsiLowerCase( Mask ) ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END StrSatisfy]\r
\r
//[FUNCTION _2StrSatisfy]\r
{$IFDEF ASM_VERSION}\r
function _2StrSatisfy( S, Mask: PChar ): Boolean;\r
asm     //     //\r
        PUSH   EBX\r
        XCHG   EBX, EAX\r
        PUSH   0\r
        MOV    EAX, ESP\r
        CALL   System.@LStrFromPChar\r
        PUSH   0\r
        MOV    EAX, ESP\r
        MOV    EDX, EBX\r
        CALL   System.@LStrFromPChar\r
        POP    EAX\r
        POP    EDX\r
        PUSH   EDX\r
        PUSH   EAX\r
        CALL   StrSatisfy\r
        XCHG   EBX, EAX\r
        CALL   RemoveStr\r
        CALL   RemoveStr\r
        XCHG   EAX, EBX\r
        POP    EBX\r
end;\r
{$ELSE ASM_VERSION} // Pascal\r
function _2StrSatisfy( S, Mask: PChar ): Boolean;\r
begin\r
  Result := StrSatisfy( S, Mask );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _2StrSatisfy]\r
\r
//[function StrReplace]\r
function StrReplace( var S: String; const From, ReplTo: String ): Boolean;\r
var I: Integer;\r
begin\r
  I := pos( From, S );\r
  if I > 0 then\r
  begin\r
    S := Copy( S, 1, I - 1 ) + ReplTo + CopyEnd( S, I + Length( From ) );\r
    Result := TRUE;\r
  end\r
  else Result := FALSE;\r
end;\r
\r
{-}\r
{$IFDEF _FPC}\r
//[procedure SetLengthW]\r
procedure SetLengthW( var W: WideString; NewLength: Integer );\r
begin\r
  while Length( W ) < NewLength do\r
    W := W + ' ' + W;\r
  if Length( W ) > NewLength then\r
    Delete( W, NewLength + 1, Length( W ) - NewLength );\r
end;\r
\r
//[function CopyW]\r
function CopyW( const W: WideString; From, Count: Integer ): WideString;\r
begin\r
  Result := '';\r
  if Count <= 0 then Exit;\r
  SetLengthW( Result, Count );\r
  Move( W[ From ], Result[ 1 ], Count * Sizeof( WideChar ) );\r
end;\r
\r
//[function posW]\r
function posW( const S1, S2: String ): Integer;\r
var I, L1: Integer;\r
begin\r
  L1 := Length( S1 );\r
  for I := 1 to Length( S2 )-L1+1 do\r
  begin\r
    if Copy( S2, I, L1 ) = S1 then\r
    begin\r
      Result := I;\r
      Exit;\r
    end;\r
  end;\r
  Result := 0;\r
end;\r
{$ENDIF _FPC}\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function WStrReplace]\r
function WStrReplace( var S: WideString; const From, ReplTo: WideString ): Boolean;\r
var I: Integer;\r
begin\r
  I := pos( From, S );\r
  if I > 0 then\r
  begin\r
    S := Copy( S, 1, I - 1 ) + ReplTo + Copy( S, I + Length( From ), MaxInt );\r
    Result := TRUE;\r
  end\r
  else Result := FALSE;\r
end;\r
\r
//[function WStrRepeat]\r
function WStrRepeat( const S: WideString; Count: Integer ): WideString;\r
var I, L: Integer;\r
begin\r
  L := Length( S );\r
  SetLength( Result, L * Count );\r
  for I := 0 to Count-1 do\r
    Move( S[ 1 ], Result[ 1 + I * L ], L * Sizeof( WideChar ) );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
{+}\r
//[function StrRepeat]\r
function StrRepeat( const S: String; Count: Integer ): String;\r
var I, L: Integer;\r
begin\r
  L := Length( S );\r
  SetLength( Result, L * Count );\r
  for I := 0 to Count-1 do\r
    Move( S[ 1 ], Result[ 1 + I * L ], L );\r
end;\r
\r
\r
//[PROCEDURE NormalizeUnixText]\r
{$IFDEF ASM_VERSION}\r
procedure NormalizeUnixText( var S: String );\r
asm     //cmd    //opd\r
        CMP      dword ptr [EAX], 0\r
        JZ       @@exit\r
        PUSH     EBX\r
        PUSH     EDI\r
        MOV      EBX, EAX\r
        CALL     UniqueString\r
        MOV      EDI, [EBX]\r
@@1:    MOV      EAX, EDI\r
        CALL     System.@LStrLen\r
        XCHG     ECX, EAX\r
        MOV      AX, $0D0A\r
\r
        CMP      byte ptr [EDI], AL\r
        JNE      @@loo\r
        MOV      byte ptr [EDI], AH\r
@@loo:\r
        TEST     ECX, ECX\r
        JZ       @@fin\r
@@loo1:\r
        REPNZ SCASB\r
        JNZ      @@fin\r
        CMP      byte ptr [EDI-2], AH\r
        JE       @@loo\r
        MOV      byte ptr [EDI-1], AH\r
        JNE      @@loo1\r
@@fin:  POP      EDI\r
        POP      EBX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure NormalizeUnixText( var S: String );\r
var I: Integer;\r
begin\r
  if S <> '' then\r
  begin\r
    if S[ 1 ] = #10 then\r
      S[ 1 ] := #13;\r
    for I := 2 to Length(S) do\r
      if (S[I]=#10) and (S[I-1]<>#13) then\r
        S[I] := #13;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NormalizeUnixText]\r
\r
//[function StrComp]\r
function StrComp(const Str1, Str2: PChar): Integer; assembler;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Str1]\r
        MOV     EDX, [Str2]\r
  {$ENDIF F_P}\r
        PUSH    EDI\r
        PUSH    ESI\r
        MOV     EDI,EDX\r
        XCHG    ESI,EAX\r
        OR      ECX, -1\r
        XOR     EAX,EAX\r
        REPNE   SCASB\r
        NOT     ECX\r
        MOV     EDI,EDX\r
        XOR     EDX,EDX\r
        REPE    CMPSB\r
        MOV     AL,[ESI-1]\r
        MOV     DL,[EDI-1]\r
        SUB     EAX,EDX\r
        POP     ESI\r
        POP     EDI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
function StrComp_NoCase(const Str1, Str2: PChar): Integer;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Str1]\r
        MOV     EDX, [Str2]\r
  {$ENDIF F_P}\r
        PUSH    EDI\r
        PUSH    ESI\r
        MOV     EDI,EDX\r
        XCHG    ESI,EAX\r
        OR      ECX, -1\r
        XOR     EAX,EAX\r
        REPNE   SCASB\r
\r
        NOT     ECX\r
        MOV     EDI,EDX\r
  @@0:\r
        XOR     EDX,EDX\r
        REPE    CMPSB\r
        MOV     AL,[ESI-1]\r
        MOV     AH, AL\r
        SUB     AH, 'a'\r
        CMP     AH, 25\r
        JA      @@1\r
        SUB     AL, $20\r
  @@1:\r
        MOV     DL,[EDI-1]\r
        MOV     AH, DL\r
        SUB     AH, 'a'\r
        CMP     AH, 25\r
        JA      @@2\r
        SUB     DL, $20\r
  @@2:\r
        MOV     AH, 0\r
        SUB     EAX,EDX\r
        JNZ     @@exit\r
        CMP     DL, 0\r
        JNZ     @@0\r
\r
  @@exit:\r
        POP     ESI\r
        POP     EDI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
//[function StrLComp_NoCase]\r
function StrLComp_NoCase(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Str1]\r
        MOV     EDX, [Str2]\r
        MOV     ECX, [MaxLen]\r
  {$ENDIF F_P}\r
        PUSH    EDI\r
        PUSH    ESI\r
        PUSH    EBX\r
        MOV     EDI,EDX\r
        MOV     ESI,EAX\r
        MOV     EBX,ECX\r
        XOR     EAX,EAX\r
        OR      ECX,ECX\r
        JE      @@exit\r
        REPNE   SCASB\r
        SUB     EBX,ECX\r
        MOV     ECX,EBX\r
        MOV     EDI,EDX\r
  @@0:\r
        XOR     EDX,EDX\r
        REPE    CMPSB\r
        MOV     AL,[ESI-1]\r
        MOV     AH, AL\r
        SUB     AH, 'a'\r
        CMP     AH, 25\r
        JA      @@1\r
        SUB     AL, $20\r
  @@1:\r
        MOV     DL,[EDI-1]\r
        MOV     AH, DL\r
        SUB     AH, 'a'\r
        CMP     AH, 25\r
        JA      @@2\r
        SUB     DL, $20\r
  @@2:\r
        MOV     AH, 0\r
        SUB     EAX,EDX\r
        JECXZ   @@exit\r
        JZ      @@0\r
\r
  @@exit:\r
        POP     EBX\r
        POP     ESI\r
        POP     EDI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
//[function StrLComp]\r
function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; assembler;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Str1]\r
        MOV     EDX, [Str2]\r
        MOV     ECX, [MaxLen]\r
  {$ENDIF F_P}\r
        PUSH    EDI\r
        PUSH    ESI\r
        PUSH    EBX\r
        MOV     EDI,EDX\r
        MOV     ESI,EAX\r
        MOV     EBX,ECX\r
        XOR     EAX,EAX\r
        OR      ECX,ECX\r
        JE      @@1\r
        REPNE   SCASB\r
        SUB     EBX,ECX\r
        MOV     ECX,EBX\r
        MOV     EDI,EDX\r
        XOR     EDX,EDX\r
        REPE    CMPSB\r
        MOV     AL,[ESI-1]\r
        MOV     DL,[EDI-1]\r
        SUB     EAX,EDX\r
@@1:    POP     EBX\r
        POP     ESI\r
        POP     EDI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
//[function StrLen]\r
function StrLen(const Str: PChar): Cardinal; assembler;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Str]\r
  {$ENDIF F_P}\r
        XCHG    EAX, EDI\r
        XCHG    EDX, EAX\r
        OR      ECX, -1\r
        XOR     EAX, EAX\r
        CMP     EAX, EDI\r
        JE      @@exit0\r
        REPNE   SCASB\r
        DEC     EAX\r
        DEC     EAX\r
        SUB     EAX,ECX\r
@@exit0:\r
        MOV     EDI,EDX\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
//[FUNCTION __DelimiterLast]\r
{$IFDEF ASM_VERSION}\r
function __DelimiterLast( Str: PChar; Delimiters: PChar ): PChar;\r
asm\r
        PUSH     ESI\r
\r
        CALL     EAX2PChar\r
\r
        MOV      ESI, EDX\r
        MOV      EDX, EAX\r
\r
@@tolast:\r
        CMP      byte ptr [EAX], 0\r
        JZ       @@next1\r
        INC      EAX\r
        JMP      @@tolast\r
\r
@@next1:\r
        PUSH     EAX\r
\r
@@next:\r
        LODSB\r
        TEST     AL, AL\r
        JZ       @@exit\r
\r
        PUSH     EDX\r
        XCHG     EDX, EAX\r
        CALL     StrRScan\r
        POP      EDX\r
\r
        TEST     EAX, EAX\r
        JZ       @@next\r
\r
        POP      ECX\r
        CMP      byte ptr [ECX], 0\r
        JZ       @@next1\r
\r
        CMP      EAX, ECX\r
        JG       @@next1\r
\r
        PUSH     ECX\r
        JLE      @@next\r
\r
@@exit: POP      EAX\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function __DelimiterLast( Str: PChar; Delimiters: PChar ): PChar;\r
var\r
    P, F : PChar;\r
begin\r
  P := Str;\r
  Result := P + StrLen( Str );\r
  while Delimiters^ <> #0 do\r
  begin\r
    F := StrRScan( P, Delimiters^ );\r
    if F <> nil then\r
    if (Result^ = #0) or (Integer(F) > Integer(Result)) then\r
       Result := F;\r
    Inc( Delimiters );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END __DelimiterLast]\r
\r
//[function SkipSpaces]\r
function SkipSpaces( P: PChar ): PChar;\r
begin\r
  while True do\r
  begin\r
    while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);\r
    if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;\r
  end;\r
  Result := P;\r
end;\r
\r
//[function SkipParam]\r
function SkipParam(P: PChar): PChar;\r
begin\r
  P := SkipSpaces( P );\r
  while P[0] > ' ' do\r
    if P[0] = '"' then\r
    begin\r
      Inc(P);\r
      while (P[0] <> #0) and (P[0] <> '"') do\r
        Inc(P);\r
      if P[0] <> #0 then Inc(P);\r
    end\r
      else\r
      Inc(P);\r
  Result := P;\r
end;\r
\r
//[FUNCTION ParamStr]\r
function ParamStr( Idx: Integer ): String;\r
var\r
  P, P1: PChar;\r
  Buffer: array[ 0..260 ] of Char;\r
begin\r
  if Idx = 0 then\r
    SetString( Result, Buffer, GetModuleFileName( 0, Buffer, Sizeof( Buffer ) ) )\r
  else\r
  begin\r
    P := GetCommandLine;\r
    repeat\r
      P := SkipSpaces( P );\r
      P1 := P;\r
      P := SkipParam(P);\r
      if Idx = 0 then Break;\r
      Dec(Idx);\r
    until (Idx < 0) or (P = P1);\r
    Result := Copy( P1, 1, P - P1 );\r
    if Length( Result ) >= 2 then\r
    if (Result[ 1 ] = '"') and (Result[ Length( Result ) ] = '"') then\r
      Result := Copy( Result, 2, Length( Result ) - 2 );\r
  end;\r
end;\r
//[END ParamStr]\r
\r
//[FUNCTION ParamCount]\r
function ParamCount: Integer;\r
var\r
  S: string;\r
begin\r
  Result := 0;\r
  while True do\r
  begin\r
    S := ParamStr(Result + 1);\r
    if S = '' then Break;\r
    Inc(Result);\r
  end;\r
end;\r
//[END ParamCount]\r
\r
//[FUNCTION DelimiterLast]\r
{$IFDEF ASM_VERSION}\r
function DelimiterLast( const Str, Delimiters: String ): Integer;\r
asm\r
        CALL     EAX2PChar\r
        CALL     EDX2PChar\r
        PUSH     EAX\r
        CALL     __DelimiterLast\r
        POP      EDX\r
        SUB      EAX, EDX\r
        INC      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function DelimiterLast( const Str, Delimiters: String ): Integer;\r
var PStr: PChar;\r
begin\r
  PStr := PChar( Str );\r
  Result := Integer( __DelimiterLast( PStr, PChar( Delimiters ) ) )\r
          - Integer( PStr )\r
          + 1; // {Viman}\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END DelimiterLast]\r
\r
// Thanks to Marco Bobba - Marisa Bo for this code\r
//[function StrIsStartingFrom]\r
function StrIsStartingFrom( Str, Pattern: PChar ): Boolean;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Str]\r
        MOV     EDX, [Pattern]\r
  {$ENDIF F_P}\r
        XOR     ECX, ECX\r
      @@1:\r
        MOV     CL, [EDX]   // pattern[ i ]\r
        INC     EDX\r
        MOV     CH, [EAX]   // str[ i ]\r
        INC     EAX\r
        JECXZ   @@2         // str = pattern; CL = #0, CH = #0\r
        CMP     CL, CH\r
        JE      @@1\r
      @@2:\r
        TEST    CL, CL\r
        SETZ    AL\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
function StrIsStartingFromNoCase( Str, Pattern: PChar ): Boolean;\r
asm\r
  {$IFDEF F_P}\r
        MOV     EAX, [Str]\r
        MOV     EDX, [Pattern]\r
  {$ENDIF F_P}\r
        XOR     ECX, ECX\r
      @@1:\r
        MOV     CL, [EDX]   // pattern[ i ]\r
        INC     EDX\r
        MOV     CH, [EAX]   // str[ i ]\r
        INC     EAX\r
        JECXZ   @@2         // str = pattern; CL = #0, CH = #0\r
        CMP     CL, 'a'\r
        JB      @@cl_ok\r
        CMP     CL, 'z'\r
        JA      @@cl_ok\r
        SUB     CL, 32\r
      @@cl_ok:\r
        CMP     CH, 'a'\r
        JB      @@ch_ok\r
        CMP     CH, 'z'\r
        JA      @@ch_ok\r
        SUB     CH, 32\r
      @@ch_ok:\r
        CMP     CL, CH\r
        JE      @@1\r
      @@2:\r
        TEST    CL, CL\r
        SETZ    AL\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
\r
{$IFNDEF _FPC}\r
//[FUNCTION Format]\r
{$IFDEF ASM_VERSION}\r
function Format( const fmt: string; params: array of const ): String;\r
asm\r
        PUSH    ESI\r
        PUSH    EDI\r
        PUSH    EBX\r
        MOV     EBX, ESP\r
        ADD     ESP, -2048\r
        MOV     ESI, ESP\r
\r
        INC     ECX\r
        JZ      @@2\r
@@1:\r
        MOV     EDI, [EDX + ECX*8 - 8]\r
        PUSH    EDI\r
        LOOP    @@1\r
@@2:\r
        PUSH    ESP\r
        PUSH    EAX\r
        PUSH    ESI\r
\r
        CALL    wvsprintf\r
\r
        MOV     EDX, ESI\r
        MOV     EAX, @Result\r
        CALL    System.@LStrFromPChar\r
\r
        MOV     ESP, EBX\r
        POP     EBX\r
        POP     EDI\r
        POP     ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Format( const fmt: string; params: array of const ): String;\r
var Buffer: array[ 0..2047 ] of Char;\r
    ElsArray, El: PDWORD;\r
    I : Integer;\r
    P : PDWORD;\r
begin\r
  ElsArray := nil;\r
  if High( params ) >= 0 then\r
    GetMem( ElsArray, (High( params ) + 1) * sizeof( Pointer ) );\r
  El := ElsArray;\r
  for I := 0 to High( params ) do\r
  begin\r
    P := @params[ I ];\r
    P := Pointer( P^ );\r
    El^ := DWORD( P );\r
    Inc( El );\r
  end;\r
  wvsprintf( @Buffer[0], PChar( fmt ), PChar( ElsArray ) );\r
  Result := Buffer;\r
  if ElsArray <> nil then\r
     FreeMem( ElsArray );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Format]\r
\r
//[function LStrFromPWCharLen]\r
function LStrFromPWCharLen(Source: PWideChar; Length: Integer): String;\r
var\r
  DestLen: Integer;\r
  Buffer: array[0..2047] of Char;\r
begin\r
  if Length <= 0 then\r
  begin\r
    //_LStrClr(Result);\r
    Result := '';\r
    Exit;\r
  end;\r
  if Length < SizeOf(Buffer) div 2 then\r
  begin\r
    DestLen := WideCharToMultiByte(0, 0, Source, Length,\r
      Buffer, SizeOf(Buffer), nil, nil);\r
    if DestLen > 0 then\r
    begin\r
      Result := Buffer;\r
      //System.LStrFromPCharLen(Result, Buffer, DestLen);\r
      Exit;\r
    end;\r
  end;\r
  DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil);\r
  // _LStrFromPCharLen(Dest, nil, DestLen);\r
  SetLength( Result, DestLen );\r
  WideCharToMultiByte(0, 0, Source, Length, Pointer(Result), DestLen, nil, nil);\r
end;\r
\r
//[function LStrFromPWChar]\r
function LStrFromPWChar(Source: PWideChar): String;\r
{* from Delphi5 - because D2 does not contain it. }\r
asm\r
        PUSH    EDX\r
        XOR     EDX,EDX\r
        TEST    EAX,EAX\r
        JE      @@5\r
        PUSH    EAX\r
@@0:    CMP     DX,[EAX+0]\r
        JE      @@4\r
        CMP     DX,[EAX+2]\r
        JE      @@3\r
        CMP     DX,[EAX+4]\r
        JE      @@2\r
        CMP     DX,[EAX+6]\r
        JE      @@1\r
        ADD     EAX,8\r
        JMP     @@0\r
@@1:    ADD     EAX,2\r
@@2:    ADD     EAX,2\r
@@3:    ADD     EAX,2\r
@@4:    XCHG    EDX,EAX\r
        POP     EAX\r
        SUB     EDX,EAX\r
        SHR     EDX,1\r
@@5:    POP     ECX\r
        JMP     LStrFromPWCharLen\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
{$ENDIF _FPC}\r
\r
\r
/////////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                          F   I   L   E   S\r
//\r
//\r
/////////////////////////////////////////////////////////////////////////\r
//[FILES]\r
{\r
   This part of the unit modified by Tim Slusher and Vladimir Kladov.\r
}\r
\r
{* Set of utility methods to work with files\r
   and reqistry.\r
   When programming KOL, which is Windows API-oriented, You should\r
   avoid alien (for Windows) embedded Pascal files handling, and\r
   use API-calls which implemented very well. This set of functions\r
   is intended to make this easier.\r
   Also TDirList object implementation present here and some registry\r
   access functions, which allow to make code more elegant.\r
}\r
\r
{$UNDEF ASM_LOCAL}\r
{$IFDEF ASM_VERSION}\r
  {$DEFINE ASM_LOCAL}\r
{$ENDIF ASM_VERSION}\r
\r
//[FUNCTION FileCreate]\r
{$IFDEF ASM_VERSION}\r
function FileCreate( const FileName: string; OpenFlags: DWord): THandle;\r
asm\r
        XOR      ECX, ECX\r
        PUSH     ECX\r
        MOV      ECX, EDX\r
        SHR      ECX, 16\r
        AND      CX, $1FFF\r
        JNZ      @@1\r
        MOV      CL, FILE_ATTRIBUTE_NORMAL\r
@@1:    PUSH     ECX\r
        MOV      CL, DH\r
        PUSH     ECX                  // CreationMode\r
        PUSH     0\r
        MOV      CL, DL\r
        PUSH     ECX                  // ShareMode\r
        MOV      DX, 0\r
        PUSH     EDX                  // AccessMode\r
        //CALL     System.@LStrToPChar // FileName must not be ''\r
        PUSH     EAX\r
        CALL     CreateFile\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FileCreate(const FileName: string; OpenFlags: DWord): THandle;\r
var Attr: DWORD;\r
begin\r
  Attr := (OpenFlags shr 16) and $1FFF;\r
  if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL;\r
  Result := CreateFile( PChar(FileName), OpenFlags and $F0000000,\r
                        OpenFlags and $F, nil, (OpenFlags shr 8) and $F,\r
                        Attr, 0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FileCreate]\r
\r
//[FUNCTION FileClose]\r
{$IFDEF ASM_VERSION}\r
function FileClose( Handle: THandle): Boolean;\r
asm\r
        PUSH     EAX\r
        CALL     CloseHandle\r
        TEST     EAX, EAX\r
        SETNZ    AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FileClose(Handle: THandle): boolean;\r
begin\r
     Result := CloseHandle(Handle);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FileClose]\r
\r
//[FUNCTION FileExists]\r
{$IFDEF ASM_VERSION}\r
function FileExists( const FileName : String ) : Boolean;\r
const size_TWin32FindData = sizeof( TWin32FindData );\r
asm\r
        CALL     EAX2PChar\r
        PUSH     EAX\r
        CALL     GetFileAttributes\r
        INC      EAX\r
        JZ       @@exit\r
        DEC      EAX\r
        {$IFDEF PARANOIA}\r
        DB $24, FILE_ATTRIBUTE_DIRECTORY\r
        {$ELSE}\r
        AND      AL, FILE_ATTRIBUTE_DIRECTORY\r
        {$ENDIF}\r
        SETZ     AL\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FileExists( const FileName : String ) : Boolean;\r
var\r
  Code: Integer;\r
begin\r
  Code := GetFileAttributes(PChar(FileName));\r
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FileExists]\r
\r
//[FUNCTION FileSeek]\r
{$IFDEF ASM_VERSION}\r
function FileSeek( Handle: THandle; MoveTo: integer; MoveMethod: TMoveMethod): DWord;\r
asm\r
        MOVZX    ECX, CL\r
        PUSH     ECX\r
        PUSH     0\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     SetFilePointer\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FileSeek(Handle: THandle; MoveTo: integer; MoveMethod: TMoveMethod): DWord;\r
begin\r
  Result := SetFilePointer(Handle, MoveTo, nil, Ord( MoveMethod ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FileSeek]\r
\r
//[FUNCTION FileRead]\r
{$IFDEF ASM_VERSION}\r
function FileRead( Handle: THandle; var Buffer; Count: DWord): DWord;\r
asm\r
        PUSH     EBP\r
        PUSH     0\r
        MOV      EBP, ESP\r
        PUSH     0\r
        PUSH     EBP\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     ReadFile\r
        TEST     EAX, EAX\r
        POP      EAX\r
        JNZ      @@exit\r
        XOR      EAX, EAX\r
@@exit:\r
        POP      EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;\r
begin\r
     if not ReadFile(Handle, Buffer, Count, Result, nil) then\r
       Result := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FileRead]\r
\r
//[FUNCTION File2Str]\r
{$IFDEF ASM_VERSION}\r
function File2Str( Handle: THandle): String;\r
asm\r
        PUSH     EDX\r
        TEST     EAX, EAX\r
        JZ       @@exit // return ''\r
\r
        PUSH     EBX\r
        MOV      EBX, EAX // EBX = Handle\r
        XOR      EDX, EDX\r
        XOR      ECX, ECX\r
        INC      ECX\r
        CALL     FileSeek\r
        PUSH     EAX // Pos\r
        PUSH     0\r
        PUSH     EBX\r
        CALL     GetFileSize\r
        POP      EDX\r
        SUB      EAX, EDX // EAX = Size - Pos\r
        JZ       @@exitEBX\r
\r
        PUSH     EAX\r
        CALL     System.@GetMem\r
        XCHG     EAX, EBX\r
        MOV      EDX, EBX\r
        POP      ECX\r
        PUSH     ECX\r
        CALL     FileRead\r
        POP      ECX\r
        MOV      EDX, EBX\r
        POP      EBX\r
        POP      EAX\r
        PUSH     EDX\r
        {$IFDEF _D2}\r
        CALL     _LStrFromPCharLen\r
        {$ELSE}\r
        CALL     System.@LStrFromPCharLen\r
        {$ENDIF}\r
        JMP      @@freebuf\r
\r
@@exitEBX:\r
        POP      EBX\r
@@exit:\r
        XCHG     EDX, EAX\r
        POP      EAX // @Result\r
        PUSH     EDX\r
        CALL     System.@LStrFromPChar\r
@@freebuf:\r
        POP      EAX\r
        TEST     EAX, EAX\r
        JZ       @@fin\r
        CALL     System.@FreeMem\r
@@fin:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function File2Str(Handle: THandle): String;\r
var Pos, Size: DWORD;\r
begin\r
  Result := '';\r
  if Handle = 0 then Exit;\r
  Pos := FileSeek( Handle, 0, spCurrent );\r
  Size := GetFileSize( Handle, nil );\r
  SetString( Result, nil, Size - Pos + 1 );\r
  FileRead( Handle, Result[ 1 ], Size - Pos );\r
  Result[ Size - Pos + 1 ] := #0;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END File2Str]\r
\r
//[FUNCTION FileWrite]\r
{$IFDEF ASM_VERSION}\r
function FileWrite( Handle: THandle; const Buffer; Count: DWord): DWord;\r
asm\r
        PUSH     EBP\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
        PUSH     0\r
        PUSH     EBP\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     WriteFile\r
        TEST     EAX, EAX\r
        POP      EAX\r
        JNZ      @@exit\r
        XOR      EAX, EAX\r
@@exit:\r
        POP      EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord;\r
begin\r
     if not WriteFile(Handle, Buffer, Count, Result, nil) then\r
       Result := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FileWrite]\r
\r
//[FUNCTION FileEOF]\r
{$IFDEF ASM_VERSION}\r
function FileEOF( Handle: THandle ) : Boolean;\r
asm\r
        PUSH     EAX\r
\r
        PUSH     0\r
        PUSH     EAX\r
        CALL     GetFileSize\r
\r
        XCHG     EAX, [ESP]\r
\r
        MOV      CL, spCurrent\r
        XOR      EDX, EDX\r
        CALL     FileSeek\r
\r
        POP      EDX\r
        CMP      EAX, EDX\r
        SETGE    AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FileEOF( Handle: THandle ) : Boolean;\r
var Siz, Pos : DWord;\r
begin\r
  Siz := GetFileSize( Handle, nil );\r
  Pos := FileSeek( Handle, 0, spCurrent );\r
  Result := Pos >= Siz;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FileEOF]\r
\r
//[FUNCTION FileFullPath]\r
{$IFDEF ASM_noVERSION}\r
function FileFullPath( const FileName: String ) : String;\r
const\r
  BkSlash: String = '\';\r
  szTShFileInfo = sizeof( TShFileInfo );\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, EDX\r
        PUSH     EAX\r
\r
        XCHG     EAX, EDX\r
        CALL     System.@LStrClr\r
\r
        POP      EDX\r
        PUSH     0\r
        MOV      EAX, ESP\r
        CALL     System.@LStrAsg\r
        MOV      ESI, ESP\r
\r
@@loo:  CMP      dword ptr [ESI], 0\r
        JZ       @@fin\r
\r
        MOV      EAX, ESI\r
        MOV      EDX, [BkSlash]\r
        PUSH     0\r
        MOV      ECX, ESP\r
        CALL     Parse\r
\r
        CMP      dword ptr [EBX], 0\r
        JE       @@1\r
        MOV      EAX, EBX\r
        MOV      EDX, [BkSlash]\r
        CALL     System.@LStrCat\r
        JMP      @@2\r
@@1:\r
        POP      EAX\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        CMP      EAX, 2\r
        JNE      @@2\r
        POP      EAX\r
        PUSH     EAX\r
        CMP      byte ptr [EAX+1], ':'\r
        JNE      @@2\r
\r
        MOV      EAX, EBX\r
        POP      EDX\r
        PUSH     EDX\r
        CALL     System.@LStrAsg\r
        JMP      @@3\r
@@2:\r
        PUSH     0\r
        MOV      EAX, ESP\r
        MOV      EDX, [EBX]\r
        CALL     System.@LStrAsg\r
        MOV      EAX, ESP\r
        MOV      EDX, [ESP+4]\r
        CALL     System.@LStrCat\r
        POP      EAX\r
        PUSH     EAX\r
        SUB      ESP, szTShFileInfo\r
        MOV      EDX, ESP\r
        PUSH     SHGFI_DISPLAYNAME\r
        PUSH     szTShFileInfo\r
        PUSH     EDX\r
        PUSH     0\r
        PUSH     EAX\r
        CALL     ShGetFileInfo\r
        LEA      EDX, [ESP].TShFileInfo.szDisplayName\r
        CMP      byte ptr [EDX], 0\r
        JE       @@clr_stk\r
        LEA      EAX, [ESP+szTShFileInfo+4]\r
        CALL     System.@LStrFromPChar\r
@@clr_stk:\r
        ADD      ESP, szTShFileInfo\r
        CALL     RemoveStr\r
        POP      EDX\r
        PUSH     EDX\r
        MOV      EAX, EBX\r
        CALL     System.@LStrCat\r
\r
@@3:    CALL     RemoveStr\r
        JMP      @@loo\r
\r
@@fin:  CALL     RemoveStr\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FileFullPath( const FileName: String ) : String;\r
var SFI: TShFileInfo;\r
    Src, S: String;\r
begin\r
  Result := '';\r
  Src := FileName;\r
  while Src <> '' do\r
  begin\r
    S := Parse( Src, '\' );\r
    if Result <> '' then\r
      Result := Result + '\';\r
    if (Result = '') and (Length( S ) = 2) and (S[ 2 ] = ':') then\r
      Result := S\r
    else\r
    begin\r
      ShGetFileInfo( PChar( Result + S ), 0, SFI, Sizeof( SFI ),\r
                     SHGFI_DISPLAYNAME );\r
      if SFI.szDisplayName[ 0 ] <> #0 then\r
        S := SFI.szDisplayName;\r
      Result := Result + S;\r
    end;\r
  end;\r
  if ExtractFileExt( Result ) = '' then\r
  // case when flag 'Hide extensions for registered file types' is set on\r
  // in the Explorer:\r
    Result := Result + ExtractFileExt( FileName );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FileFullPath]\r
\r
//[function FileShortPath]\r
function FileShortPath( const FileName: String ): String;\r
var Buf: array[ 0..MAX_PATH ] of Char;\r
begin\r
  GetShortPathName( PChar( FileName ), Buf, Sizeof( Buf ) );\r
  Result := Buf;\r
end;\r
\r
//[function FileIconSystemIdx]\r
function FileIconSystemIdx( const Path: String ): Integer;\r
var SFI: TShFileInfo;\r
begin\r
  SFI.iIcon := 0; // Bartov\r
  ShGetFileInfo( PChar( Path ), 0, SFI, sizeof( SFI ),\r
                 //-- Babenko Alexey: -----------------//\r
                 // SHGFI_ICON or                     //\r
                 //----------------------------------//\r
                 SHGFI_SMALLICON or SHGFI_SYSICONINDEX );\r
  Result := SFI.iIcon;\r
end;\r
\r
//[function FileIconSysIdxOffline]\r
function FileIconSysIdxOffline( const Path: String ): Integer;\r
var SFI: TShFileInfo;\r
begin\r
  SFI.iIcon := 0; // Bartov\r
  ShGetFileInfo( PChar( Path ), FILE_ATTRIBUTE_NORMAL, SFI, sizeof( SFI ),\r
                 //-- Babenko Alexey: -----------------//\r
                 //SHGFI_ATTRIBUTES or SHGFI_ICON or //\r
                 //----------------------------------//\r
                 SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES );\r
  Result := SFI.iIcon;\r
end;\r
\r
//[procedure LogFileOutput]\r
procedure LogFileOutput( const filepath, str: String );\r
var F: HFile;\r
begin\r
  F := FileCreate( filepath, ofOpenWrite or ofOpenAlways );\r
  if F = INVALID_HANDLE_VALUE then Exit;\r
  FileSeek( F, 0, spEnd );\r
  FileWrite( F, {$IFNDEF _D2} String {$ENDIF}\r
             ( str + #13#10 )[ 1 ], Length( str ) + 2 );\r
  FileClose( F );\r
end;\r
\r
//[function StrSaveToFile]\r
function StrSaveToFile( const Filename, Str: String ): Boolean;\r
begin\r
  Result := Mem2File( PChar( Filename ), PChar( Str ), Length( Str ) )\r
            = Length( Str );\r
end;\r
\r
//[function StrLoadFromFile]\r
function StrLoadFromFile( const Filename: String ): String;\r
var F: HFile;\r
begin\r
  Result := '';\r
  F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );\r
  if F = INVALID_HANDLE_VALUE then Exit;\r
  Result := File2Str( F );\r
  FileClose( F ); {??ee(zhog); Dark Knight}\r
end;\r
\r
//[function Mem2File]\r
function Mem2File( Filename: PChar; Mem: Pointer; Len: Integer ): Integer;\r
var F: HFile;\r
begin\r
  Result := 0;\r
  F := FileCreate( Filename, ofOpenWrite or ofOpenAlways );\r
  if F = INVALID_HANDLE_VALUE then Exit;\r
  Result := FileWrite( F, Mem^, Len );\r
  FileClose( F );\r
end;\r
\r
//[function File2Mem]\r
function File2Mem( Filename: PChar; Mem: Pointer; MaxLen: Integer ): Integer;\r
var F: HFile;\r
begin\r
  Result := 0;\r
  F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );\r
  if F = INVALID_HANDLE_VALUE then Exit;\r
  Result := FileRead( F, Mem^, MaxLen );\r
  FileClose( F );\r
end;\r
\r
//[FUNCTION DirectoryExists]\r
{$IFDEF ASM_VERSION}\r
function DirectoryExists( const Name: string): Boolean;\r
asm\r
        //CALL     System.@LStrToPChar // Name must not be ''\r
        PUSH     EAX\r
        CALL     GetFileAttributes\r
        INC      EAX\r
        JZ       @@exit\r
        DEC      EAX\r
        {$IFDEF PARANOIA}\r
        DB $24, FILE_ATTRIBUTE_DIRECTORY\r
        {$ELSE}\r
        AND      AL, FILE_ATTRIBUTE_DIRECTORY\r
        {$ENDIF}\r
        SETNZ    AL\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function DirectoryExists(const Name: string): Boolean;\r
var\r
  Code: Integer;\r
begin\r
  Code := GetFileAttributes(PChar(Name));\r
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END DirectoryExists]\r
\r
//[function CheckDirectoryContent]\r
function CheckDirectoryContent( const Name: String; SubDirsOnly: Boolean; const Mask: String ): Boolean;\r
var FD: TWin32FindData;\r
    FH: THandle;\r
begin\r
  if not DirectoryExists( Name ) then\r
    Result := TRUE\r
  else\r
  begin\r
    FH := Windows.FindFirstFile( PChar( IncludeTrailingPathDelimiter( Name )\r
       + Mask ), FD );\r
    if FH = INVALID_HANDLE_VALUE then\r
      Result := TRUE\r
    else\r
    begin\r
      Result := TRUE;\r
      repeat\r
        if not StrIn( FD.cFileName, ['.','..'] ) then\r
        begin\r
          if SubDirsOnly and LongBool(FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)\r
             or not SubDirsOnly then\r
          begin\r
            Result := FALSE;\r
            break;\r
          end;\r
        end;\r
      until not Windows.FindNextFile( FH, FD );\r
      Windows.FindClose( FH );\r
    end;\r
  end;\r
end;\r
\r
//[function DirectoryEmpty]\r
function DirectoryEmpty(const Name: String): Boolean;\r
begin\r
  Result := CheckDirectoryContent( Name, FALSE, '*.*' );\r
end;\r
\r
{-}\r
//[function DirectorySize]\r
function DirectorySize( const Path: String ): I64;\r
var DirList: PDirList;\r
    I: Integer;\r
begin\r
  Result := MakeInt64( 0, 0 );\r
  DirList := NewDirList( Path, '*.*', 0 );\r
  for I := 0 to DirList.Count-1 do\r
  begin\r
    if LongBool( DirList.Items[ I ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY ) then\r
      Result := Add64( Result, DirectorySize( DirList.Path + DirList.Names[ I ] ) )\r
    else\r
      Result := Add64( Result, MakeInt64( DirList.Items[ I ].nFileSizeLow,\r
             DirList.Items[ I ].nFileSizeHigh ) );\r
  end;\r
  DirList.Free;\r
end;\r
{+}\r
\r
//[function DirectoryHasSubdirs]\r
function DirectoryHasSubdirs( const Path: String ): Boolean;\r
begin\r
  Result := not CheckDirectoryContent( Path, TRUE, '*.*' );\r
end;\r
\r
//[function GetFileList]\r
function GetFileList(const dir: string): PStrList;\r
var\r
   Srch: TWin32FindData;\r
   flag: Integer;\r
   succ: boolean;\r
begin\r
   result := nil;\r
   flag := FindFirstFile(PChar(dir), Srch);\r
   //succ := flag <> 0; //---------------------------------------\r
   succ := flag <> Integer(INVALID_HANDLE_VALUE); // M.V.Chirikov\r
   while succ do begin\r
      if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin\r
         if Result = nil then begin\r
            Result := NewStrList;\r
         end;\r
         Result.Add(Srch.cFileName);\r
      end;\r
      succ := FindNextFile(Flag, Srch);\r
   end;\r
   FindClose(Flag);\r
end;\r
\r
//[function ExcludeTrailingChar]\r
function ExcludeTrailingChar( const S: String; C: Char ): String;\r
begin\r
  Result := S;\r
  if Result <> '' then\r
  if Result[ Length( Result ) ] = C then\r
    Delete( Result, Length( Result ), 1 );\r
end;\r
\r
//[function IncludeTrailingChar]\r
function IncludeTrailingChar( const S: String; C: Char ): String;\r
begin\r
  Result := S;\r
  if (Result = '') or (Result[ Length( Result ) ] <> C) then\r
    Result := Result + C;\r
end;\r
\r
//---------------------------------------------------------\r
// Following functions/procedures are created by Edward Aretino:\r
// IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter,\r
// ForceDirectories, CreateDir, ChangeFileExt\r
//---------------------------------------------------------\r
//[function IncludeTrailingPathDelimiter]\r
function IncludeTrailingPathDelimiter(const S: string): string;\r
begin\r
   {if CopyTail(S, 1) <> '\' then\r
     Result := S + '\'\r
   else\r
     Result := S;}\r
   Result := IncludeTrailingChar( S, '\' );\r
end;\r
\r
//[function ExcludeTrailingPathDelimiter]\r
function ExcludeTrailingPathDelimiter(const S: string): string;\r
begin\r
   {Result := S;\r
   if Length(Result) = 0 then Exit;\r
\r
   if (CopyTail(Result, 1) = '\') then\r
     DeleteTail(Result, 1);}\r
   Result := ExcludeTrailingChar( S, '\' );\r
end;\r
\r
//[function ForceDirectories]\r
function ForceDirectories(Dir: string): Boolean;\r
begin\r
 Result := Length(Dir) > 0; {Centronix}\r
 If not Result then Exit;\r
 Dir := ExcludeTrailingPathDelimiter(Dir);\r
 If (Length(Dir) < 3) or DirectoryExists(Dir) or\r
   (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.\r
 Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);\r
end;\r
\r
//[function CreateDir]\r
function CreateDir(const Dir: string): Boolean;\r
begin\r
   Result := Windows.CreateDirectory(PChar(Dir), nil);\r
end;\r
\r
//[function ChangeFileExt]\r
function ChangeFileExt(FileName: String; const Extension: string): string;\r
var\r
   FileExt: String;\r
begin\r
   FileExt := ExtractFileExt(FileName);\r
   DeleteTail(FileName, Length(FileExt));\r
   Result := FileName+ Extension;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
{$IFNDEF _D2}\r
{$DEFINE ASM_LStrFromPCharLen}\r
{$ENDIF}\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_LStrFromPCharLen}\r
  {$DEFINE ASM_DIRDelimiters}\r
{$ENDIF}\r
\r
{$IFDEF ASM_VERSION}\r
  {$DEFINE ASM_DIRDelimiters}\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_DIRDelimiters}\r
const\r
  DirDelimiters: PChar = ':\';\r
{$ENDIF}\r
\r
//[FUNCTION ExtractFileName]\r
{$IFDEF ASM_VERSION}\r
function ExtractFileName( const Path : String ) : String;\r
asm\r
        PUSH     EDX\r
        PUSH     EAX\r
        MOV      EDX, [DirDelimiters]\r
        CALL     __DelimiterLast\r
        POP      EDX\r
        CMP      byte ptr [EAX], 0\r
        JZ       @@1\r
        XCHG     EDX, EAX\r
        INC      EDX\r
@@1:    POP      EAX\r
        CALL     System.@LStrFromPChar\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function ExtractFileName( const Path : String ) : String;\r
var P: PChar;\r
begin\r
  P := __DelimiterLast( PChar( Path ), ':\' );\r
  if P^ = #0 then\r
    Result := Path\r
  else\r
    Result := P + 1;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END ExtractFileName]\r
\r
//[FUNCTION ExtractFilePath]\r
{$IFDEF ASM_LStrFromPCharLen} // LStrFromPCharLen - there are no in D2\r
function ExtractFilePath( const Path : String ) : String;\r
asm\r
        PUSH     EDX\r
        MOV      EDX, [DirDelimiters]\r
        CALL     EAX2PChar\r
        PUSH     EAX\r
        CALL     __DelimiterLast\r
        XCHG     EDX, EAX\r
        XOR      ECX, ECX\r
        POP      EAX\r
        CMP      byte ptr [EDX], CL\r
        JZ       @@ret_0\r
        SUB      EDX, EAX\r
        INC      EDX\r
        XCHG     EDX, EAX\r
        XCHG     ECX, EAX\r
@@ret_0:\r
        POP      EAX\r
        CALL     System.@LStrFromPCharLen\r
end;\r
{$ELSE} //Pascal\r
function ExtractFilePath( const Path : String ) : String;\r
//var I : Integer;\r
var P, P0: PChar;\r
begin\r
  P0 := PChar( Path );\r
  P := __DelimiterLast( P0, ':\' );\r
  if P^ = #0 then\r
    Result := ''\r
  else\r
    Result := Copy( Path, 1, P - P0 + 1 );\r
end;\r
{$ENDIF}\r
\r
//[function ExtractFileNameWOext]\r
function ExtractFileNameWOext( const Path : String ) : String;\r
begin\r
  Result := ExtractFileName( Path );\r
  Result := Copy( Result, 1, Length( Result ) - Length( ExtractFileExt( Result ) ) );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
const\r
  ExtDelimeters: PChar = '.';\r
\r
//[function ExtractFileExt]\r
function ExtractFileExt( const Path : String ) : String;\r
asm\r
        PUSH     EDX\r
        MOV      EDX, [ExtDelimeters]\r
        CALL     EAX2PChar\r
        CALL     __DelimiterLast\r
@@1:    XCHG     EDX, EAX\r
        POP      EAX\r
        CALL     System.@LStrFromPChar\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function ExtractFileExt( const Path : String ) : String;\r
var P: PChar;\r
begin\r
  P := __DelimiterLast( PChar( Path ), '.' );\r
  Result := P;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END ExtractFilePath]\r
\r
//[function ReplaceFileExt]\r
function ReplaceFileExt( const Path, NewExt: String ): String;\r
begin\r
  Result := ExtractFilePath( Path ) +\r
            ExtractFileNameWOext( ExtractFileName( Path ) ) +\r
            NewExt;\r
end;\r
\r
//[function ExtractShortPathName]\r
function ExtractShortPathName( const Path: String ): String;\r
var\r
  Buffer: array[0..MAX_PATH - 1] of Char;\r
begin\r
  SetString(Result, Buffer,\r
    GetShortPathName(PChar(Path), Buffer, SizeOf(Buffer)));\r
end;\r
\r
//[function FilePathShortened]\r
function FilePathShortened( const Path: String; MaxLen: Integer ): String;\r
begin\r
  Result := FilePathShortenPixels( Path, 0, MaxLen );\r
end;\r
\r
//[function PixelsLength]\r
function PixelsLength( DC: HDC; const Text: String ): Integer;\r
var Sz: TSize;\r
begin\r
  if DC = 0 then\r
    Result := Length( Text )\r
  else\r
  begin\r
    Windows.GetTextExtentPoint32( DC, PChar( Text ), Length( Text ), Sz );\r
    Result := Sz.cx;\r
  end;\r
end;\r
\r
//[function FilePathShortenPixels]\r
function FilePathShortenPixels( const Path: String; DC: HDC; MaxPixels: Integer ): String;\r
var L0, L1: Integer;\r
    Prev: String;\r
begin\r
 Result := Path;\r
 L0 := PixelsLength( DC, Result );\r
 while L0 > MaxPixels do\r
 begin\r
   Prev := Result;\r
   L1 := pos( '\...\', Result );\r
   if L1 <= 0 then\r
     Result := ExcludeTrailingPathDelimiter( ExtractFilePath( Result ) )\r
   else\r
     Result := Copy( Result, 1, L1 - 1 );\r
   if Result <> '' then\r
     Result := IncludeTrailingPathDelimiter( ExtractFilePath( Result ) ) + '...\' + ExtractFileName( Path );\r
   if (Result = '') or (Result = Prev) then\r
   begin\r
     L1 := Length( ExtractFilePath( Result ) );\r
     while (PixelsLength( DC, Result ) > MaxPixels) and (L1 > 1) do\r
     begin\r
       Dec( L1 );\r
       Result := Copy( Result, 1, L1 ) + '...\' + ExtractFileName( Result );\r
     end;\r
     if PixelsLength( DC, Result ) > MaxPixels then\r
     begin\r
       L1 := MaxPixels + 1;\r
       while ((MaxPixels > 0) and (L1 > 1) or (MaxPixels = 0) and (L1 > 0)) and\r
             (PixelsLength( DC, Result ) > MaxPixels) do\r
       begin\r
         Dec( L1 );\r
         Result := Copy( ExtractFileName( Path ), 1, L1 ) + '...';\r
       end;\r
     end;\r
     break;\r
   end;\r
   L0 := PixelsLength( DC, Result );\r
 end;\r
end;\r
\r
//[procedure CutFirstDirectory]\r
procedure CutFirstDirectory(var S: String);\r
var\r
  Root: Boolean;\r
  P: Integer;\r
begin\r
  if S = '\' then\r
    S := ''\r
  else\r
  begin\r
    if S[1] = '\' then\r
    begin\r
      Root := True;\r
      Delete(S, 1, 1);\r
    end\r
    else\r
      Root := False;\r
    if S[1] = '.' then\r
      Delete(S, 1, 4);\r
    P := pos('\',S);\r
    if P <> 0 then\r
    begin\r
      Delete(S, 1, P);\r
      S := '...\' + S;\r
    end\r
    else\r
      S := '';\r
    if Root then\r
      S := '\' + S;\r
  end;\r
end;\r
\r
//[function MinimizeName]\r
function MinimizeName( const Path: String; DC: HDC; MaxPixels: Integer ): String;\r
var\r
  Drive, Dir, Name: String;\r
begin\r
  Result := Path;\r
  Dir := ExtractFilePath(Result);\r
  Name := ExtractFileName(Result);\r
\r
  if (Length(Dir) >= 2) and (Dir[2] = ':') then\r
  begin\r
    Drive := Copy(Dir, 1, 2);\r
    Delete(Dir, 1, 2);\r
  end\r
  else\r
    Drive := '';\r
  while ((Dir <> '') or (Drive <> '')) and (PixelsLength(DC, Result) > MaxPixels) do\r
  begin\r
    if Dir = '\...\' then\r
    begin\r
      Drive := '';\r
      Dir := '...\';\r
    end\r
    else if Dir = '' then\r
      Drive := ''\r
    else\r
      CutFirstDirectory(Dir);\r
    Result := Drive + Dir + Name;\r
  end;\r
end;\r
\r
//[FUNCTION FileSize]\r
{$IFDEF ASM_VERSION}\r
function FileSize( const Path : String ) : Integer;\r
const size_TWin32FindData = sizeof( TWin32FindData );\r
asm\r
        ADD      ESP, - size_TWin32FindData\r
        PUSH     ESP\r
        //CALL     System.@LStrToPChar // Path must not be ''\r
        PUSH     EAX\r
        CALL     FindFirstFile\r
        INC      EAX\r
        JZ       @@exit\r
        DEC      EAX\r
        PUSH     EAX\r
        CALL     FindClose\r
\r
        MOV      EAX, [ESP].TWin32FindData.nFileSizeLow\r
@@exit:\r
        ADD      ESP, size_TWin32FindData\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FileSize( const Path : String ) : Integer;\r
var FD : TWin32FindData;\r
    FH : THandle;\r
begin\r
  FH := FindFirstFile( PChar( Path ), FD );\r
  Result := 0;\r
  if FH = INVALID_HANDLE_VALUE then exit;\r
  Result := FD.nFileSizeLow;\r
  if ((FD.nFileSizeLow and $80000000) <> 0) or\r
     (FD.nFileSizeHigh <> 0) then Result := -1;\r
  FindClose( FH );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FileSize]\r
\r
//*\r
//[function FileTimeCompare]\r
function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;\r
var ST1, ST2 : TSystemTime;\r
begin\r
  FileTimeToSystemTime( FT1, ST1 );\r
  FileTimeToSystemTime( FT2, ST2 );\r
  Result := CompareSystemTime( ST1, ST2 );\r
end;\r
\r
//[function GetSystemDir]\r
function GetSystemDir: String;\r
var Buf: array[ 0..MAX_PATH ] of Char;\r
begin\r
  GetSystemDirectory( @ Buf[ 0 ], MAX_PATH + 1 );\r
  Result := IncludeTrailingPathDelimiter( PChar( @ Buf[ 0 ] ) );\r
end;\r
\r
//*\r
//[function GetWindowsDir]\r
function GetWindowsDir : string;\r
var Buf : array[ 0..MAX_PATH ] of Char;\r
begin\r
  GetWindowsDirectory( @Buf[ 0 ], MAX_PATH + 1 );\r
  Result := IncludeTrailingPathDelimiter( PChar( @ Buf[ 0 ] ) );\r
end;\r
\r
//[function GetWorkDir]\r
function GetWorkDir : string;\r
var Buf: array[ 0..MAX_PATH ] of Char;\r
begin\r
  GetCurrentDirectory( MAX_PATH + 1, @ Buf[ 0 ] );\r
  Result := IncludeTrailingPathDelimiter( PChar( @ Buf[ 0 ] ) );\r
end;\r
\r
//*\r
//[function GetTempDir]\r
function GetTempDir : string;\r
var Buf : array[ 0..MAX_PATH ] of Char;\r
begin\r
  Windows.GetTempPath( MAX_PATH + 1, @Buf[ 0 ] );\r
  Result := IncludeTrailingPathDelimiter( PChar( @ Buf[ 0 ] ) );\r
end;\r
\r
//[function CreateTempFile]\r
function CreateTempFile( const DirPath, Prefix: String ): String;\r
var Buf: array[ 0..MAX_PATH ] of Char;\r
begin\r
  GetTempFileName( PChar( DirPath ), PChar( Prefix ), 0, Buf );\r
  Result := Buf;\r
end;\r
\r
//[function GetFileListStr]\r
function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: string): string;\r
{* List of files in string, separating each path from others with semicolon (';').\r
   E.g.: 'c:\tmp\unit1.dcu;c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}\r
var\r
   Srch: TWin32FindData;\r
   flag: Integer;\r
   succ: boolean;\r
   dir:string;\r
begin\r
   result := '';\r
   if (FPath<>'') and (FPath[length(FPath)]<>'\') then FPath:=FPath+'\';\r
   if (FMask<>'') and (FMask[1]='\') then FMask:=CopyEnd(FMask,2);\r
   dir:=FPath+FMask;\r
   flag := FindFirstFile(PChar(dir), Srch);\r
   succ := flag <> 0;\r
   while succ do begin\r
      if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin\r
         if Result<>''then Result:=Result+';';\r
         Result:=Result+FPath+Srch.cFileName;\r
      end;\r
      succ := FindNextFile(Flag, Srch);\r
   end;\r
   FindClose(Flag);\r
end;\r
\r
//[function DeleteFiles]\r
function DeleteFiles( const DirPath: String ): Boolean;\r
var Files, Name: String;\r
begin\r
  Files := GetFileListStr( ExtractFilePath( DirPath ), ExtractFileName( DirPath ) );\r
  Result := TRUE;\r
  while Files <> '' do\r
  begin\r
    Name := Parse( Files, ';' );\r
    Result := Result and DeleteFile( PChar( Name ) );\r
  end;\r
end;\r
\r
//*\r
//[function DeleteFile2Recycle]\r
function DeleteFile2Recycle( const Filename : String ) : Boolean;\r
var FOS : TSHFileOpStruct;\r
    Buf : PChar;\r
    L : Integer;\r
begin\r
  L := Length( Filename );\r
  GetMem( Buf, L + 2 );\r
  StrCopy( Buf, PChar( Filename ) );\r
  Buf[ L + 1 ] := #0;\r
  for L := L downto 0 do\r
    if Buf[ L ] = ';' then Buf[ L ] := #0;\r
  FillChar( FOS, Sizeof( FOS ), 0 );\r
  if Applet <> nil then\r
    FOS.Wnd := Applet.Handle;\r
  FOS.wFunc := FO_DELETE;\r
  FOS.pFrom := Buf;\r
  FOS.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;\r
  FOS.fAnyOperationsAborted := True;\r
  FOS.lpszProgressTitle := PChar( 'Delete ' + Filename + ' to Recycle bin' );\r
  Result := SHFileOperation( FOS ) = 0;\r
  if Result then\r
    Result := not FOS.fAnyOperationsAborted;\r
  FreeMem( Buf );\r
end;\r
\r
//[function CopyMoveFiles]\r
function CopyMoveFiles( const FromList, ToList: String; Move: Boolean ): Boolean;\r
var FOS : TSHFileOpStruct;\r
    Buf : PChar;\r
    L : Integer;\r
begin\r
  L := Length( FromList );\r
  GetMem( Buf, L + 2 );\r
  StrCopy( Buf, PChar( FromList ) );\r
  Buf[ L + 1 ] := #0;\r
  for L := L downto 0 do\r
    if Buf[ L ] = ';' then Buf[ L ] := #0;\r
  FillChar( FOS, Sizeof( FOS ), 0 );\r
  if Applet <> nil then\r
    FOS.Wnd := Applet.Handle;\r
  if Move then\r
  begin\r
    FOS.wFunc := FO_MOVE;\r
    FOS.lpszProgressTitle := PChar( 'Move files' );\r
  end\r
    else\r
  begin\r
    FOS.wFunc := FO_COPY;\r
    FOS.lpszProgressTitle := PChar( 'Copy files' );\r
  end;\r
  FOS.pFrom := Buf;\r
  FOS.pTo := PChar( ToList + #0 );\r
  FOS.fFlags := FOF_ALLOWUNDO;\r
  FOS.fAnyOperationsAborted := True;\r
  Result := SHFileOperation( FOS ) = 0;\r
  if Result then\r
    Result := not FOS.fAnyOperationsAborted;\r
  FreeMem( Buf );\r
end;\r
\r
{-}\r
//[function DiskFreeSpace]\r
function DiskFreeSpace( const Path: String ): I64;\r
type TGetDFSEx = function( Path: PChar; CallerFreeBytes, TotalBytes, FreeBytes: Pointer )\r
                 : Bool; stdcall;\r
var GetDFSEx: TGetDFSEx;\r
    Kern32: THandle;\r
    V: TOSVersionInfo;\r
    Ex: Boolean;\r
    SpC, BpS, NFC, TNC: DWORD;\r
    FBA, TNB: I64;\r
begin\r
  GetDFSEx := nil;\r
  V.dwOSVersionInfoSize := Sizeof( V );\r
  GetVersionEx( V );\r
  Ex := FALSE;\r
  if V.dwPlatformId = VER_PLATFORM_WIN32_NT then\r
  begin\r
    Ex := V.dwMajorVersion >= 4;\r
  end\r
    else\r
  if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then\r
  begin\r
    Ex := V.dwMajorVersion > 4;\r
    if not Ex then\r
    if V.dwMajorVersion = 4 then\r
    begin\r
      Ex := V.dwMinorVersion > 0;\r
      if not Ex then\r
        Ex := LoWord( V.dwBuildNumber ) >= $1111;\r
    end;\r
  end;\r
  if Ex then\r
  begin\r
    Kern32 := GetModuleHandle( 'kernel32.dll' );\r
    GetDFSEx := GetProcAddress( Kern32, 'GetDiskFreeSpaceExA' );\r
  end;\r
  if Assigned( GetDFSEx ) then\r
    GetDFSEx( PChar( Path ), @ FBA, @ TNB, @Result )\r
  else\r
  begin\r
    GetDiskFreeSpace( PChar( Path ), SpC, BpS, NFC, TNC );\r
    Result := Mul64i( MakeInt64( SpC * BpS, 0 ), NFC );\r
  end;\r
end;\r
{+}\r
\r
//*\r
//[function GetUniqueFilename]\r
function GetUniqueFilename( PathName: string ) : String;\r
var Path, Nam, Ext : String;\r
    I, J, K : Integer;\r
begin\r
  Result := PathName;\r
  Path := ExtractFilePath( PathName );\r
  if not DirectoryExists( Path ) then Exit;\r
  Nam := ExtractFileNameWOext( PathName );\r
  if Nam = '' then\r
  begin\r
    if Path[ Length( Path ) ] = '\' then\r
       Path := Copy( Path, 1, Length( Path ) - 1 );\r
    PathName := Path;\r
    Result := Path;\r
  end;\r
  Nam := ExtractFileNameWOext( PathName );\r
  Ext := ExtractFileExt( PathName );\r
  I := Length( Nam );\r
  for J := I downto 1 do\r
  if not (Nam[ J ] in [ '0'..'9' ]) then\r
  begin\r
    I := J;\r
    break;\r
  end;\r
  K := Str2Int( CopyEnd( Nam, I + 1 ) );\r
  while FileExists( Result ) do\r
  begin\r
    Inc( K );\r
    Result := Path + Copy( Nam, 1, I ) + Int2Str( K ) + Ext;\r
  end;\r
end;\r
\r
//[FUNCTION GetStartDir]\r
{$IFDEF ASM_VERSION}\r
function GetStartDir : String;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        XOR      EAX, EAX\r
        MOV      AH, 2\r
        SUB      ESP, EAX\r
        MOV      EDX, ESP\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     0\r
        CALL     GetModuleFileName\r
\r
        LEA      EDX, [ESP + EAX]\r
@@1:    DEC      EDX\r
        CMP      byte ptr [EDX], '\'\r
        JNZ      @@1\r
\r
        INC      EDX\r
        MOV      byte ptr [EDX], 0\r
\r
        MOV      EAX, EBX\r
        MOV      EDX, ESP\r
        CALL     System.@LStrFromPChar\r
\r
        ADD      ESP, 200h\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function GetStartDir : String;\r
var Buffer:array[0..260] of Char;\r
    I : Integer;\r
begin\r
  I := GetModuleFileName( 0, Buffer, Sizeof( Buffer ) );\r
  for I := I downto 0 do\r
    if Buffer[ I ] = '\' then\r
    begin\r
      Buffer[ I + 1 ] := #0;\r
      break;\r
    end;\r
  Result := Buffer;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END GetStartDir]\r
\r
//[END FILES]\r
\r
\r
\r
{ TDirList }\r
\r
//[function NewDirList]\r
function NewDirList( const DirPath, Filter: String; Attr: DWORD ): PDirList;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PDirList.Create;*){--}\r
  Result.ScanDirectory( DirPath, Filter, Attr );\r
end;\r
//[END NewDirList]\r
\r
//[function NewDirListEx]\r
function NewDirListEx( const DirPath, Filters: String; Attr: DWORD ): PDirList;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PDirList.Create;*){--}\r
  Result.ScanDirectoryEx( DirPath, Filters, Attr );\r
end;\r
//[END NewDirListEx]\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TDirList.Clear]\r
procedure TDirList.Clear;\r
asm\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EAX].fList\r
        JECXZ    @@exit\r
        XCHG     EAX, ECX\r
        CALL     TList.Release\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TDirList.Clear;\r
begin\r
  if FList <> nil then\r
    FList.Release;\r
  FList := nil;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TDirList.Destroy]\r
destructor TDirList.Destroy;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CALL     Clear\r
        LEA      EAX, [EBX].FPath\r
        CALL     System.@LStrClr\r
        XCHG     EAX, EBX\r
        CALL     TObj.Destroy\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TDirList.Destroy;\r
begin\r
  Clear;\r
  FPath := '';\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[FUNCTION FindFilter]\r
{$IFDEF ASM_VERSION}\r
function FindFilter( const Filter: String): String;\r
asm\r
        XCHG     EAX, EDX\r
        PUSH     EAX\r
        CALL     System.@LStrAsg\r
        POP      EAX\r
        CMP      dword ptr [EAX], 0\r
        JNE      @@exit\r
        LEA      EDX, @@mask_all\r
        JE       System.@LStrFromPChar\r
@@mask_all:  DB  '*.*',0\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function FindFilter(const Filter: String): String;\r
begin\r
  Result := Filter;\r
  if Result = '' then Result := '*.*';\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FindFilter]\r
\r
//+\r
//[function TDirList.Get]\r
function TDirList.Get(Idx: Integer): PWin32FindData;\r
begin\r
  Result := FList.fItems[ Idx ];\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TDirList.GetCount]\r
function TDirList.GetCount: Integer;\r
asm\r
        MOV      EAX, [EAX].fList\r
        TEST     EAX, EAX\r
        {$IFDEF USE_CMOV}\r
        CMOVNZ   EAX, [EAX].TList.fCount\r
        {$ELSE}\r
        JZ       @@exit\r
        MOV      EAX, [EAX].TList.fCount\r
@@exit: {$ENDIF}\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TDirList.GetCount: Integer;\r
begin\r
  Result := 0;\r
  if FList = nil then Exit;\r
  Result := FList.Count;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TDirList.GetNames]\r
function TDirList.GetNames(Idx: Integer): string;\r
asm\r
        MOV      EAX, [EAX].fList\r
        MOV      EAX, [EAX].TList.fItems\r
        MOV      EDX, [EAX + EDX*4]\r
//*/////////////////////////////////////////////////////\r
//      ADD      EDX, TWin32FindData.cFileName\r
//*/////////////////////////////////////////////////////\r
        ADD      EDX, offset TWin32FindData.cFileName //\r
//*/////////////////////////////////////////////////////\r
        MOV      EAX, ECX\r
        CALL     System.@LStrFromPChar\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TDirList.GetNames(Idx: Integer): string;\r
begin\r
  Result := PChar(@PWin32FindData(fList.fItems[ Idx ]).cFileName[0]);\r
  //Result := PChar(@Items[Idx].cFileName[0]);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TDirList.GetIsDirectory]\r
function TDirList.GetIsDirectory(Idx: Integer): Boolean;\r
begin\r
  Result := LongBool( Items[ Idx ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY );\r
end;\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TDirList.SatisfyFilter]\r
function TDirList.SatisfyFilter(FileName: PChar; FileAttr,\r
  FindAttr: DWord): Boolean;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        XCHG     EBX, EAX // EBX = @ Self\r
        MOV      EAX, [FindAttr]\r
        MOV      EDI, EDX // EDI = FileName\r
        MOV      EDX, EAX\r
        AND      EDX, ECX\r
        CMP      EDX, EAX\r
        JE       @@1\r
\r
        TEST AL, FILE_ATTRIBUTE_NORMAL\r
        JZ      @@ret_false\r
@@1:\r
        CMP      word ptr [EDI], '.'\r
        JE       @@1_1\r
        CMP      word ptr [EDI], '..'\r
        JNE      @@1_1\r
        CMP      byte ptr [EDI+2], 0\r
        JNE      @@1_1\r
@@1_0:\r
        MOV      ECX, [FindAttr]\r
        TEST     CL, FILE_ATTRIBUTE_NORMAL\r
        JZ       @@1_1\r
        CMP      ECX, FILE_ATTRIBUTE_NORMAL\r
        JE       @@1_1\r
        TEST     AL, FILE_ATTRIBUTE_DIRECTORY\r
        JZ       @@1_1\r
        TEST     CL, FILE_ATTRIBUTE_DIRECTORY\r
        JNZ      @@ret_true\r
\r
@@1_1:\r
        MOV      ECX, [EBX].fFilters\r
        JECXZ    @@ret_false //?\r
\r
        MOV      ESI, [ECX].TStrList.fList\r
        MOV      ESI, [ESI].TList.fItems\r
        MOV      ECX, [ECX].TStrList.fCount\r
        JECXZ    @@ret_false\r
\r
@@2:\r
        LODSD\r
        TEST     EAX, EAX\r
        JZ       @@nx_filter\r
\r
        PUSHAD\r
\r
        MOV      EDX, [EAX]\r
        CMP      DX, $002E\r
        JE       @@F_d_dd\r
        AND      EDX, $FFFFFF\r
        CMP      EDX, $002E2E\r
        JE       @@F_d_dd\r
\r
        MOV      EDX, [EDI]\r
        CMP      DX, $002E\r
        JE       @@4\r
        AND      EDX, $FFFFFF\r
        CMP      EDX, $002E2E\r
        JE       @@4\r
        JMP      @@chk_anti\r
\r
@@F_d_dd:\r
        MOV      EDX, EDI\r
        PUSH     EAX\r
        CALL     StrComp\r
        TEST     EAX, EAX\r
        POP      EAX\r
        JZ       @@popad_ret_true\r
\r
@@chk_anti:\r
        XCHG     EDX, EAX // EDX = filter[ i ]\r
        MOV      EAX, EDI // EAX = FileName\r
        CMP      byte ptr [EDX], '^'\r
        JNE      @@3\r
\r
        INC      EDX\r
        CALL     _2StrSatisfy\r
        TEST     AL, AL\r
        JZ       @@4\r
        POPAD\r
        JMP      @@ret_false\r
\r
@@3:    CALL     _2StrSatisfy\r
        TEST     AL, AL\r
        JZ       @@4\r
@@popad_ret_true:\r
        POPAD\r
@@ret_true:\r
        MOV      AL, 1\r
        JMP      @@exit\r
\r
@@4:    POPAD\r
@@nx_filter:\r
        LOOP     @@2\r
\r
@@ret_false:\r
        XOR      EAX, EAX\r
@@exit:\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TDirList.SatisfyFilter(FileName: PChar; FileAttr,\r
  FindAttr: DWord): Boolean;\r
{$IFDEF F_P}\r
const Dot: String = '.';\r
{$ENDIF F_P}\r
var I: Integer;\r
    F: PChar;\r
    HasOnlyNegFilters: Boolean;\r
begin\r
  Result := (((FileAttr and FindAttr) = FindAttr) or\r
            LongBool(FindAttr and FILE_ATTRIBUTE_NORMAL));\r
  if not Result then Exit;\r
\r
  if (FileName <> {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}) and\r
     (FileName <> '..') then\r
  if LongBool( FindAttr and FILE_ATTRIBUTE_NORMAL ) and\r
     (FindAttr <> FILE_ATTRIBUTE_NORMAL) then\r
     if LongBool( FindAttr and FILE_ATTRIBUTE_DIRECTORY ) and\r
        LongBool( FileAttr and FILE_ATTRIBUTE_DIRECTORY ) then Exit;\r
\r
  HasOnlyNegFilters := TRUE;\r
  for I := 0 to fFilters.fCount - 1 do\r
  begin\r
    F := PChar(fFilters.fList.fItems[ I ]);\r
    if F = '' then continue;\r
\r
    if (F = {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}) or (F = '..') then\r
    begin\r
      if FileName = F then\r
        Exit;\r
    end\r
      else\r
    if (Filename = {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}) or (FileName = '..') then\r
    begin\r
      //Result := FALSE;\r
      continue;\r
    end;\r
\r
    if F[ 0 ] = '^' then\r
    begin\r
      if StrSatisfy( FileName, PChar(@F[ 1 ]) ) then\r
      begin\r
         Result := False;\r
         Exit;\r
      end;\r
    end\r
      else\r
    begin\r
      HasOnlyNegFilters := FALSE;\r
      if StrSatisfy( FileName, F ) then\r
      begin\r
        Result := True;\r
        Exit;\r
      end;\r
    end;\r
  end;\r
\r
  Result := HasOnlyNegFilters and\r
            (FileName <> {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}) and\r
            (FileName <> '..');\r
\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TDirList.ScanDirectory]\r
procedure TDirList.ScanDirectory(const DirPath, Filter: String;\r
  Attr: DWord);\r
const   sz_win32finddata = sizeof(TWin32FindData);\r
asm\r
        PUSH     EBX\r
        PUSH     EDI\r
        MOV      EBX, EAX\r
\r
        PUSHAD\r
        CALL     Clear\r
        CALL     NewList\r
        MOV      [EBX].fList, EAX\r
        POPAD\r
\r
        PUSHAD\r
        LEA      EAX, [EBX].fPath\r
        CALL     System.@LStrAsg\r
        POPAD\r
\r
        MOV      EAX, [EBX].fPath\r
        TEST     EAX, EAX\r
        JE       @@exit\r
\r
        PUSHAD\r
        LEA      EDX, [EBX].fPath\r
        MOV      EAX, [EDX]\r
        CALL     IncludeTrailingPathDelimiter\r
\r
        MOV      EAX, [EBX].fFilters\r
        TEST     EAX, EAX\r
        JNZ      @@1\r
        CALL     NewStrList\r
        MOV      [EBX].fFilters, EAX\r
        POPAD\r
\r
        PUSHAD\r
        PUSH     ECX\r
        XCHG     EAX, ECX\r
        MOV      EDX, offset[@@star_d_star]\r
        CALL     StrComp\r
        TEST     AL, AL\r
        POP      EDX\r
        JNZ      @@asg_Filter\r
        MOV      EDX, offset[@@star]\r
@@asg_Filter:\r
        MOV      EAX, [EBX].fFilters\r
        CALL     TStrList.Add\r
        JMP      @@1\r
\r
@@star_d_star:\r
        DB       '*.*', 0\r
        DD       -1, 1\r
@@star: DB       '*', 0\r
\r
@@1:\r
        POPAD\r
\r
        ADD      ESP, -sz_win32finddata\r
        XOR      EDX, EDX\r
        PUSH     EDX\r
        PUSH     EDX\r
        XCHG     EAX, ECX\r
        MOV      EDX, ESP\r
        CALL     FindFilter\r
\r
        LEA      EAX, [ESP+4]\r
        MOV      EDX, [EBX].fPath\r
        POP      ECX\r
        PUSH     ECX\r
        CALL     System.@LStrCat3\r
        CALL     RemoveStr\r
\r
        POP      EAX\r
        MOV      EDX, ESP\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     FindFirstFile\r
        MOV      EDI, EAX\r
        INC      EAX\r
        MOV      EAX, ESP\r
\r
        PUSHFD\r
        CALL     System.@LStrClr\r
        POPFD\r
        POP      ECX\r
\r
        JZ       @@fin\r
\r
@@loop:\r
        MOV      ECX, [ESP].TWin32FindData.dwFileAttributes\r
        PUSH     [Attr]\r
        LEA      EDX, [ESP+4].TWin32FindData.cFileName\r
        MOV      EAX, EBX\r
        CALL     SatisfyFilter\r
\r
        TEST     AL, AL\r
        JZ       @@next\r
\r
        MOV      ECX, [EBX].fOnItem.TMethod.Code\r
        JECXZ    @@accept\r
        MOV      EAX, [EBX].fOnItem.TMethod.Data\r
        MOV      ECX, ESP\r
        PUSH     1\r
        MOV      EDX, ESP\r
        PUSH     EDX\r
        MOV      EDX, EBX\r
        CALL     dword ptr [EBX].fOnItem.TMethod.Code\r
        POP      ECX\r
        JECXZ    @@next\r
        LOOP     @@fin\r
\r
@@accept:\r
        MOV      EAX, sz_win32finddata\r
        PUSH     EAX\r
          CALL     System.@GetMem\r
          PUSH     EAX\r
            XCHG     EDX, EAX\r
            MOV      EAX, [EBX].fList\r
            CALL     TList.Add\r
          POP      EDX\r
        POP      ECX\r
        MOV      EAX, ESP\r
        CALL     System.Move\r
\r
@@next:\r
        PUSH     ESP\r
        PUSH     EDI\r
        CALL     FindNextFile\r
        TEST     EAX, EAX\r
        JNZ      @@loop\r
\r
        PUSH     EDI\r
        CALL     FindClose\r
\r
@@fin:\r
        ADD      ESP, sz_win32finddata\r
@@exit:\r
        XOR      EAX, EAX\r
        XCHG     EAX, [EBX].fFilters\r
        CALL     TObj.Free\r
        POP      EDI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TDirList.ScanDirectory(const DirPath, Filter: String;\r
  Attr: DWord);\r
var FindData : TWin32FindData;\r
    E : PWin32FindData;\r
    FindHandle : THandle;\r
    Action: TDirItemAction;\r
begin\r
  Clear;\r
  FList := NewList;\r
  FPath := DirPath;\r
  if FPath = '' then Exit;\r
  FPath := IncludeTrailingPathDelimiter( FPath );\r
  if fFilters = nil then\r
  begin\r
    fFilters := NewStrList;\r
    if Filter = '*.*' then\r
      fFilters.Add( '*' )\r
    else\r
      fFilters.Add( Filter );\r
  end;\r
  FindHandle := FindFirstFile( PChar( FPath + FindFilter( Filter ) ),\r
                               FindData );\r
  if FindHandle = INVALID_HANDLE_VALUE then Exit;\r
  while True do\r
  begin\r
    if SatisfyFilter( PChar(@FindData.cFileName[0]),\r
                      FindData.dwFileAttributes, Attr ) then\r
    begin\r
      Action := diAccept;\r
      if Assigned( OnItem ) then\r
        OnItem( @Self, FindData, Action );\r
      CASE Action OF\r
      diSkip: ;\r
      diAccept:\r
        begin\r
          GetMem( E, Sizeof( FindData ) );\r
          E^ := FindData;\r
          FList.Add( E );\r
        end;\r
      diCancel: break;\r
      END;\r
    end;\r
    if not FindNextFile( FindHandle, FindData ) then break;\r
  end;\r
  FindClose( FindHandle );\r
  fFilters.Free;\r
  fFilters := nil;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TDirList.ScanDirectoryEx]\r
procedure TDirList.ScanDirectoryEx(const DirPath, Filters: String;\r
  Attr: DWord);\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        PUSHAD\r
        CALL     NewStrList\r
        MOV      [EBX].fFilters, EAX\r
        POPAD\r
\r
        PUSHAD\r
        PUSH     0\r
        MOV      EAX, ESP\r
        MOV      EDX, ECX\r
        CALL     System.@LStrLAsg\r
@@1:    MOV      ECX, [ESP]\r
        JECXZ    @@2\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[@@semicolon]\r
        PUSH     0\r
        MOV      ECX, ESP\r
        CALL     Parse\r
        MOV      EAX, [ESP]\r
        MOV      EDX, ESP\r
        CALL     Trim\r
        POP      EDX\r
        PUSH     EDX\r
        TEST     EDX, EDX\r
        JZ       @@filt_added\r
        MOV      EAX, [EBX].fFilters\r
        CALL     TStrList.Add\r
@@filt_added:\r
        CALL     RemoveStr\r
        JMP      @@1\r
\r
        //       ';' string literal\r
        DD       -1, 1\r
@@semicolon:\r
        DB       ';',0\r
\r
@@2:    POP      ECX\r
        POPAD\r
        XOR      ECX, ECX\r
        PUSH     [Attr]\r
        CALL     ScanDirectory\r
        {XOR      EAX, EAX\r
        XCHG     EAX, [EBX].fFilters\r
        CALL     TObj.Free}\r
        POP      EBX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TDirList.ScanDirectoryEx(const DirPath, Filters: String;\r
  Attr: DWord);\r
var F, FF: String;\r
begin\r
  FF := Filters;\r
  fFilters := NewStrList;\r
  while FF <> '' do\r
  begin\r
    F := Trim( Parse( FF, ';' ) );\r
    if F <> '' then\r
      fFilters.Add( F );\r
  end;\r
  ScanDirectory( DirPath, '', Attr );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
type\r
  PSortDirData = ^TSortDirData;\r
  TSortDirData = packed Record\r
    FoldersFirst, CaseSensitive : Boolean;\r
    Rules : array[ 0..11 ] of TSortDirRules;\r
    Dir : PDirList;\r
  end;\r
\r
//[FUNCTION CompareDirItems]\r
{$IFDEF ASM_noVERSION}\r
function CompareDirItems( const Data : PSortDirData; const e1, e2 : DWORD ) : Integer;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].TSortDirData.Dir\r
        MOV      EAX, [EAX].TDirList.fList\r
        MOV      EAX, [EAX].TList.fItems\r
        MOV      ESI, [EAX+EDX*4]\r
        MOV      EDI, [EAX+ECX*4]\r
        MOV      DL, byte ptr[ESI].TWin32FindData.dwFileAttributes\r
        MOV      DH, byte ptr[EDI].TWin32FindData.dwFileAttributes\r
        AND      DX, 2020h\r
        XOR      EAX, EAX\r
        CMP      DL, DH\r
        JE       @@1\r
        CMP      [EBX].TSortDirData.FoldersFirst, AL\r
        JE       @@1\r
        OR       AL, DL\r
        JNE      @@exit_near\r
        DEC      EAX\r
        //JMP      @@exit\r
@@exit_near:\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
        RET\r
\r
@@sdrByDateChanged:\r
        LEA      EAX, [ESI].TWin32FindData.ftLastWriteTime\r
        LEA      EDX, [EDI].TWin32FindData.ftLastWriteTime\r
        JMP      @@sdrByDate1\r
\r
@@sdrByDateAccessed:\r
        LEA      EAX, [ESI].TWin32FindData.ftLastAccessTime\r
        LEA      EDX, [EDI].TWin32FindData.ftLastAccessTime\r
        JMP      @@sdrByDate1\r
\r
@@jmp_table:\r
        DD       offset[@@exit1], offset[@@2], offset[@@2]\r
        DD       offset[@@sdrByName], offset[@@sdrByExt]\r
        DD       offset[@@sdrBySize], offset[@@sdrBySize]\r
        DD       offset[@@sdrByDateCreate], offset[@@sdrByDateChanged]\r
        DD       offset[@@sdrByDateAccessed]\r
\r
@@1:\r
        LEA      EDX, [EBX].TSortDirData.Rules\r
        PUSH     EDX\r
@@2:\r
        POP      EDX\r
        XOR      EAX, EAX\r
        MOV      AL, [EDX]\r
        INC      EDX\r
        PUSH     EDX\r
\r
        JMP      dword ptr [@@jmp_table+EAX*4]\r
        //////// ///////////////////\r
\r
@@sdrByDateCreate:\r
        LEA      EAX, [ESI].TWin32FindData.ftCreationTime\r
        LEA      EDX, [EDI].TWin32FindData.ftCreationTime\r
@@sdrByDate1:\r
        PUSH     EDX\r
        PUSH     EAX     \r
        CALL     CompareFileTime\r
        TEST     EAX, EAX\r
        JE       @@2\r
        JMP      @@exit1\r
\r
@@sdrBySize:\r
        MOV      EAX, [ESI].TWin32FindData.nFileSizeHigh\r
        SUB      EAX, [EDI].TWin32FindData.nFileSizeHigh\r
        JNE      @@sdrBySize1\r
        MOV      EAX, [ESI].TWin32FindData.nFileSizeLow\r
        SUB      EAX, [EDI].TWin32FindData.nFileSizeLow\r
@@to_2:\r
        JE       @@2\r
@@sdrBySize1:\r
        POP      EDX\r
        DEC      EDX\r
        CMP      byte ptr[EDX], sdrBySizeDescending\r
        JNE      @@sdrBySize2\r
        NEG      EAX\r
@@sdrBySize2:\r
        JNE      @@exit\r
        //////// ///////////////////\r
\r
        DD       -1, 1\r
@@point:DB       '.',0\r
\r
@@sdrByExt:\r
        LEA      EAX, [EDI].TWin32FindData.cFileName\r
        MOV      EDX, offset[@@point]\r
        PUSH     EDX\r
        CALL     __DelimiterLast\r
        POP      EDX\r
        PUSH     EAX\r
        LEA      EAX, [ESI].TWin32FindData.cFileName\r
        CALL     __DelimiterLast\r
        POP      EDX\r
        JMP      @@sdrByName0\r
\r
@@sdrByName:\r
        LEA      EAX, [ESI].TWin32FindData.cFileName\r
        LEA      EDX, [EDI].TWin32FindData.cFileName\r
@@sdrByName0:\r
        CMP      [EBX].TSortDirData.CaseSensitive, 0\r
        JNE      @@sdrByName1\r
        CALL     _AnsiCompareStrNoCase\r
        JMP      @@sdrByName2\r
@@sdrByName1:\r
        CALL     _AnsiCompareStr\r
@@sdrByName2:\r
        TEST     EAX, EAX\r
        JE       @@to_2\r
        //JMP    @@exit1\r
\r
@@exit1:\r
        POP      EDX\r
@@exit:\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CompareDirItems( const Data : PSortDirData; const e1, e2 : DWORD ) : Integer;\r
var I : Integer;\r
    Item1, Item2 : PWin32FindData;\r
    S1, S2 : PChar;\r
    IsDir1, IsDir2 : Boolean;\r
    Date1, Date2 : PFileTime;\r
begin\r
  Item1 := Data.Dir.fList.fItems[ e1 ];\r
  Item2 := Data.Dir.fList.fItems[ e2 ];\r
  Result := 0;\r
  IsDir1 := (Item1.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0;\r
  IsDir2 := (Item2.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0;\r
  if (IsDir1 <> IsDir2) and Data.FoldersFirst then\r
  begin\r
    if IsDir1 then Result := -1 else Result := 1;\r
    exit;\r
  end;\r
  for I := 0 to High(Data.Rules) do\r
  begin\r
    case Data.Rules[ I ] of\r
    sdrByName:\r
      begin\r
        S1 := Item1.cFileName;\r
        S2 := Item2.cFileName;\r
        if not Data.CaseSensitive then\r
          Result := _AnsiCompareStrNoCase( S1, S2 )\r
        else\r
          Result := _AnsiCompareStr( S1, S2 );\r
      end;\r
    sdrByExt:\r
      begin\r
        S1 := Item1.cFileName;\r
        S2 := Item2.cFileName;\r
        S1 := __DelimiterLast( S1, '.' );\r
        S2 := __DelimiterLast( S2, '.' );\r
        if not Data.CaseSensitive then\r
           Result := _AnsiCompareStrNoCase( S1, S2 )\r
        else\r
           Result := _AnsiCompareStr( S1, S2 );\r
      end;\r
    sdrBySize, sdrBySizeDescending:\r
      begin\r
        if Item1.nFileSizeHigh < Item2.nFileSizeHigh then\r
           Result := -1\r
        else\r
        if Item1.nFileSizeHigh > Item2.nFileSizeHigh then\r
           Result := 1\r
        else\r
        if Item1.nFileSizeLow < Item2.nFileSizeLow then\r
           Result := -1\r
        else\r
        if Item1.nFileSizeLow > Item2.nFileSizeLow then\r
           Result := 1;\r
        if Data.Rules[ I ] = sdrBySizeDescending then\r
           Result := -Result;\r
      end;\r
    sdrByDateCreate:\r
      begin\r
        Date1 := @Item1.ftCreationTime;\r
        Date2 := @Item2.ftCreationTime;\r
        Result := CompareFileTime( Date1^, Date2^ );\r
      end;\r
    sdrByDateChanged:\r
      begin\r
        Date1 := @Item1.ftLastWriteTime;\r
        Date2 := @Item2.ftLastWriteTime;\r
        Result := CompareFileTime( Date1^, Date2^ );\r
      end;\r
    sdrByDateAccessed:\r
      begin\r
        Date1 := @Item1.ftLastAccessTime;\r
        Date2 := @Item2.ftLastAccessTime;\r
        Result := CompareFileTime( Date1^, Date2^ );\r
      end;\r
    end; {case}\r
    if Result <> 0 then break;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CompareDirItems]\r
\r
//[PROCEDURE SwapDirItems]\r
{$IFDEF ASM_VERSION}\r
procedure SwapDirItems( const Data : PSortDirData; const e1, e2 : DWORD );\r
asm\r
        MOV      EAX, [EAX].TSortDirData.Dir\r
        MOV      EAX, [EAX].TDirList.fList\r
        MOV      EAX, [EAX].TList.fItems\r
        LEA      EDX, [EAX+EDX*4]\r
        LEA      ECX, [EAX+ECX*4]\r
        MOV      EAX, [EDX]\r
        XCHG     EAX, [ECX]\r
        MOV      [EDX], EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure SwapDirItems( const Data : PSortDirData; const e1, e2 : DWORD );\r
var Tmp : Pointer;\r
begin\r
  Tmp := Data.Dir.FList.fItems[ e1 ];\r
  Data.Dir.FList.fItems[ e1 ] := Data.Dir.FList.fItems[ e2 ];\r
  Data.Dir.FList.fItems[ e2 ] := Tmp;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END SwapDirItems]\r
\r
{\r
  TSortDirData = packed Record\r
    FoldersFirst, CaseSensitive : Boolean;\r
    Rules : array[ 0..11 ] of TSortDirRules;\r
    Dir : PDirList;\r
  end;\r
}\r
{$IFDEF ASM_VERSION}\r
procedure TDirList.Sort(Rules: array of TSortDirRules);\r
const   high_DefSortDirRules = High( DefSortDirRules );\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        XOR      EBX,EBX\r
        CMP      [EAX].fList, EBX\r
        JE       @@exit\r
\r
        PUSH     EAX           // prepare Dir = @Self\r
        XOR      EAX, EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        MOV      ESI, ESP\r
        INC      ECX           // ECX = High(Rules)\r
        JZ       @@2\r
@@1:    MOV      AH, [EDX]     // AH = Rules[ I ]\r
        INC      EDX\r
        CALL     @@add_rule\r
        LOOP     @@1\r
@@2:    LEA      EDX, [DefSortDirRules]\r
        MOV      CL, high_DefSortDirRules + 1\r
@@21:   MOV      AH, [EDX]\r
        INC      EDX\r
        CALL     @@add_rule\r
        LOOP     @@21\r
\r
        PUSH     BX           // prepare FoldersFirst(BL), CaseSensitive(BH)\r
        MOV      EBX, [ESP].TSortDirData.Dir\r
        MOV      EAX, ESP\r
        PUSH     offset[SwapDirItems]\r
        MOV      ECX, offset[CompareDirItems]\r
        MOV      EDX, [EBX].fList\r
        MOV      EDX, [EDX].TList.fCount\r
        CALL     SortData\r
\r
        ADD      ESP, 18\r
        JMP      @@exit\r
\r
@@add_rule:\r
        PUSH     ESI\r
        PUSH     ECX\r
        MOV      CL, 11\r
@@a1:   LODSB\r
        TEST     AL, AL\r
        JZ       @@a2\r
        CMP      AL, AH\r
        JE       @@a3\r
        LOOP     @@a1\r
@@a2:   DEC      ESI\r
        MOV      [ESI], AH\r
        CMP      AH, sdrFoldersFirst\r
        JNE      @@a4\r
        INC      BL\r
@@a4:   CMP      AH, sdrCaseSensitive\r
        JNE      @@a3\r
        INC      BH\r
@@a3:   POP      ECX\r
        POP      ESI\r
        RET\r
\r
@@exit:\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TDirList.Sort(Rules: array of TSortDirRules);\r
var SortDirData : TSortDirData;\r
    I, J : Integer;\r
\r
    function RulePresent( Rule : TSortDirRules ) : Boolean;\r
    var K : Integer;\r
    begin\r
      Result := True;\r
      for K := J - 1 downto 0 do\r
        if Rule = SortDirData.Rules[ K ] then exit;\r
      Result := False;\r
    end;\r
\r
    procedure AddRule( Rule : TSortDirRules );\r
    begin\r
      if J > High( SortDirData.Rules ) then exit;\r
      if RulePresent( Rule ) then exit;\r
      SortDirData.Rules[ J ] := Rule;\r
      Inc( J );\r
    end;\r
begin\r
  if fList = nil then Exit;\r
  J := 0;\r
  for I := 0 to High(Rules) do\r
    AddRule( Rules[ I ] );\r
  for I := 0 to High(DefSortDirRules) do\r
    AddRule( DefSortDirRules[ I ] );\r
  while J < High( SortDirData.Rules ) do\r
  begin\r
    SortDirData.Rules[ J ] := sdrNone;\r
    Inc( J );\r
  end;\r
\r
  SortDirData.Dir := @Self;\r
  SortDirData.FoldersFirst := RulePresent( sdrFoldersFirst );\r
  SortDirData.CaseSensitive := RulePresent( sdrCaseSensitive );\r
  SortData( Pointer( @SortDirData ), fList.fCount, @CompareDirItems, @SwapDirItems );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
\r
//[function TDirList.FileList]\r
function TDirList.FileList(const Separator: String; Dirs,\r
  FullPaths: Boolean): String;\r
var I: Integer;\r
begin\r
  Result := '';\r
  for I := 0 to Count-1 do\r
  begin\r
    if not Dirs and IsDirectory[ I ] then Continue;\r
    if FullPaths then\r
      Result := Result + Path;\r
    Result := Result + Names[ I ] + Separator;\r
  end;\r
end;\r
\r
\r
\r
\r
\r
////////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                        R  E  G  I  S  T  R  Y\r
//\r
//\r
////////////////////////////////////////////////////////////////////////\r
\r
\r
\r
{++}(*\r
function RegSetValueEx; external advapi32 name 'RegSetValueExA';\r
*){--}\r
\r
\r
{ -- registry -- }\r
\r
//[function RegKeyOpenRead]\r
function RegKeyOpenRead( Key: HKey; const SubKey: String ): HKey;\r
begin\r
  if RegOpenKeyEx( Key, PChar( SubKey ), 0, KEY_READ, Result ) <> ERROR_SUCCESS then\r
     Result := 0;\r
end;\r
\r
//[function RegKeyOpenWrite]\r
function RegKeyOpenWrite( Key: HKey; const SubKey: String ): HKey;\r
begin\r
  if RegOpenKeyEx( Key, PChar( SubKey ), 0, KEY_READ or KEY_WRITE, Result ) <> ERROR_SUCCESS then\r
     Result := 0;\r
end;\r
\r
//[function RegKeyOpenCreate]\r
function RegKeyOpenCreate( Key: HKey; const SubKey: String ): HKey;\r
var dwDisp: DWORD;\r
begin\r
  if RegCreateKeyEx( Key, PChar( SubKey ), 0, nil, 0, KEY_ALL_ACCESS, nil, Result,\r
                     @dwDisp ) <> ERROR_SUCCESS then\r
    Result := 0;\r
end;\r
\r
//[function RegKeyGetDw]\r
function RegKeyGetDw( Key: HKey; const ValueName: String ): DWORD;\r
var dwType, dwSize: DWORD;\r
begin\r
  dwSize := sizeof( DWORD );\r
  Result := 0;\r
  if (Key = 0) or\r
     (RegQueryValueEx( Key, PChar( ValueName ), nil, @dwType, PByte( @Result ), @dwSize ) <> ERROR_SUCCESS)\r
     or (dwType <> REG_DWORD) then Result := 0;\r
end;\r
\r
//[function RegKeyGetStr]\r
function RegKeyGetStr( Key: HKey; const ValueName: String ): String;\r
var dwType, dwSize: DWORD;\r
    Buffer: PChar;\r
\r
    function Query: Boolean;\r
    begin\r
      Result := RegQueryValueEx( Key, PChar( ValueName ), nil, @dwType,\r
                Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;\r
    end;\r
begin\r
  Result := '';\r
  if Key = 0 then Exit;\r
  dwSize := 0;\r
  Buffer := nil;\r
  if not Query or (dwType <> REG_SZ) then Exit;\r
  GetMem( Buffer, dwSize );\r
  if Query then\r
    Result := Buffer;\r
  FreeMem( Buffer );\r
end;\r
\r
//[function RegKeyGetStrEx]\r
function RegKeyGetStrEx( Key: HKey; const ValueName: String ): String;\r
var dwType, dwSize: DWORD;\r
    Buffer, Buffer2: PChar;\r
    Sz: Integer;\r
    function Query: Boolean;\r
    begin\r
      Result := RegQueryValueEx( Key, PChar( ValueName ), nil, @dwType,\r
                Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;\r
    end;\r
begin\r
  Result := '';\r
  if Key = 0 then Exit;\r
  dwSize := 0;\r
  Buffer := nil;\r
  if not Query or ((dwType <> REG_SZ) and (dwtype <> REG_EXPAND_SZ)) then Exit;\r
  GetMem( Buffer, dwSize );\r
  if Query then\r
  begin\r
    if dwtype = REG_EXPAND_SZ then\r
    begin\r
      //------------------------------------------------------ by Dmitry Zharov\r
      // Sz := ExpandEnvironmentStrings(Buffer,nil,0);         18-Aug-2004\r
      // SetLength( Result, Sz );\r
      // ExpandEnvironmentStrings(Buffer, PChar(Result), Sz);\r
      //---------------------------------------------//\r
      Sz := ExpandEnvironmentStrings(Buffer,nil,0);  // bug in size detection! sometimes we get an additional 2 bytes at the end...\r
      GetMem(Buffer2,Sz);                            //\r
      ExpandEnvironmentStrings(Buffer, Buffer2, Sz); //\r
      Result:=Buffer2;                               //\r
      FreeMem(Buffer2);                              //\r
      //---------------------------------------------//\r
    end\r
      else\r
    Result := Buffer;\r
  end;\r
  FreeMem( Buffer );\r
end;\r
\r
//[function RegKeySetDw]\r
function RegKeySetDw( Key: HKey; const ValueName: String; Value: DWORD ): Boolean;\r
begin\r
  Result := (Key <> 0) and (RegSetValueEx( Key, PChar( ValueName ), 0, REG_DWORD, @Value, sizeof( DWORD ) )\r
            = ERROR_SUCCESS);\r
end;\r
\r
//[function RegKeySetStr]\r
function RegKeySetStr( Key: HKey; const ValueName: String; const Value: String ): Boolean;\r
begin\r
  Result := (Key <> 0) and (RegSetValueEx( Key, PChar( ValueName ), 0,\r
            REG_SZ, PChar(Value),\r
             Length( Value ) + 1 ) = ERROR_SUCCESS);\r
end;\r
\r
//[function RegKeySetStrEx]\r
function RegKeySetStrEx( Key: HKey; const ValueName: string; const Value: string;\r
                         expand: boolean): Boolean;\r
var dwType: DWORD;\r
begin\r
  dwType := REG_SZ;\r
  if expand then\r
    dwType := REG_EXPAND_SZ;\r
  Result := (Key <> 0) and (RegSetValueEx(Key, PChar(ValueName), 0, dwType,\r
            PChar(Value), Length(Value) + 1) = ERROR_SUCCESS);\r
end;\r
\r
//[procedure RegKeyClose]\r
procedure RegKeyClose( Key: HKey );\r
begin\r
  if Key <> 0 then\r
    RegCloseKey( Key );\r
end;\r
\r
//[function RegKeyDelete]\r
function RegKeyDelete( Key: HKey; const SubKey: String ): Boolean;\r
begin\r
  Result := FALSE;\r
  if Key <> 0 then\r
    Result := RegDeleteKey( Key, PChar( SubKey ) ) = ERROR_SUCCESS;\r
end;\r
\r
//[function RegKeyDeleteValue]\r
function RegKeyDeleteValue( Key: HKey; const SubKey: String ): Boolean;\r
begin\r
  Result := FALSE;\r
  if Key <> 0 then\r
    Result := RegDeleteValue( Key, PChar( SubKey ) ) = ERROR_SUCCESS;\r
end;\r
\r
//[function RegKeyExists]\r
function RegKeyExists( Key: HKey; const SubKey: String ): Boolean;\r
var K: Integer;\r
begin\r
  if Key = 0 then\r
  begin\r
    Result := FALSE;\r
    Exit;\r
  end;\r
  K := RegKeyOpenRead( Key, SubKey );\r
  Result := K <> 0;\r
  if K <> 0 then\r
    RegKeyClose( K );\r
end;\r
\r
//[function RegKeyValExists]\r
function RegKeyValExists( Key: HKey; const ValueName: String ): Boolean;\r
var dwType, dwSize: DWORD;\r
begin\r
  Result := (Key <> 0) and\r
            (RegQueryValueEx( Key, PChar( ValueName ), nil,\r
            @dwType, nil, @dwSize ) = ERROR_SUCCESS);\r
end;\r
\r
//[function RegKeyValueSize]\r
function RegKeyValueSize( Key: HKey; const ValueName: String ): Integer;\r
begin\r
  Result := 0;\r
  if Key = 0 then Exit;\r
  RegQueryValueEx( Key, PChar( ValueName ), nil, nil, nil, @ DWORD( Result ) );\r
end;\r
\r
//[function RegKeyGetBinary]\r
function RegKeyGetBinary( Key: HKey; const ValueName: String; var Buffer; Count: Integer ): Integer;\r
begin\r
  Result := 0;\r
  if Key = 0 then Exit;\r
  Result := Count;\r
  RegQueryValueEx( Key, PChar( ValueName ), nil, nil, @ Buffer, @ Result );\r
end;\r
\r
//[function RegKeySetBinary]\r
function RegKeySetBinary( Key: HKey; const ValueName: String; const Buffer; Count: Integer ): Boolean;\r
begin\r
  Result := (Key <> 0) and (RegSetValueEx( Key, PChar( ValueName ), 0,\r
                    REG_BINARY, @ Buffer, Count ) = ERROR_SUCCESS);\r
end;\r
\r
//[function RegKeyGetDateTime]\r
function RegKeyGetDateTime(Key: HKey; const ValueName: String): TDateTime;\r
begin\r
  RegKeyGetBinary( Key, ValueName, Result, Sizeof( Result ) );\r
end;\r
\r
//[function RegKeySetDateTime]\r
function RegKeySetDateTime(Key: HKey; const ValueName: String; DateTime: TDateTime): Boolean;\r
begin\r
  Result := RegKeySetBinary( Key, ValueName, DateTime, Sizeof( DateTime ) );\r
end;\r
\r
//-----------------------------------------------\r
// functions by Valerian Luft <luft@valerian.de>\r
//-----------------------------------------------\r
//[function RegKeyGetSubKeys]\r
function RegKeyGetSubKeys( const Key: HKEY; List: PStrList) : Boolean;\r
var\r
  I, Size, NumSubKeys, MaxSubKeyLen : DWORD;\r
  KeyName: String;\r
begin\r
  Result := False;\r
  List.Clear ;\r
  if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, @MaxSubKeyLen, nil, nil, nil, nil,\r
nil, nil) = ERROR_SUCCESS then\r
    begin\r
      if NumSubKeys > 0 then begin\r
        for I := 0 to NumSubKeys-1 do\r
        begin\r
          Size := MaxSubKeyLen+1;\r
          SetLength(KeyName, Size);\r
          //FillChar(KeyName[1],Size,#0);\r
          RegEnumKeyEx(Key, I, @KeyName[1], Size, nil, nil, nil, nil);\r
          SetLength(KeyName, lstrlen(@KeyName[1]));\r
          List.Add(KeyName);\r
        end;\r
      end;\r
      Result:= True;\r
  end;\r
end;\r
\r
\r
//[function RegKeyGetValueNames]\r
function RegKeyGetValueNames(const Key: HKEY; List: PStrList): Boolean;\r
var\r
  I, Size, NumSubKeys, NumValueNames, MaxValueNameLen: DWORD;\r
  ValueName: String;\r
begin\r
  List.Clear ;\r
  Result:=False;\r
  if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, nil, nil, @NumValueNames,\r
@MaxValueNameLen, nil, nil, nil) = ERROR_SUCCESS then\r
  begin\r
     if NumValueNames > 0 then\r
        for I := 0 to NumValueNames - 1 do begin\r
          Size := MaxValueNameLen + 1;\r
          SetLength(ValueName, Size);\r
          //FillChar(ValueName[1],Size,#0);\r
          RegEnumValue(Key, I, @ValueName[1], Size, nil, nil, nil, nil);\r
          SetLength(ValueName, lstrlen(@ValueName[1]));\r
          List.Add(ValueName);\r
        end;\r
     Result := True;\r
  end ;\r
end;\r
\r
\r
//[function RegKeyGetValueTyp]\r
function RegKeyGetValueTyp (const Key:HKEY; const ValueName: String) : DWORD;\r
begin\r
Result:= Key ;\r
if Key <> 0 then\r
   RegQueryValueEx (Key,@ValueName[1],NIL,@Result,NIL,NIL)\r
end;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- TDirChange -- }\r
\r
const FilterFlags: array[ TFileChangeFilters ] of Integer = (\r
      FILE_NOTIFY_CHANGE_FILE_NAME, FILE_NOTIFY_CHANGE_DIR_NAME,\r
      FILE_NOTIFY_CHANGE_ATTRIBUTES, FILE_NOTIFY_CHANGE_SIZE,\r
      FILE_NOTIFY_CHANGE_LAST_WRITE, $20 {FILE_NOTIFY_CHANGE_LAST_ACCESS},\r
      $40 {FILE_NOTIFY_CHANGE_CREATION}, FILE_NOTIFY_CHANGE_SECURITY );\r
\r
//[FUNCTION _NewDirChgNotifier]\r
{$IFDEF ASM_VERSION}\r
function _NewDirChgNotifier: PDirChange;\r
begin\r
  New( Result, Create );\r
end;\r
//[function NewDirChangeNotifier]\r
function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;\r
                               WatchSubtree: Boolean; ChangeProc: TOnDirChange )\r
                               : PDirChange;\r
const Dflt_Flags = FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or\r
      FILE_NOTIFY_CHANGE_ATTRIBUTES or FILE_NOTIFY_CHANGE_SIZE or\r
      FILE_NOTIFY_CHANGE_LAST_WRITE;\r
asm\r
        PUSH     EBX\r
        PUSH     ECX // [EBP-8] = WatchSubtree\r
        PUSH     EDX // [EBP-12] = Filter\r
        PUSH     EAX // [EBP-16] = Path\r
        CALL     _NewDirChgNotifier\r
        XCHG     EBX, EAX\r
        LEA      EAX, [EBX].TDirChange.FPath\r
        POP      EDX\r
        CALL     System.@LStrAsg\r
        MOV      EAX, [ChangeProc].TMethod.Code\r
        MOV      [EBX].TDirChange.FOnChange.TMethod.Code, EAX\r
        MOV      EAX, [ChangeProc].TMethod.Data\r
        MOV      [EBX].TDirChange.FOnChange.TMethod.Data, EAX\r
        POP      ECX\r
        MOV      EAX, Dflt_Flags\r
        MOVZX    ECX, CL\r
        JECXZ    @@flags_ready\r
        PUSH     ECX\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[FilterFlags]\r
        XOR      ECX, ECX\r
        MOV      CL, 7\r
        CALL     MakeFlags\r
        POP      ECX\r
@@flags_ready:           // EAX = Flags\r
        POP      EDX\r
        MOVZX    EDX, DL // EDX = WatchSubtree\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     [EBX].TDirChange.FPath\r
        CALL     FindFirstChangeNotification\r
        MOV      [EBX].TDirChange.FHandle, EAX\r
        INC      EAX\r
        JZ       @@fault\r
        PUSH     EBX\r
        PUSH     offset[TDirChange.Execute]\r
        CALL     NewThreadEx\r
        MOV      [EBX].TDirChange.FMonitor, EAX\r
        JMP      @@exit\r
@@fault:\r
        XCHG     EAX, EBX\r
        CALL     TObj.Free\r
@@exit:\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;\r
                               WatchSubtree: Boolean; ChangeProc: TOnDirChange )\r
                               : PDirChange;\r
var Flags: DWORD;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PDirChange.Create;*){--}\r
\r
  Result.FPath := Path;\r
  Result.FOnChange := ChangeProc;\r
  if Filter = [ ] then\r
    Flags := FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or\r
      FILE_NOTIFY_CHANGE_ATTRIBUTES or FILE_NOTIFY_CHANGE_SIZE or\r
      FILE_NOTIFY_CHANGE_LAST_WRITE\r
  else\r
    Flags := MakeFlags( @Filter, FilterFlags );\r
  Result.FHandle := FindFirstChangeNotification(PChar(Result.FPath),\r
                    Bool( Integer( WatchSubtree ) ), Flags);\r
  if Result.FHandle <> INVALID_HANDLE_VALUE then\r
    Result.FMonitor := NewThreadEx( Result.Execute )\r
  else //MsgOK( 'Can not monitor ' + Result.FPath + #13'Error ' + Int2Str( GetLastError ) );\r
  begin\r
    Result.Free;\r
    Result := nil;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _NewDirChgNotifier]\r
\r
{ TDirChange }\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TDirChange.Changed]\r
procedure TDirChange.Changed;\r
asm\r
        MOV      ECX, [EAX].FPath\r
        XCHG     EDX, EAX\r
        MOV      EAX, [EDX].FOnChange.TMethod.Data\r
        CALL     [EDX].FOnChange.TMethod.Code\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TDirChange.Changed;\r
begin\r
  FOnChange(@Self, FPath); // must be assigned always!!!\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TDirChange.Destroy]\r
destructor TDirChange.Destroy;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      ECX, [EBX].FMonitor\r
        JECXZ    @@no_monitor\r
        XCHG     EAX, ECX\r
        CALL     TObj.Free\r
@@no_monitor:\r
        MOV      ECX, [EBX].FHandle\r
        JECXZ    @@exit\r
        PUSH     ECX\r
        CALL     FindCloseChangeNotification\r
@@exit:\r
        LEA      EAX, [EBX].FPath\r
        CALL     System.@LStrClr\r
        XCHG     EAX, EBX\r
        CALL     TObj.Destroy\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TDirChange.Destroy;\r
begin\r
  if FMonitor <> nil then\r
     FMonitor.Free;\r
  if FHandle > 0 then // FHandle <> INVALID_HANDLE_VALUE AND FHandle <> 0\r
     FindCloseChangeNotification(FHandle);\r
  FPath := '';\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TDirChange.Execute]\r
function TDirChange.Execute(Sender: PThread): Integer;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        XCHG     EBX, EAX\r
        MOV      ESI, EDX\r
@@loo:\r
        MOVZX    ECX, [ESI].TThread.FTerminated\r
        INC      ECX\r
        LOOP     @@e_loop\r
\r
        MOV      ECX, [EBX].FHandle\r
        INC      ECX\r
        JZ       @@e_loop\r
\r
        PUSH     INFINITE\r
        PUSH     ECX\r
        CALL     WaitForSingleObject\r
        OR       EAX, EAX\r
        JNZ      @@loo\r
\r
        PUSH     [EBX].FHandle\r
        MOV      EAX, [EBX].FMonitor\r
        PUSH     EBX\r
        PUSH     offset[TDirChange.Changed]\r
        CALL     TThread.Synchronize\r
        CALL     FindNextChangeNotification\r
        JMP      @@loo\r
@@e_loop:\r
\r
        POP      ESI\r
        POP      EBX\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TDirChange.Execute(Sender: PThread): Integer;\r
begin\r
  while (not Sender.Terminated and (FHandle <> INVALID_HANDLE_VALUE)) do\r
    if (WaitForSingleObject(FHandle, INFINITE) = WAIT_OBJECT_0) then\r
    begin\r
      if AppletTerminated then break;\r
      Applet.GetWindowHandle;\r
      FMonitor.Synchronize( Changed );\r
      FindNextChangeNotification(FHandle);\r
    end;\r
  Result := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
//////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                D  A  T  E     A  N  D     T  I  M  E\r
//\r
//\r
//////////////////////////////////////////////////////////////////////\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- date and time utilities -- }\r
\r
{* This part of the unit contains date-time routines. It is not a simple compilation\r
   of Delphi VCL date-time. E.g., TDateTime type is not based on 31-Dec-1899,\r
   but it is based on 31-Dec-0000 instead, allowing easy manipulating of dates\r
   at all Christian era, and all other historical era too. }\r
\r
//[procedure DivMod]\r
procedure DivMod(Dividend: Integer; Divisor: Word;\r
  var Result, Remainder: Word);\r
{$IFDEF F_P}\r
begin\r
        Result    := Dividend div Divisor;\r
        Remainder := Dividend mod Divisor;\r
end;\r
{$ELSE DELPHI}\r
asm\r
        PUSH    EBX\r
        MOV     EBX,EDX\r
        MOV     EDX,EAX\r
        SHR     EDX,16\r
        DIV     BX\r
        MOV     EBX,Remainder\r
        MOV     [ECX],AX\r
        MOV     [EBX],DX\r
        POP     EBX\r
end;\r
{$ENDIF}\r
\r
{++}(*\r
//[API GetLocalTime, GetSystemTime]\r
procedure GetLocalTime; external kernel32 name 'GetLocalTime';\r
procedure GetSystemTime; external kernel32 name 'GetSystemTime';\r
*){--}\r
\r
//*\r
//[function Now]\r
function Now : TDateTime;\r
var SystemTime : TSystemTime;\r
begin\r
   GetLocalTime( SystemTime );\r
   SystemTime2DateTime( SystemTime, Result );\r
end;\r
\r
//[function Date]\r
function Date: TDateTime;\r
begin\r
  Result := Trunc( Now );\r
end;\r
\r
//[procedure DecodeDateFully]\r
procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD );\r
var ST: TSystemTime;\r
begin\r
  DateTime2SystemTime( DateTime, ST );\r
  Year := ST.wYear;\r
  Month := ST.wMonth;\r
  Day := ST.wDay;\r
  DayOfWeek := ST.wDayOfWeek;\r
end;\r
\r
//[procedure DecodeDate]\r
procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD );\r
var Dummy: Word;\r
begin\r
  DecodeDateFully( DateTime, Year, Month, Day, Dummy );\r
end;\r
\r
//[function EncodeDate]\r
function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean;\r
var ST: TSystemTime;\r
begin\r
  FillChar( ST, Sizeof( ST ), 0 );\r
  ST.wYear := Year;\r
  ST.wMonth := Month;\r
  ST.wDay := Day;\r
  Result := SystemTime2DateTime( ST, DateTime );\r
end;\r
\r
//[FUNCTION CompareSystemTime]\r
{$IFDEF ASM_VERSION}\r
function CompareSystemTime( const D1, D2 : TSystemTime) : Integer; assembler;\r
asm\r
        PUSH     ESI\r
        PUSH     EBX\r
        MOV      ESI, EAX\r
        XOR      EAX, EAX\r
        XOR      ECX, ECX\r
        MOV      CL, 8  // 8 words: wYear, wMonth,..., wMilliseconds\r
@@loo:\r
        LODSW\r
        MOV      BX, [EDX]\r
        INC      EDX\r
        INC      EDX\r
\r
        CMP      CL, 6\r
        JE       @@cont  // skip compare DayOfWeek\r
\r
        SUB      AX, BX\r
        JNE      @@calc\r
\r
@@cont:\r
        LOOP     @@loo\r
        JMP      @@exit\r
\r
@@calc:\r
        SBB      EAX, EAX\r
        {$IFDEF PARANOIA}\r
        DB $0C, 1\r
        {$ELSE}\r
        OR       AL, 1\r
        {$ENDIF}\r
\r
@@exit:\r
        POP      EBX\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CompareSystemTime(const D1, D2 : TSystemTime) : Integer;\r
var R: Integer;\r
   procedure CompareFields(const F1, F2 : Integer);\r
   begin\r
      if R <> 0 then Exit;\r
      if F1 = F2 then Exit;\r
      if F1 < F2 then\r
         R := -1\r
      else\r
         R := 1;\r
   end;\r
begin\r
   R := 0;\r
   CompareFields( D1.wYear, D2.wYear );\r
   CompareFields( D1.wMonth, D2.wMonth );\r
   CompareFields( D1.wDay, D2.wDay );\r
   CompareFields( D1.wHour, D2.wHour );\r
   CompareFields( D1.wMinute, D2.wMinute );\r
   CompareFields( D1.wSecond, D2.wSecond );\r
   CompareFields( D1.wMilliseconds, D2.wMilliseconds );\r
   Result := R;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CompareSystemTime]\r
\r
//*\r
//[procedure IncDays]\r
procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer );\r
var DateTime : TDateTime;\r
begin\r
   SystemTime2DateTime( SystemTime, DateTime );\r
   DateTime := DateTime + DaysNum;\r
   DateTime2SystemTime( DateTime, SystemTime );\r
end;\r
\r
//*\r
//[procedure IncMonths]\r
procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer );\r
var M : Integer;\r
    DateTime : TDateTime;\r
begin\r
   M := SystemTime.wMonth + MonthsNum - 1;\r
   Inc( SystemTime.wYear, M div 12 );\r
   SystemTime.wMonth := M mod 12 + 1;\r
\r
   // Normalize wDayOfWeek field:\r
   SystemTime2DateTime( SystemTime, DateTime );\r
   DateTime2SystemTime( DateTime, SystemTime );\r
end;\r
\r
//*\r
//[function IsLeapYear]\r
function IsLeapYear(Year: Word): Boolean;\r
begin\r
  Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));\r
end;\r
\r
//*\r
//[function SystemTime2DateTime]\r
function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean;\r
var I : Integer;\r
    Day : Integer;\r
    DayTable: PDayTable;\r
begin\r
  Result := False;\r
  DateTime := 0.0;\r
  DayTable := @MonthDays[IsLeapYear(SystemTime.wYear)];\r
  with SystemTime do\r
//-------- by Vadim Petrov ----------------------------------------------------------------\r
//if (wYear >= 1) and (wYear <= 9999) and (wMonth >= 1) and (wMonth <= 12) and\r
//  (wDay >= 1) and (wDay <= DayTable^[wMonth]) and\r
//  (wHour < 24) and (wMinute < 60) and (wSecond < 60) and (wMilliSeconds < 1000) then\r
//---------------------------------------------------------------------------------------//\r
  if {(wYear >= 0) !always true! and} (wYear <= 9999) and\r
    {(wMonth >= 0) !always true! and} (wMonth <= 12) and\r
    {(wDay >= 0) !always true! and} (wDay <= DayTable^[wMonth]) and                                      //\r
    (wHour < 24) and (wMinute < 60) and (wSecond < 60) and (wMilliSeconds < 1000) then   //\r
//---------------------------------------------------------------------------------------//\r
  begin\r
    Day := wDay;\r
    for I := 1 to wMonth - 1 do\r
        Inc(Day, DayTable^[I]);\r
    I := wYear - 1;\r
    //--------------- by Vadim Petrov ------++\r
    if I<0 then i := 0;                     //\r
    //--------------------------------------++\r
    DateTime := I * 365 + I div 4 - I div 100 + I div 400 + Day\r
             + (wHour * 3600000 + wMinute * 60000 + wSecond * 1000 + wMilliSeconds) / MSecsPerDay;\r
    Result := True;\r
  end;\r
end;\r
\r
//*\r
//[function DayOfWeek]\r
function DayOfWeek(Date: TDateTime): Integer;\r
begin\r
  Result := (Trunc( Date ) + 6) mod 7 + 1;\r
end;\r
\r
//*\r
//[function DateTime2SystemTime]\r
function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;\r
const\r
  D1 = 365;\r
  D4 = D1 * 4 + 1;\r
  D100 = D4 * 25 - 1;\r
  D400 = D100 * 4 + 1;\r
var Days : Integer;\r
    Y, M, D, I: Word;\r
    MSec : Integer;\r
    DayTable: PDayTable;\r
    MinCount, MSecCount: Word;\r
begin\r
  Days := Trunc( DateTime );\r
  MSec := Round((DateTime - Days) * MSecsPerDay);\r
  Result := False;\r
  with SystemTime do\r
  if Days > 0 then\r
  begin\r
    Dec(Days);\r
    Y := 1;\r
    while Days >= D400 do\r
    begin\r
      Dec(Days, D400);\r
      Inc(Y, 400);\r
    end;\r
    DivMod(Days, D100, I, D);\r
    if I = 4 then\r
    begin\r
      Dec(I);\r
      Inc(D, D100);\r
    end;\r
    Inc(Y, I * 100);\r
    DivMod(D, D4, I, D);\r
    Inc(Y, I * 4);\r
    DivMod(D, D1, I, D);\r
    if I = 4 then\r
    begin\r
      Dec(I);\r
      Inc(D, D1);\r
    end;\r
    Inc(Y, I);\r
    DayTable := @MonthDays[IsLeapYear(Y)];\r
    M := 1;\r
    while True do\r
    begin\r
      I := DayTable^[M];\r
      if D < I then Break;\r
      Dec(D, I);\r
      Inc(M);\r
    end;\r
    wYear := Y;\r
    wMonth := M;\r
    wDay := D + 1;\r
    wDayOfWeek := DayOfWeek( DateTime );\r
    DivMod(MSec, 60000, MinCount, MSecCount);\r
    DivMod(MinCount, 60, wHour, wMinute);\r
    DivMod(MSecCount, 1000, wSecond, wMilliSeconds);\r
    Result := True;\r
  end;\r
end;\r
\r
function DateTime_DiffSysLoc: TDateTime;\r
var ST, LT: TSystemTime;\r
    FT, FT1: TFileTime;\r
    D1, D2: TDateTime;\r
begin\r
  GetSystemTime( ST );\r
  SystemTimeToFileTime( ST, FT );\r
  FileTimeToLocalFileTime( FT, FT1 );\r
  FileTimeToSystemTime( FT1, LT );\r
  SystemTime2DateTime( ST, D1 );\r
  SystemTime2DateTime( LT, D2 );\r
  Result := D2 - D1;\r
end;\r
\r
//[function DateTime_System2Local]\r
function DateTime_System2Local( DTSys: TDateTime ): TDateTime;\r
begin\r
  Result := DTSys + DateTime_DiffSysLoc;\r
end;\r
\r
//[function DateTime_Local2System]\r
function DateTime_Local2System( DTLoc: TDateTime ): TDateTime;\r
begin\r
  Result := DTLoc - DateTime_DiffSysLoc;\r
end;\r
\r
//*\r
//[function CatholicEaster]\r
function CatholicEaster( nYear: Integer ): TDateTime;\r
var\r
   nMoon, nEpact, nSunday, nGold, nCent, nCorx, nCorz: Integer;\r
   SystemTime : TSystemTime;\r
begin\r
   FillChar( SystemTime, Sizeof( SystemTime ), 0 );\r
   with SystemTime do\r
   begin\r
\r
    wYear := nYear;\r
\r
    { The Golden Number of the year in the 19 year Metonic Cycle }\r
    nGold := ( ( wYear mod 19 ) + 1  );\r
\r
    { Calculate the Century }\r
    nCent := ( ( wYear div 100 ) + 1 );\r
\r
    { No. of Years in which leap year was dropped in order to keep in step\r
      with the sun }\r
    nCorx := ( ( 3 * nCent ) div 4 - 12 );\r
\r
    { Special Correction to Syncronize Easter with the moon's orbit }\r
    nCorz := ( ( 8 * nCent + 5 ) div 25 - 5 );\r
\r
    { Find Sunday }\r
    nSunday := ( ( 5 * wYear ) div 4 - nCorx - 10 );\r
\r
    { Set Epact (specifies occurance of full moon }\r
    nEpact := ( ( 11 * nGold + 20 + nCorz - nCorx ) mod 30 );\r
\r
    if ( nEpact < 0 ) then\r
       nEpact := nEpact + 30;\r
\r
    if ( ( nEpact = 25 ) and ( nGold > 11 ) ) or ( nEpact = 24 ) then\r
       nEpact := nEpact + 1;\r
\r
    { Find Full Moon }\r
    nMoon := 44 - nEpact;\r
\r
    if ( nMoon < 21 ) then\r
       nMoon := nMoon + 30;\r
\r
    { Advance to Sunday }\r
    nMoon := ( nMoon + 7 - ( ( nSunday + nMoon ) mod 7 ) );\r
\r
    if ( nMoon > 31 ) then\r
       begin\r
         wMonth := 4;\r
         wDay   := ( nMoon - 31 );\r
       end\r
    else\r
       begin\r
         wMonth := 3;\r
         wDay   := nMoon;\r
       end;\r
   end;\r
   SystemTime2DateTime( SystemTime, Result );\r
end;\r
\r
//*\r
//[function SystemDate2Str]\r
function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;\r
                         const DfltDateFormat : TDateFormat; const DateFormat : PChar ) : String;\r
var Buf : PChar;\r
    Sz : Integer;\r
    Flags : DWORD;\r
begin\r
   Sz := 100;\r
   Buf := nil;\r
   Result := '';\r
   Flags := 0;\r
   if DateFormat = nil then\r
   if DfltDateFormat = dfShortDate then\r
      Flags := DATE_SHORTDATE\r
   else\r
      Flags := DATE_LONGDATE;\r
   while True do\r
   begin\r
      if Buf <> nil then\r
         FreeMem( Buf );\r
      GetMem( Buf, Sz );\r
      if Buf = nil then Exit;\r
      if GetDateFormat( LocaleID, Flags, @SystemTime, DateFormat, Buf, Sz )\r
         = 0 then\r
      begin\r
         if GetLastError = ERROR_INSUFFICIENT_BUFFER then\r
            Sz := Sz * 2\r
         else\r
            break;\r
      end\r
         else\r
      begin\r
         Result := Buf;\r
         break;\r
      end;\r
   end;\r
   if Buf <> nil then\r
      FreeMem( Buf );\r
end;\r
\r
//*\r
//[function SystemTime2Str]\r
function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;\r
                         const Flags : TTimeFormatFlags; const TimeFormat : PChar ) : String;\r
var Buf : PChar;\r
    Sz : Integer;\r
    Flg : DWORD;\r
begin\r
   Sz := 100;\r
   Buf := nil;\r
   Result := '';\r
   Flg := 0;\r
   if tffNoMinutes in Flags then\r
      Flg := TIME_NOMINUTESORSECONDS\r
   else\r
   if tffNoSeconds in Flags then\r
      Flg := TIME_NOSECONDS;\r
   if tffNoMarker in Flags then\r
      Flg := Flg or TIME_NOTIMEMARKER;\r
   if tffForce24 in Flags then\r
      Flg := Flg or TIME_FORCE24HOURFORMAT;\r
   while True do\r
   begin\r
      if Buf <> nil then\r
         FreeMem( Buf );\r
      GetMem( Buf, Sz );\r
      if Buf = nil then Exit;\r
      if GetTimeFormat( LocaleID, Flg, @SystemTime, TimeFormat, Buf, Sz )\r
         = 0 then\r
      begin\r
         if GetLastError = ERROR_INSUFFICIENT_BUFFER then\r
            Sz := Sz * 2\r
         else\r
            break;\r
      end\r
         else\r
      begin\r
         Result := Buf;\r
         break;\r
      end;\r
   end;\r
   if Buf <> nil then\r
      FreeMem( Buf );\r
end;\r
\r
//[function Date2StrFmt]\r
function Date2StrFmt( const Fmt: String; D: TDateTime ): String;\r
var ST: TSystemTime;\r
    lpFmt: PChar;\r
begin\r
  DateTime2SystemTime( D, ST );\r
  lpFmt := nil;\r
  if Fmt <> '' then lpFmt := PChar( Fmt );\r
  Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT, dfShortDate, lpFmt );\r
end;\r
\r
//[function Time2StrFmt]\r
function Time2StrFmt( const Fmt: String; D: TDateTime ): String;\r
var ST: TSystemTime;\r
    lpFmt: PChar;\r
begin\r
  if D < 1 then D := D + 1;\r
  DateTime2SystemTime( D, ST );\r
  lpFmt := nil;\r
  if Fmt <> '' then lpFmt := PChar( Fmt );\r
  Result := SystemTime2Str( ST, LOCALE_USER_DEFAULT, [], lpFmt );\r
end;\r
\r
//[function DateTime2StrShort]\r
function DateTime2StrShort( D: TDateTime ): String;\r
var ST: TSystemTime;\r
begin\r
  //--------- by Vadim Petrov --------++\r
  if D < 1 then D := D + 1;           //\r
  //----------------------------------++\r
  DateTime2SystemTime( D, ST );\r
  Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, dfShortDate, nil ) + ' ' +\r
            SystemTime2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, [], nil );\r
end;\r
\r
//[function Str2DateTimeFmt]\r
function Str2DateTimeFmt( const sFmtStr, sS: String ): TDateTime;\r
var h12, hAM: Boolean;\r
    FmtStr, S: PChar;\r
\r
  function GetNum( var S: PChar; NChars: Integer ): Integer;\r
  begin\r
    Result := 0;\r
    while (S^ <> #0) and (NChars <> 0) do\r
    begin\r
      Dec( NChars );\r
      if S^ in ['0'..'9'] then\r
      begin\r
        Result := Result * 10 + Ord(S^) - Ord('0');\r
        Inc( S );\r
      end\r
      else\r
        break;\r
    end;\r
  end;\r
\r
  function GetYear( var S: PChar; NChars: Integer ): Integer;\r
  var STNow: TSystemTime;\r
      OldDate: Boolean;\r
  begin\r
    Result := GetNum( S, NChars );\r
    GetSystemTime( STNow );\r
    OldDate := Result < 50;\r
    Result := Result + STNow.wYear - STNow.wYear mod 100;\r
    if OldDate then Dec( Result, 100 );\r
  end;\r
\r
  function GetMonth( const fmt: String; var S: PChar ): Integer;\r
  var SD: TSystemTime;\r
      M: Integer;\r
      C, MonthStr: String;\r
  begin\r
    GetSystemTime( SD );\r
    for M := 1 to 12 do\r
    begin\r
      SD.wMonth := M;\r
      C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PChar( fmt + '/dd/yyyy/' ) );\r
      MonthStr := Parse( C, '/' );\r
      if AnsiCompareStrNoCase( MonthStr, Copy( S, 1, Length( MonthStr ) ) ) = 0 then\r
      begin\r
        Result := M;\r
        Inc( S, Length( MonthStr ) );\r
        Exit;\r
      end;\r
    end;\r
    Result := 1;\r
  end;\r
\r
  procedure SkipDayOfWeek( const fmt: String; var S: PChar );\r
  var SD: TSystemTime;\r
      Dt: TDateTime;\r
      D: Integer;\r
      C, DayWeekStr: String;\r
  begin\r
    GetSystemTime( SD );\r
    SystemTime2DateTime( SD, Dt );\r
    Dt := Dt - SD.wDayOfWeek;\r
    for D := 0 to 6 do\r
    begin\r
      DateTime2SystemTime( Dt, SD );\r
      C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PChar( fmt + '/MM/yyyy/' ) );\r
      DayWeekStr := Parse( C, '/' );\r
      if AnsiCompareStrNoCase( DayWeekStr, Copy( S, 1, Length( DayWeekStr ) ) ) = 0 then\r
      begin\r
        Inc( S, Length( DayWeekStr ) );\r
        Exit;\r
      end;\r
      Dt := Dt + 1.0;\r
    end;\r
  end;\r
\r
  procedure GetTimeMark( const fmt: String; var S: PChar );\r
  var SD: TSystemTime;\r
      AM: Boolean;\r
      C, TimeMarkStr: String;\r
  begin\r
    GetSystemTime( SD );\r
    SD.wHour := 0;\r
    for AM := FALSE to TRUE do\r
    begin\r
      C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PChar( fmt + '/HH/mm' ) );\r
      TimeMarkStr := Parse( C, '/' );\r
      if AnsiCompareStrNoCase( TimeMarkStr, Copy( S, 1, Length( TimeMarkStr ) ) ) = 0 then\r
      begin\r
        Inc( S, Length( TimeMarkStr ) );\r
        hAM := AM;\r
        Exit;\r
      end;\r
      SD.wHour := 13;\r
    end;\r
    Result := 1;\r
  end;\r
\r
  function FmtIs1( S: PChar ): Boolean;\r
  begin\r
    if StrIsStartingFrom( FmtStr, S ) then\r
    begin\r
      Inc( FmtStr, StrLen( S ) );\r
      Result := TRUE;\r
    end\r
      else\r
      Result := FALSE;\r
  end;\r
\r
  function FmtIs( S1, S2: PChar ): Boolean;\r
  begin\r
    Result := FmtIs1( S1 ) or FmtIs1( S2 );\r
  end;\r
\r
var ST: TSystemTime;\r
begin\r
  FmtStr := PChar( sFmtStr);\r
  S := PChar( sS );\r
  FillChar( ST, Sizeof( ST ), 0 );\r
  h12 := FALSE;\r
  hAM := FALSE;\r
  while (FmtStr^ <> #0) and (S^ <> #0) do\r
  begin\r
    if (FmtStr^ in ['a'..'z','A'..'Z']) and (S^ in ['0'..'9']) then\r
    begin\r
      if      FmtIs1( 'yyyy'   ) then ST.wYear := GetNum( S, 4 )\r
      else if FmtIs1( 'yy' )     then ST.wYear := GetYear( S, 2 )\r
      else if FmtIs1( 'y' )      then ST.wYear := GetYear( S, -1 )\r
      else if FmtIs( 'dd', 'd' ) then ST.wDay := GetNum( S, 2 )\r
      else if FmtIs( 'MM', 'M' ) then ST.wMonth := GetNum( S, 2 )\r
      else if FmtIs( 'HH', 'H' ) then ST.wHour := GetNum( S, 2 )\r
      else if FmtIs( 'hh', 'h' ) then begin ST.wHour := GetNum( S, 2 ); h12 := TRUE end\r
      else if FmtIs( 'mm', 'm' ) then ST.wMinute := GetNum( S, 2 )\r
      else if FmtIs( 'ss', 's' ) then ST.wSecond := GetNum( S, 2 )\r
      else break; // + ECM\r
    end\r
      else\r
    if (FmtStr^ in [ 'M', 'd', 'g' ]) then\r
    begin\r
      if      FmtIs1( 'MMMM' ) then ST.wMonth := GetMonth( 'MMMM', S )\r
      else if FmtIs1( 'MMM'  ) then ST.wMonth := GetMonth( 'MMM', S )\r
      else if FmtIs1( 'dddd' ) then SkipDayOfWeek( 'dddd', S )\r
      else if FmtIs1( 'ddd'  ) then SkipDayOfWeek( 'ddd', S )\r
      else if FmtIs1( 'tt'   ) then GetTimeMark( 'tt', S )\r
      else if FmtIs1( 't'    ) then GetTimeMark( 't', S )\r
      else break; // + ECM\r
    end\r
      else\r
    begin\r
      if FmtStr^ = S^ then\r
        Inc( FmtStr );\r
      Inc( S );\r
    end;\r
  end;\r
\r
  if h12 then\r
  if hAM then\r
    Inc( ST.wHour, 12 );\r
\r
  SystemTime2DateTime( ST, Result );\r
end;\r
\r
var FmtBuf: PChar;\r
    DateSeparator : Char = #0; // + ECM\r
\r
//[function Str2DateTimeShort]\r
function Str2DateTimeShort( const S: String ): TDateTime;\r
var FmtStr, FmtStr2: String;\r
\r
  function EnumDateFmt( lpstrFmt: PChar ): Boolean; stdcall;\r
  begin\r
    GetMem( FmtBuf, StrLen( lpstrFmt ) + 1 );\r
    StrCopy( FmtBuf, lpstrFmt );\r
    Result := FALSE;\r
  end;\r
\r
begin\r
  FmtStr := 'dd.MM.yyyy';\r
  FmtBuf := nil;\r
  EnumDateFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, DATE_SHORTDATE );\r
  if FmtBuf <> nil then\r
  begin\r
    FmtStr := FmtBuf;\r
    FreeMem( FmtBuf );\r
  end;\r
\r
  FmtStr2 := 'H:mm:ss';\r
  FmtBuf := nil;\r
  EnumTimeFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, 0 );\r
  if FmtBuf <> nil then\r
  begin\r
    FmtStr2 := FmtBuf;\r
    FreeMem( FmtBuf );\r
  end;\r
\r
  Result := Str2DateTimeFmt( FmtStr + ' ' + FmtStr2, S );\r
end;\r
\r
// + ECM\r
//[function Str2DateTimeShortEx]\r
function Str2DateTimeShortEx( const S: String ): TDateTime;\r
var St: String;\r
  Buff: Array[0..1] of Char;\r
begin\r
  if DateSeparator = #0 then\r
  begin\r
    if GetLocaleInfo(GetThreadLocale,LOCALE_SDATE,Buff,2) > 0 then\r
      DateSeparator := Buff[0];\r
  end;\r
  St := S;\r
  if Pos(DateSeparator,S) = 0 then\r
    St := '0.0.0 '+S;\r
  Result := Str2DateTimeShort(St);\r
end;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
///////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                          T  H  R  E  A  D  S\r
//\r
//\r
///////////////////////////////////////////////////////////////////////\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- Thread -- }\r
\r
//[function ThreadFunc]\r
function ThreadFunc(Thread: PThread): integer; stdcall;\r
begin\r
  Result := Thread.Execute;\r
end;\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewThread]\r
function NewThread: PThread;\r
begin\r
  new( Result, ThreadCreate );\r
end;\r
//[END NewThread]\r
{$ELSE not_USE_CONSTRUCTORS}\r
//*\r
//[function NewThread]\r
function NewThread: PThread;\r
begin\r
  {$IFNDEF FPC105ORBELOW}\r
  IsMultiThread := True;\r
  {$ENDIF}\r
  {-}\r
  New( Result, Create );\r
  {+}\r
  {++}(*Result := PThread.Create;*){--}\r
  Result.FSuspended := True;\r
  Result.FHandle := CreateThread( nil, // no security\r
                                  0,   // the same stack size\r
                                  @ThreadFunc, // thread entry point\r
                                  Result,      // parameter to pass to ThreadFunc\r
                                  CREATE_SUSPENDED,   // always SUSPENDED\r
                                  Result.FThreadID ); // receive thread ID\r
end;\r
//[END NewThread]\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewThreadEx]\r
function NewThreadEx( const Proc: TOnThreadExecute ): PThread;\r
begin\r
  new( Result, ThreadCreateEx( Proc ) );\r
end;\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewThreadEx]\r
{$IFDEF ASM_VERSION}\r
function NewThreadEx( const Proc: TOnThreadExecute ): PThread;\r
asm\r
        CALL     NewThread\r
        POP      EBP\r
        POP      ECX\r
        POP      EDX\r
        MOV      [EAX].TThread.fOnExecute.TMethod.Code, EDX\r
        POP      EDX\r
        MOV      [EAX].TThread.fOnExecute.TMethod.Data, EDX\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     TThread.Resume\r
        POP      EAX\r
        RET\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewThreadEx( const Proc: TOnThreadExecute ): PThread;\r
begin\r
  Result := NewThread;\r
  Result.OnExecute := {++}(*{$IFDEF F_P} @ {$ENDIF}*){--}Proc;\r
  Result.Resume;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewThreadEx]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//[function NewThreadAutoFree]\r
function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread;\r
begin\r
  Result := NewThread;\r
  Result.OnExecute := {++}(*{$IFDEF F_P} @ {$ENDIF}*){--}Proc;\r
  Result.F_AutoFree := TRUE;\r
  if Assigned( Proc ) then\r
    Result.Resume;\r
end;\r
\r
{ TThread }\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TThread.Destroy]\r
destructor TThread.Destroy;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CMP      [EAX].FTerminated, 0\r
        JNZ      @@1\r
        CALL     Terminate\r
        MOV      EAX, EBX\r
        CALL     WaitFor\r
@@1:    MOV      ECX, [EBX].FHandle\r
        JECXZ    @@2\r
        PUSH     ECX\r
        CALL     CloseHandle\r
@@2:    POP      EAX\r
        XCHG     EBX, EAX\r
        JMP      TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TThread.Destroy;\r
begin\r
  if not FTerminated then\r
  begin\r
    Terminate;\r
    WaitFor;\r
  end;\r
  if (FHandle <> 0) then\r
    CloseHandle(FHandle);\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[function TThread.Execute]\r
function TThread.Execute: integer;\r
begin\r
  Result := 0;\r
  if Assigned( FOnExecute ) then\r
     Result := FOnExecute( @Self );\r
  if F_AutoFree then\r
  begin\r
    FTerminated := TRUE; // fake thread object (to prevent terminating while freeing)\r
    Free;\r
  end;\r
end;\r
\r
//*\r
//[function TThread.GetPriorityCls]\r
function TThread.GetPriorityCls: Integer;\r
begin\r
  Result := GetPriorityClass(FHandle);\r
end;\r
\r
//*\r
//[function TThread.GetThrdPriority]\r
function TThread.GetThrdPriority: Integer;\r
begin\r
  Result := GetThreadPriority(FHandle);\r
end;\r
\r
//*\r
//[procedure TThread.Resume]\r
procedure TThread.Resume;\r
begin\r
  FSuspended := False;\r
  if (ResumeThread(FHandle) > 1) then\r
    FSuspended := True\r
  else\r
  if Assigned(FOnResume) then\r
    FOnResume(@Self);\r
end;\r
\r
//*\r
//[procedure TThread.SetPriorityCls]\r
procedure TThread.SetPriorityCls(Value: Integer);\r
begin\r
  {$IFDEF DEBUG}\r
  if not SetPriorityClass(GetCurrentProcess, Value) then\r
  begin\r
    ShowMessage( SysErrorMessage( GetLastError ) );\r
  end;\r
  {$ELSE}\r
  SetPriorityClass(GetCurrentProcess, Value);\r
  {$ENDIF}\r
end;\r
\r
//*\r
//[procedure TThread.SetThrdPriority]\r
procedure TThread.SetThrdPriority(Value: Integer);\r
begin\r
  SetThreadPriority(FHandle, Value);\r
end;\r
\r
//*\r
//[procedure TThread.Suspend]\r
procedure TThread.Suspend;\r
begin\r
  FSuspended := TRUE;\r
  if Assigned(FOnSuspend) then\r
    Synchronize( FOnSuspend );\r
  SuspendThread(FHandle);\r
end;\r
\r
//*\r
//[procedure CallSynchronized]\r
procedure CallSynchronized( Sender: PObj; Param: Pointer );\r
var Thread: PThread;\r
begin\r
  Thread := PThread( Sender );\r
  if Param <> nil then\r
    Thread.FMethodEx( Thread, Param )\r
  else\r
    Thread.FMethod( );\r
end;\r
\r
//*\r
//[procedure TThread.Synchronize]\r
procedure TThread.Synchronize(Method: TThreadMethod);\r
begin\r
  Global_Synchronized := CallSynchronized;\r
  FMethod := Method;\r
  if Applet <> nil then\r
    SendMessage( Applet.fHandle, CM_EXECPROC, 0, Integer( @Self ) );\r
end;\r
\r
//[procedure TThread.SynchronizeEx]\r
procedure TThread.SynchronizeEx( Method: TThreadMethodEx; Param: Pointer );\r
begin\r
  Assert( Param <> nil, 'Parameter must not be NIL' );\r
  Global_Synchronized := CallSynchronized;\r
  FMethodEx := Method;\r
  SendMessage( Applet.fHandle, CM_EXECPROC, Integer( Param ), Integer( @Self ) );\r
end;\r
\r
//*\r
//[procedure TThread.Terminate]\r
procedure TThread.Terminate;\r
begin\r
  TerminateThread(FHandle,0);\r
  FTerminated := True;\r
end;\r
\r
//*\r
//[function TThread.WaitFor]\r
function TThread.WaitFor: Integer;\r
begin\r
  RefInc;\r
  Result := -1;\r
  if FHandle = 0 then Exit;\r
  WaitForSingleObject(FHandle, INFINITE);\r
  GetExitCodeThread(FHandle, DWORD(Result));\r
  RefDec;\r
end;\r
\r
\r
\r
{ TStream }\r
\r
{* This part of the unit contains implementation of streams for KOL. Please note,\r
   that both stream types (file stream and memory stream) are incapsulated\r
   by a single object type TStream. To avoid including unnedeed code,\r
   use constructing functions NewReadFileStream and NewWriteFileStream\r
   to work with file streams, which do not require both types of operation. }\r
\r
{* To create new type of stream, define your own methods, and in your\r
   constructing function, pass it to _NewStream function (through\r
   TStreamMethods record). In a field Custom, You can store a reference to\r
   your own data of any type (but do not forget to define correct releasing\r
   of such data in your fClose procedure). }\r
\r
//[function TStream.GetPosition]\r
function TStream.GetPosition: DWord;\r
begin\r
  Result := Seek( 0, spCurrent );\r
end;\r
\r
//[procedure TStream.SetPosition]\r
procedure TStream.SetPosition(Value: DWord);\r
begin\r
  Seek( Value, spBegin );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStream.GetSize]\r
function TStream.GetSize: DWord;\r
asm\r
        CALL     [EAX].fMethods.fGetSiz\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStream.GetSize: DWord;\r
begin\r
  Result := fMethods.fGetSiz( @Self );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStream.SetSize]\r
procedure TStream.SetSize(NewSize: DWord);\r
asm\r
        CALL     [EAX].fMethods.fSetSiz\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStream.SetSize(NewSize: DWord);\r
begin\r
  fMethods.fSetSiz( @Self, NewSize );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TStream.GetFileStreamHandle]\r
function TStream.GetFileStreamHandle: THandle;\r
begin\r
  Result := fData.fHandle;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStream.Read]\r
function TStream.Read(var Buffer; Count: DWord): DWord;\r
asm\r
        CALL     [EAX].fMethods.fRead\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStream.Read(var Buffer; Count: DWord): DWord;\r
begin\r
  Result := fMethods.fRead( @Self, Buffer, Count );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TStream.GetCapacity]\r
function TStream.GetCapacity: DWORD;\r
begin\r
  Result := fData.fCapacity;\r
end;\r
\r
//[procedure TStream.SetCapacity]\r
procedure TStream.SetCapacity(const Value: DWORD);\r
var OldSize: DWORD;\r
begin\r
  if fData.fCapacity >= Value then Exit;\r
  OldSize := Size;\r
  Size := Value;\r
  Size := OldSize;\r
end;\r
\r
//[function TStream.Busy]\r
function TStream.Busy: Boolean;\r
begin\r
  Result := Assigned( fData.fThread );\r
end;\r
\r
//[function TStream.DoAsyncRead]\r
function TStream.DoAsyncRead( Sender: PThread ): Integer;\r
begin\r
  Read( Pointer( fParam1 )^, fParam2 );\r
  fData.fThread := nil;\r
  Result := 0;\r
end;\r
\r
//[procedure TStream.ReadAsync]\r
procedure TStream.ReadAsync(var Buffer; Count: DWord);\r
begin\r
  if Busy then Wait;\r
  fData.fThread := NewThreadAutoFree( nil );\r
  fData.fThread.OnExecute := DoAsyncRead;\r
  fParam1 := DWORD( @ Buffer );\r
  fParam2 := Count;\r
  fData.fThread.Resume;\r
end;\r
\r
//[function TStream.DoAsyncSeek]\r
function TStream.DoAsyncSeek( Sender: PThread ): Integer;\r
begin\r
  Seek( fParam1, TMoveMethod( fParam2 ) );\r
  fData.fThread := nil;\r
  Result := 0;\r
end;\r
\r
//[procedure TStream.SeekAsync]\r
procedure TStream.SeekAsync(MoveTo: Integer; MoveMethod: TMoveMethod);\r
begin\r
  if Busy then Wait;\r
  fData.fThread := NewThreadAutoFree( nil );\r
  fData.fThread.OnExecute := DoAsyncSeek;\r
  fParam1 := MoveTo;\r
  fParam2 := Ord( MoveMethod );\r
  fData.fThread.Resume;\r
end;\r
\r
//[function TStream.DoAsyncWrite]\r
function TStream.DoAsyncWrite( Sender: PThread ): Integer;\r
begin\r
  Write( Pointer( fParam1 )^, fParam2 );\r
  fData.fThread := nil;\r
  Result := 0;\r
end;\r
\r
//[procedure TStream.WriteAsync]\r
procedure TStream.WriteAsync(var Buffer; Count: DWord);\r
begin\r
  if Busy then Wait;\r
  fData.fThread := NewThreadAutoFree( nil );\r
  fData.fThread.OnExecute := DoAsyncWrite;\r
  fParam1 := DWORD( @ Buffer );\r
  fParam2 := Count;\r
  fData.fThread.Resume;\r
end;\r
\r
//[procedure TStream.Wait]\r
procedure TStream.Wait;\r
begin\r
  if not Assigned( fData.fThread ) then Exit;\r
  if Assigned( fMethods.fWait ) then\r
    fMethods.fWait( @Self )\r
  else\r
    fData.fThread.WaitFor;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStream.Write]\r
function TStream.Write(var Buffer; Count: DWord): DWord;\r
asm\r
        CALL     [EAX].fMethods.fWrite\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStream.Write(var Buffer; Count: DWord): DWord;\r
begin\r
  Result := fMethods.fWrite( @Self, Buffer, Count );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TStream.WriteStr]\r
function TStream.WriteStr(S: String): DWORD;\r
begin\r
  if S <> '' then\r
    Result := fMethods.fWrite( @Self, S[1], Length( S ) )\r
  else\r
    Result := 0;\r
end;\r
\r
//[function TStream.ReadStrZ]\r
function TStream.ReadStrZ: String;\r
var C: Char;\r
begin\r
  Result := '';\r
  REPEAT\r
    C := #0;\r
    Read( C, 1 );\r
    if C <> #0 then Result := Result + C;\r
  UNTIL C = #0;\r
end;\r
\r
//[function TStream.ReadStr]\r
function TStream.ReadStr: String;\r
var C: Char;\r
begin\r
  Result := '';\r
  REPEAT\r
    C := #0;\r
    Read( C, 1 );\r
    if C <> #0 then\r
    begin\r
      if C = #13 then\r
      begin\r
        C := #0;\r
        Read( C, 1 );\r
        if C <> #10 then Position := Position - 1;\r
        C := #13;\r
      end\r
        else\r
      if C = #10 then\r
        C := #13;\r
      if C <> #13 then\r
        Result := Result + C;\r
    end;\r
  UNTIL C in [ #13, #0 ];\r
end;\r
\r
//[function TStream.WriteStrZ]\r
function TStream.WriteStrZ(S: String): DWORD;\r
var C: Char;\r
begin\r
  if S = '' then\r
    begin\r
      C := #0;\r
      Result := Write( C, 1 );\r
    end\r
  else\r
    Result := Write( S[ 1 ], Length( S ) + 1 );\r
end;\r
\r
//[function TStream.WriteStrEx]\r
function TStream.WriteStrEx(S: String): DWord;\r
begin\r
  result:=length(s);\r
  fmethods.fwrite(@self,result,Sizeof(DWORD));\r
  if result<>0 then result:=fmethods.fwrite(@self,s[1],result);\r
end;\r
\r
//[function TStream.ReadStrExVar]\r
function TStream.ReadStrExVar(var S: String): DWord;\r
begin\r
  fmethods.fread(@self,result,Sizeof(DWORD));\r
  setlength(s,result);\r
  if result<>0 then result:=fmethods.fread(@self,s[1],result);\r
end;\r
\r
//[function TStream.ReadStrEx]\r
function TStream.ReadStrEx: String;\r
begin\r
  readstrexvar(result);\r
end;\r
\r
//[function TStream.WriteStrPas]\r
function TStream.WriteStrPas( S: String ): DWORD;\r
var L: Integer;\r
begin\r
  Result := 0;\r
  L := Length( S );\r
  if L > 255 then L := 255;\r
  if Write( L, 1 ) < 1 then Exit;\r
  Result := 1;\r
  if L > 0 then\r
    Result := Write( S[ 1 ], L ) + 1;\r
end;\r
\r
//[function TStream.ReadStrPas]\r
function TStream.ReadStrPas: String;\r
var L: Byte;\r
begin\r
  Result := '';\r
  if Read( L, 1 ) < 1 then Exit;\r
  SetLength( Result, L );\r
  L := Read( Result[ 1 ], L );\r
  Result := Copy( Result, 1, L );\r
end;\r
\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStream.Seek]\r
function TStream.Seek(MoveTo: integer; MoveMethod: TMoveMethod): DWord;\r
asm\r
        CALL     [EAX].fMethods.fSeek\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStream.Seek(MoveTo: integer; MoveMethod: TMoveMethod): DWord;\r
begin\r
  Result := fMethods.fSeek( @Self, MoveTo, MoveMethod );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TStream.Destroy]\r
destructor TStream.Destroy;\r
asm\r
        PUSH     EAX\r
        PUSH     [EAX].fData.fThread\r
        CALL     [EAX].fMethods.fClose\r
        POP      EAX\r
        CALL     TObj.Free\r
        POP      EAX\r
        CALL     TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TStream.Destroy;\r
begin\r
  fMethods.fClose( @Self );\r
  fData.fThread.Free;\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//+-\r
//[function _NewStream]\r
function _NewStream( const StreamMethods: TStreamMethods ): PStream;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PStream.Create;*){--}\r
  Move( StreamMethods, Result.fMethods, Sizeof( TStreamMethods ) );\r
  Result.fPMethods := @Result.fMethods;\r
end;\r
\r
//+\r
//[function SeekFileStream]\r
function SeekFileStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;\r
begin\r
  Result := FileSeek( Strm.fData.fHandle, MoveTo, MoveFrom );\r
end;\r
\r
//+\r
//[function GetSizeFileStream]\r
function GetSizeFileStream( Strm: PStream ): DWORD;\r
begin\r
  Result := GetFileSize( Strm.fData.fHandle, nil );\r
  if Result = DWORD( -1 ) then Result := 0;\r
end;\r
\r
//[procedure DummySetSize]\r
procedure DummySetSize( Strm: PStream; Value: DWORD );\r
begin\r
end;\r
\r
//[procedure DummyStreamProc]\r
procedure DummyStreamProc(Strm: PStream);\r
begin\r
end;\r
\r
//[function DummyReadWrite]\r
function DummyReadWrite( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
asm\r
  XOR EAX, EAX\r
end;\r
\r
//[function ReadFileStream]\r
function ReadFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
begin\r
  Result := FileRead( Strm.fData.fHandle, Buffer, Count );\r
end;\r
\r
//[function WriteFileStream]\r
function WriteFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
begin\r
  Result := FileWrite( Strm.fData.fHandle, Buffer, Count );\r
end;\r
\r
//[FUNCTION WriteFileStreamEOF]\r
{$IFDEF ASM_VERSION}\r
function WriteFileStreamEOF( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
asm\r
        PUSH     EBX\r
        PUSH     [EAX].TStream.fData.fHandle\r
        CALL     WriteFileStream\r
        XCHG     EBX, EAX\r
        CALL     SetEndOfFile\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WriteFileStreamEOF( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
begin\r
  Result := WriteFileStream( Strm, Buffer, Count );\r
  SetEndOfFile( Strm.fData.fHandle );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WriteFileStreamEOF]\r
\r
//[procedure CloseFileStream]\r
procedure CloseFileStream( Strm: PStream );\r
begin\r
  FileClose( Strm.fData.fHandle );\r
end;\r
\r
//[FUNCTION SeekMemStream]\r
{$IFDEF ASM_VERSION}\r
function SeekMemStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EDX\r
        AND      ECX, $FF\r
        LOOP     @@not_from_cur\r
        ADD      EBX, [EAX].TStream.fData.fPosition\r
@@not_from_cur:\r
        LOOP     @@not_from_end\r
        ADD      EBX, [EAX].TStream.fData.fSize\r
@@not_from_end:\r
        CMP      EBX, [EAX].TStream.fData.fSize\r
        JLE      @@space_ok\r
        PUSH     EAX\r
        MOV      EDX, EBX\r
        CALL     TStream.SetSize\r
        POP      EAX\r
@@space_ok:\r
        XCHG     EAX, EBX\r
        MOV      [EBX].TStream.fData.fPosition, EAX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function SeekMemStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;\r
var NewPos: DWORD;\r
begin\r
  case MoveFrom of\r
  spBegin: NewPos := MoveTo;\r
  spCurrent: NewPos := Strm.fData.fPosition + DWORD( MoveTo );\r
  else //spEnd:\r
       NewPos := Strm.fData.fSize + DWORD( MoveTo );\r
  end;\r
  if NewPos > Strm.fData.fSize then\r
    Strm.SetSize( NewPos );\r
  Strm.fData.fPosition := NewPos;\r
  Result := NewPos;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END SeekMemStream]\r
\r
//[function GetSizeMemStream]\r
function GetSizeMemStream( Strm: PStream ): DWORD;\r
begin\r
  Result := Strm.fData.fSize;\r
end;\r
\r
//[PROCEDURE SetSizeMemStream]\r
{$IFDEF ASM_VERSION}\r
procedure SetSizeMemStream( Strm: PStream; NewSize: DWORD );\r
asm\r
        CMP      [EAX].TStream.fData.fCapacity, EDX\r
        JGE      @@cap_ok\r
        PUSH     EDX\r
        PUSH     EAX\r
        MOV      ECX, [EAX].TStream.fMemory\r
        JECXZ    @@get_mem\r
        TEST     EDX, EDX\r
        JZ       @@free_mem\r
        LEA      EAX, [EAX].TStream.fMemory\r
        CALL     System.@ReallocMem\r
        JMP      @@1\r
@@get_mem:\r
        XCHG     EAX, EDX\r
        CALL     System.@GetMem\r
        XCHG     EDX, EAX\r
        POP      EAX\r
        MOV      [EAX].TStream.fMemory, EDX\r
        JMP      @@2\r
@@free_mem:\r
        XCHG     EDX, [EAX].TStream.fMemory\r
        XCHG     EAX, EDX\r
        CALL     System.@FreeMem\r
@@1:\r
        POP      EAX\r
@@2:\r
        POP      EDX\r
\r
@@cap_ok:\r
        MOV      [EAX].TStream.fData.fSize, EDX\r
        CMP      [EAX].TStream.fData.fPosition, EDX\r
        JLE      @@exit\r
        MOV      [EAX].TStream.fData.fPosition, EDX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure SetSizeMemStream( Strm: PStream; NewSize: DWORD );\r
var S: PStream;\r
begin\r
  S := Strm;\r
  if S.fData.fCapacity < NewSize then\r
  begin\r
    if S.fMemory = nil then\r
    begin\r
      if NewSize <> 0 then\r
         GetMem( S.fMemory, NewSize );\r
    end\r
      else\r
    if NewSize = 0 then\r
    begin\r
      FreeMem( S.fMemory );\r
      S.fMemory := nil;\r
    end\r
      else\r
      ReallocMem( S.fMemory, NewSize );\r
    S.fData.fCapacity := NewSize;\r
  end;\r
  S.fData.fSize := NewSize;\r
  if S.fData.fPosition > S.fData.fSize then\r
     S.fData.fPosition := S.fData.fSize;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END SetSizeMemStream]\r
\r
//[FUNCTION ReadMemStream]\r
{$IFDEF ASM_VERSION}\r
function ReadMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].TStream.fData.fPosition\r
        ADD      EAX, ECX\r
        CMP      EAX, [EBX].TStream.fData.fSize\r
        JLE      @@count_ok\r
        MOV      ECX, [EBX].TStream.fData.fSize\r
        SUB      ECX, [EBX].TStream.fData.fPosition\r
@@count_ok:\r
        PUSH     ECX\r
        MOV      EAX, [EBX].TStream.fMemory\r
        ADD      EAX, [EBX].TStream.fData.fPosition\r
        CALL     System.Move\r
        POP      EAX\r
        ADD      [EBX].TStream.fData.fPosition, EAX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function ReadMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
var S: PStream;\r
begin\r
  S := Strm;\r
  if Count + S.fData.fPosition > S.fData.fSize then\r
     Count := S.fData.fSize - S.fData.fPosition;\r
  Result := Count;\r
  Move( Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Buffer, Result );\r
  Inc( S.fData.fPosition, Result );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END ReadMemStream]\r
\r
//[FUNCTION WriteMemStream]\r
{$IFDEF ASM_VERSION}\r
function WriteMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].TStream.fData.fPosition\r
        ADD      EAX, ECX\r
        CMP      EAX, [EBX].TStream.fData.fSize\r
        PUSH     EDX\r
        PUSH     ECX\r
        JLE      @@count_ok\r
        XCHG     EDX, EAX\r
        MOV      EAX, EBX\r
        CALL     TStream.SetSize\r
@@count_ok:\r
        POP      ECX\r
        POP      EAX\r
        MOV      EDX, [EBX].TStream.fMemory\r
        ADD      EDX, [EBX].TStream.fData.fPosition\r
        PUSH     ECX\r
        CALL     System.Move\r
        POP      EAX\r
        ADD      [EBX].TStream.fData.fPosition, EAX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WriteMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
var S: PStream;\r
begin\r
  S := Strm;\r
  if Count + S.fData.fPosition > S.fData.fSize then\r
     S.SetSize( S.fData.fPosition + Count );\r
  Result := Count;\r
  Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result );\r
  Inc( S.fData.fPosition, Result );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WriteMemStream]\r
\r
//[PROCEDURE CloseMemStream]\r
{$IFDEF ASM_VERSION}\r
procedure CloseMemStream( Strm: PStream );\r
asm\r
        MOV      ECX, [EAX].TStream.fMemory\r
        JECXZ    @@exit\r
        XCHG     EAX, ECX\r
        CALL     System.@FreeMem\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure CloseMemStream( Strm: PStream );\r
var S: PStream;\r
begin\r
  S := Strm;\r
  if S.fMemory <> nil then\r
    FreeMem( S.fMemory );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CloseMemStream]\r
\r
const\r
  BaseFileMethods: TStreamMethods = (\r
    fSeek: SeekFileStream;\r
    fGetSiz: GetSizeFileStream;\r
    fSetSiz: DummySetSize;\r
    fRead: DummyReadWrite;\r
    fWrite: DummyReadWrite;\r
    fClose: CloseFileStream;\r
    fCustom: nil;\r
  );\r
\r
  MemoryMethods: TStreamMethods = (\r
    fSeek: SeekMemStream;\r
    fGetSiz: GetSizeMemStream;\r
    fSetSiz: SetSizeMemStream;\r
    fRead: ReadMemStream;\r
    fWrite: WriteMemStream;\r
    fClose: CloseMemStream;\r
    fCustom: nil;\r
  );\r
\r
// by Roman Vorobets:\r
//[procedure SetSizeFileStream]\r
procedure SetSizeFileStream( Strm: PStream; NewSize: DWORD );\r
var\r
  P: DWORD;\r
begin\r
  P:=Strm.Position;\r
  Strm.Position:=NewSize;\r
  SetEndOfFile(Strm.Handle);\r
  if P < NewSize then\r
    Strm.Position:=P;\r
end;\r
\r
//[function NewFileStream]\r
function NewFileStream( const FileName: String; Options: DWORD ): PStream;\r
begin\r
  Result := _NewStream( BaseFileMethods );\r
  Result.fMethods.fRead := ReadFileStream;\r
  Result.fMethods.fWrite := WriteFileStream; // not WriteStreamEOF, Àëåêñåé Øóâàëîâ\r
  Result.fMethods.fSetSiz := SetSizeFileStream;\r
  Result.fData.fHandle := FileCreate( FileName, Options );\r
end;\r
\r
//[FUNCTION NewReadFileStream]\r
{$IFDEF ASM_VERSION}\r
function NewReadFileStream( const FileName: String ): PStream;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, offset[BaseFileMethods]\r
        CALL     _NewStream\r
        MOV      [EAX].TStream.fMethods.fRead, offset[ReadFileStream]\r
        XCHG     EBX, EAX\r
        MOV      EDX, ofOpenRead or ofOpenExisting or ofShareDenyWrite\r
        CALL     FileCreate\r
        MOV      [EBX].TStream.fData.fHandle, EAX\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewReadFileStream( const FileName: String ): PStream;\r
begin\r
  Result := _NewStream( BaseFileMethods );\r
  Result.fMethods.fRead := ReadFileStream;\r
  Result.fData.fHandle := FileCreate( FileName,\r
                                      ofOpenRead or ofShareDenyWrite or ofOpenExisting );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewReadFileStream]\r
\r
//[FUNCTION NewWriteFileStream]\r
{$IFDEF ASM_VERSION}\r
function NewWriteFileStream( const FileName: String ): PStream;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, offset[BaseFileMethods]\r
        CALL     _NewStream\r
        MOV      [EAX].TStream.fMethods.fWrite, offset[WriteFileStreamEOF]\r
        MOV      [EAX].TStream.fMethods.fSetSiz, offset[SetSizeFileStream]\r
        XCHG     EBX, EAX\r
        MOV      EDX, ofOpenWrite or ofOpenAlways or ofShareDenyWrite\r
        CALL     FileCreate\r
        MOV      [EBX].TStream.fData.fHandle, EAX\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewWriteFileStream( const FileName: String ): PStream;\r
begin\r
  Result := _NewStream( BaseFileMethods );\r
  Result.fMethods.fWrite := WriteFileStreamEOF;\r
  Result.fMethods.fSetSiz := SetSizeFileStream;\r
  Result.fData.fHandle := FileCreate( FileName,\r
                                      //ofOpenWrite or ofCreateAlways );\r
                                      ofOpenWrite or ofOpenAlways or ofShareDenyWrite );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewWriteFileStream]\r
\r
//[FUNCTION NewReadWriteFileStream]\r
{$IFDEF ASM_noVERSION}\r
function NewReadWriteFileStream( const FileName: String ): PStream;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, offset[BaseFileMethods]\r
        CALL     _NewStream\r
        MOV      [EAX].TStream.fMethods.fRead, offset[ReadFileStream]\r
        MOV      [EAX].TStream.fMethods.fWrite, offset[WriteFileStream]\r
        MOV      [EAX].TStream.fMethods.fSetSiz, offset[SetSizeFileStream]\r
        XCHG     EBX, EAX\r
\r
        PUSH     EAX\r
        CALL     FileExists\r
        MOV      EDX, ofOpenReadWrite or ofCreateAlways or ofShareDenyWrite\r
        ADD      DH, AL // $200 (ofCreateAlways) -> $300 (ofCreateExisting)\r
        POP      EAX\r
\r
        CALL     FileCreate\r
        MOV      [EBX].TStream.fData.fHandle, EAX\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewReadWriteFileStream( const FileName: String ): PStream;\r
var Creation: DWORD;\r
begin\r
  Result := _NewStream( BaseFileMethods );\r
  Result.fMethods.fRead := ReadFileStream;\r
  Result.fMethods.fWrite := WriteFileStream;\r
  Result.fMethods.fSetSiz := SetSizeFileStream;\r
  Creation := ofCreateAlways;\r
  if FileExists( FileName ) then Creation := ofOpenExisting;\r
  Result.fData.fHandle := FileCreate( FileName,\r
                          ofOpenReadWrite or Creation or ofShareDenyWrite );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewReadWriteFileStream]\r
\r
//[function NewMemoryStream]\r
function NewMemoryStream: PStream;\r
begin\r
  Result := _NewStream( MemoryMethods );\r
end;\r
\r
//[FUNCTION WriteExMemoryStream]\r
{$IFDEF ASM_VERSION}\r
function WriteExMemoryStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].TStream.fData.fSize\r
        SUB      EAX, [EBX].TStream.fData.fPosition\r
        CMP      EAX, ECX\r
        JGE      @@1\r
        XCHG     ECX, EAX\r
@@1:\r
        PUSH     EDX\r
        PUSH     ECX\r
        JLE      @@count_ok\r
        XCHG     EDX, EAX\r
        MOV      EAX, EBX\r
        CALL     TStream.SetSize\r
@@count_ok:\r
        POP      ECX\r
        POP      EAX\r
        MOV      EDX, [EBX].TStream.fMemory\r
        ADD      EDX, [EBX].TStream.fData.fPosition\r
        PUSH     ECX\r
        CALL     System.Move\r
        POP      EAX\r
        ADD      [EBX].TStream.fData.fPosition, EAX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION}\r
function WriteExMemoryStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;\r
var S: PStream;\r
begin\r
  S := Strm;\r
  if Count + S.fData.fPosition > S.fData.fSize then\r
    Count := S.fData.fSize - S.fData.fPosition;\r
  Result := Count;\r
  Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result );\r
  Inc( S.fData.fPosition, Result );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WriteExMemoryStream]\r
\r
//[procedure DummyClose_ExMemStream]\r
procedure DummyClose_ExMemStream( Strm: PStream );\r
begin\r
  // nothing to do - ignore call (memory is not released by any way)\r
end;\r
\r
//[function NewExMemoryStream]\r
function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream;\r
begin\r
  Result := NewMemoryStream;\r
  Result.fMemory := ExistingMem;\r
  Result.fData.fCapacity := Size;\r
  Result.fData.fSize := Size;\r
  Result.fMethods.fWrite := WriteExMemoryStream;\r
  Result.fMethods.fSetSiz := DummySetSize;\r
  Result.fMethods.fClose := DummyClose_ExMemStream;\r
end;\r
\r
//*\r
//[function Stream2Stream]\r
function Stream2Stream( Dst, Src: PStream; Count: DWORD ): DWORD;\r
var Buf: Pointer;\r
begin\r
  if Src.fMemory <> nil then\r
  begin\r
     if Src.fData.fPosition + Count > Src.fData.fSize then\r
        Count := Src.fData.fSize - Src.fData.fPosition;\r
     Result := Dst.Write( Pointer(DWORD(Src.fMemory)+Src.fData.fPosition)^,\r
                   Count );\r
     Inc( Src.fData.fPosition, Result );\r
  end\r
     else\r
  if Dst.fMemory <> nil then\r
  begin\r
    if Dst.fData.fPosition + Count > Dst.fData.fSize then\r
       Dst.SetSize( Dst.fData.fPosition + Count );\r
    Result := Src.Read( Pointer( DWORD( Dst.fMemory ) + Dst.fData.fPosition )^,\r
                        Count );\r
    Inc( Dst.fData.fPosition, Result );\r
  end\r
     else\r
  begin\r
    GetMem( Buf, Count );\r
    Count := Src.Read( Buf^, Count );\r
    Result := Dst.Write( Buf^, Count );\r
    FreeMem( Buf );\r
  end;\r
end;\r
\r
//[function Stream2StreamEx]\r
function Stream2StreamEx( Dst, Src: PStream; Count: DWORD ): DWORD;\r
begin\r
  Result := Stream2StreamExBufSz( Dst, Src, Count, 65536 );\r
end;\r
\r
//[function Stream2StreamExBufSz]\r
function Stream2StreamExBufSz( Dst, Src: PStream; Count, BufSz: DWORD ): DWORD;\r
var\r
  buf:pointer;\r
  rd, wr:dword;\r
begin\r
  if count=0 then result:=0 else\r
  begin\r
    result:=0;\r
    BufSz := Min( BufSz, Count );\r
    if BufSz = 0 then BufSz := Count;\r
    getmem(buf,BufSz);\r
    repeat\r
      if count<BufSz then rd:=count else rd:=BufSz;\r
      rd:=src.read(buf^,rd);\r
      wr := dst.write(buf^,rd);\r
      inc(result,wr);\r
      dec(Count, rd);\r
    until (rd<>BufSz) or (Count=0);\r
    freemem(buf);\r
  end;\r
end;\r
\r
//[FUNCTION Resource2Stream]\r
{$IFDEF ASM_VERSION}\r
function Resource2Stream( DestStrm : PStream; Inst : HInst;\r
                          ResName : PChar; ResType : PChar ): Integer;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, EDX // EBX = Inst\r
        PUSH     EAX      // DestStrm\r
        PUSH     ResType\r
        PUSH     ECX\r
        PUSH     EDX\r
        CALL     FindResource\r
        TEST     EAX, EAX\r
        JZ       @@exit0\r
\r
        PUSH     EAX\r
        PUSH     EBX\r
        PUSH     EAX\r
        PUSH     EBX\r
        CALL     SizeofResource\r
        XCHG     EBX, EAX\r
        CALL     LoadResource\r
        TEST     EAX, EAX\r
        JZ       @@exit0\r
        XCHG     ESI, EAX\r
\r
        PUSH     ESI\r
        CALL     GlobalLock\r
        TEST     EAX, EAX\r
        JNZ      @@P_ok\r
\r
        CALL     GetLastError\r
        CMP      EAX, ERROR_INVALID_HANDLE\r
        JNZ      @@exit_00\r
        MOV      EAX, ESI\r
\r
@@P_ok:\r
        XCHG     EDX, EAX\r
        POP      EAX // DestStrm\r
        PUSH     EDX\r
        MOV      ECX, EBX\r
        CALL     TStream.Write\r
\r
        //EAX = Result (length of written data)\r
        XCHG     EBX, EAX\r
        POP      EAX\r
        CMP      ESI, EAX\r
        JE       @@not_unlock\r
\r
        PUSH     ESI\r
        CALL     GlobalUnlock\r
@@not_unlock:\r
        XCHG     EAX, EBX\r
        JMP      @@exit\r
\r
@@exit_00:\r
        XOR      EAX, EAX\r
@@exit0:\r
        POP      ECX\r
@@exit:\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Resource2Stream( DestStrm : PStream; Inst : HInst;\r
                          ResName : PChar; ResType : PChar ): Integer;\r
var R : HRSRC;\r
    G : HGlobal;\r
    P : PChar;\r
    Sz : DWORD;\r
    E : Integer;\r
begin\r
  Result := 0;\r
  R := FindResource( Inst, ResName, ResType );\r
  if R <> 0 then\r
  begin\r
    Sz := SizeofResource( Inst, R );\r
    G := LoadResource( Inst, R );\r
    if G <> 0 then\r
    begin\r
      P := GlobalLock( G );\r
      if P = nil then\r
      begin\r
        E := GetLastError;\r
        if E = ERROR_INVALID_HANDLE then\r
           P := Pointer( G )\r
        else\r
           Exit;\r
      end;\r
      Result := DestStrm.Write( P^, Sz );\r
      if P <> Pointer( G ) then\r
        GlobalUnlock( G );\r
      //FreeResource( G );\r
      { from Win32.hlp: "You do not need to call the FreeResource\r
        function to free a resource loaded by using the LoadResource\r
        function." }\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Resource2Stream]\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
///////////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                        I  N  I  -  F  I  L  E  S\r
//\r
//\r
///////////////////////////////////////////////////////////////////////////\r
\r
\r
{ TIniFile }\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TIniFile.Destroy]\r
destructor TIniFile.Destroy;\r
asm     //cmd    //opd\r
        PUSH     EAX\r
        LEA      EDX, [EAX].fFileName\r
        PUSH     EDX\r
        LEA      EAX, [EAX].fSection\r
        CALL     System.@LStrClr\r
        POP      EAX\r
        CALL     System.@LStrClr\r
        POP      EAX\r
        CALL     TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TIniFile.Destroy;\r
begin\r
  fFileName := '';\r
  fSection := '';\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFNDEF _D5orHigher}\r
// Place here correct definition for WritePrivateProfileStruct\r
// and GetPrivateProfileStruct (a bug in Delphi2, Delphi3 and Delphi4)\r
//[API WritePrivateProfileStruct]\r
function WritePrivateProfileStruct(lpszSection, lpszKey: PChar;\r
  lpStruct: Pointer; uSizeStruct: UINT; szFile: PChar): BOOL; stdcall;\r
  external kernel32 name 'WritePrivateProfileStructA';\r
//[API GetPrivateProfileStruct]\r
function GetPrivateProfileStruct(lpszSection, lpszKey: PAnsiChar;\r
  lpStruct: Pointer; uSizeStruct: UINT; szFile: PAnsiChar): BOOL; stdcall;\r
  external kernel32 name 'GetPrivateProfileStructA';\r
\r
// + by Slava A. Gavrik:\r
////////////////////////////////////////////////////////////////////////////\r
//[function WritePrivateProfileSection]\r
function WritePrivateProfileSection(lpAppName, lpString,\r
  lpFileName: PChar): BOOL; stdcall;\r
  external kernel32 name 'WritePrivateProfileSectionA';\r
//[function GetPrivateProfileSection]\r
function GetPrivateProfileSection(lpAppName: PChar; lpReturnedString: PChar;\r
  nSize: DWORD; lpFileName: PChar): DWORD; stdcall;\r
  external kernel32 name 'GetPrivateProfileSectionA';\r
\r
//[function GetPrivateProfileSectionNames]\r
function GetPrivateProfileSectionNames(lpszReturnBuffer: PChar; nSize:\r
DWORD;\r
  lpFileName: PChar): DWORD; stdcall;\r
  external kernel32 name 'GetPrivateProfileSectionNamesA';\r
////////////////////////////////////////////////////////////////////////////\r
{$ENDIF}\r
\r
\r
//[procedure TIniFile.ClearAll]\r
procedure TIniFile.ClearAll;\r
begin\r
  WritePrivateProfileString( nil, nil, nil,\r
                             PChar( fFileName ) );\r
end;\r
\r
//[procedure TIniFile.ClearKey]\r
procedure TIniFile.ClearKey(const Key: String);\r
begin\r
  WritePrivateProfileString( PChar( fSection ), PChar( Key ), nil,\r
                             PChar( fFileName ) );\r
end;\r
\r
//[procedure TIniFile.ClearSection]\r
procedure TIniFile.ClearSection;\r
begin\r
  WritePrivateProfileString( PChar( fSection ), nil, nil,\r
                             PChar( fFileName ) );\r
end;\r
\r
//[function TIniFile.ValueBoolean]\r
function TIniFile.ValueBoolean(const Key: String; Value: Boolean): Boolean;\r
begin\r
  if fMode = ifmRead then\r
     Result := GetPrivateProfileInt( PChar( fSection ), PChar( Key ),\r
               Integer( Value ), PChar( fFileName ) ) <> 0\r
  else\r
  begin\r
    WritePrivateProfileString( PChar( fSection ), PChar( Key ),\r
              PChar( Int2Str( Integer( Value ) ) ), PChar( fFileName ) );\r
    Result := Value;\r
  end;\r
end;\r
\r
//[function TIniFile.ValueData]\r
function TIniFile.ValueData(const Key: String; Value: Pointer;\r
  Count: Integer): Boolean;\r
begin\r
  if fMode = ifmRead then\r
     Result := GetPrivateProfileStruct( PChar( fSection ), PChar( Key ),\r
               Value, Count, PChar( fFileName ) )\r
  else\r
     Result := WritePrivateProfileStruct( PChar( fSection ), PChar( Key ),\r
               Value, Count, PChar( fFileName ) );\r
end;\r
\r
//[function TIniFile.ValueInteger]\r
function TIniFile.ValueInteger(const Key: String; Value: Integer): Integer;\r
begin\r
  if fMode = ifmRead then\r
     Result := GetPrivateProfileInt( PChar( fSection ), PChar( Key ),\r
               Integer( Value ), PChar( fFileName ) )\r
  else\r
  begin\r
     Result := Value;\r
     WritePrivateProfileString( PChar( fSection ), PChar( Key ),\r
               PChar( Int2Str( Value ) ), PChar( fFileName ) );\r
  end;\r
end;\r
\r
//[function TIniFile.ValueString]\r
function TIniFile.ValueString(const Key, Value: String): String;\r
var\r
  Buffer: array[0..2047] of Char;\r
begin\r
  if fMode = ifmRead then\r
  begin\r
    Buffer[ 0 ] := #0;\r
    GetPrivateProfileString(PChar(fSection),\r
         PChar(Key), PChar(Value), Buffer, SizeOf(Buffer), PChar(fFileName));\r
    Result := Buffer;\r
  end\r
    else\r
  begin\r
     Result := Value;\r
     WritePrivateProfileString( PChar( fSection ), PChar( Key ),\r
               PChar( Value ), PChar( fFileName ) );\r
  end;\r
end;\r
\r
//[function OpenIniFile]\r
function OpenIniFile( const FileName: String ): PIniFile;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PIniFile.Create;*){--}\r
  Result.fFileName := FileName;\r
end;\r
\r
/////////////////////////////////////////////////// GetSectionNames, SectionData\r
// - by Vyacheslav A. Gavrik :\r
\r
const\r
  IniBufferSize = 32767;\r
  IniBufferStrSize = IniBufferSize+4;         /// äëÿ ìàõèíàöèé :)\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure _FillStrList]\r
procedure _FillStrList;    // Ýòà ÷àñòü êîäà îáùàÿ äëÿ äâóõ ñëåäóþùèõ ïðîöåäóð\r
asm\r
///////////////////////////////\r
        OR      EAX,0\r
        JE      @@EXIT                  //ERROR\r
//        LEA     EAX,[EAX-IniBufferSize]\r
//        JE      @@EXIT\r
//      âîçìîæíà íåõâàòêà Áóôåðà... â ïðèíöèïå íå îøèáêà :)\r
//      âîçâðàùàåì ÷òî âëåçëî...\r
//////////////////////////////\r
@@LOOP:\r
        LEA     EAX,[ESI+4]\r
        CALL    StrLen\r
        MOV     [ESI],EAX\r
        LEA     EDX,[ESI+4]\r
        INC     EAX\r
        ADD     ESI,EAX\r
\r
        MOV     EAX,EDI\r
\r
        CALL    TStrList.ADD\r
\r
        CMP     byte ptr [ESI+4],0\r
        JNE     @@LOOP\r
\r
@@EXIT:\r
        POP     EAX\r
        CALL    System.@FreeMem\r
\r
\r
        POP     ECX\r
        POP     EBX\r
        POP     EDI\r
        POP     ESI\r
end;\r
\r
\r
//[procedure TIniFile.GetSectionNames]\r
procedure TIniFile.GetSectionNames(Names: PStrList);\r
asm\r
        PUSH    ESI\r
        PUSH    EDI\r
        PUSH    EBX\r
        PUSH    ECX\r
\r
        MOV     EBX,EAX\r
        MOV     EAX, IniBufferStrSize\r
        MOV     EDI,EDX\r
\r
        CALL    System.@GetMem\r
        MOV     ESI,EAX\r
        PUSH    EAX\r
\r
        PUSH    [EBX].fFileName\r
        MOV     EAX,IniBufferSize\r
        PUSH    EAX\r
\r
        LEA     EAX,[ESI+4]\r
        PUSH    EAX\r
\r
        CALL    GetPrivateProfileSectionNames\r
        JMP     _FillStrList\r
end;\r
\r
//[procedure TIniFile.SectionData]\r
procedure TIniFile.SectionData(Names: PStrList);\r
asm\r
        PUSH    ESI\r
        PUSH    EDI\r
        PUSH    EBX\r
        PUSH    ECX\r
\r
        MOV     EBX,EAX\r
        MOV     EAX, IniBufferStrSize\r
        MOV     EDI,EDX\r
\r
        CALL    System.@GetMem\r
        MOV     ESI,EAX\r
        PUSH    EAX\r
\r
        OR     [EBX].fMode,0\r
        JNE     @@DOWrite\r
\r
        PUSH    [EBX].fFileName\r
        MOV     EAX,IniBufferSize\r
        PUSH    EAX\r
\r
        LEA     EAX,[ESI+4]\r
        PUSH    EAX\r
        PUSH    [EBX].fSection\r
\r
        CALL    GetPrivateProfileSection\r
        JMP     _FillStrList\r
\r
@@DOWrite:\r
\r
        PUSH    EBX\r
        PUSH    ESI\r
        PUSH    EDX\r
        PUSH    EBP\r
\r
        MOV     EDX,0\r
        MOV     EBP,[EDI].TStrList.fCount\r
        MOV     EBX,IniBufferSize-2 // îñòàâèì ìåñòî äëÿ #0#0\r
\r
{ECM+++>} OR      EBP,EBP  // otherwise GetPChars when StrList.Count = 0 crashed\r
\r
@@LOOP:\r
        JE      @@ENDLOOP\r
\r
        OR      EBX,EBX\r
        JE      @@ENDLOOP\r
\r
        PUSH    EDX\r
        MOV     EAX,EDI\r
        CALL    TStrList.GetPChars\r
\r
        PUSH    EAX\r
        CALL    StrLen\r
        POP     EAX\r
\r
        XOR     ECX,-1\r
        MOV     EDX,ESI\r
\r
        SUB     EBX,ECX\r
        JA      @@L1\r
        ADD     ECX,EBX\r
        XOR     EBX,EBX\r
@@L1:\r
\r
        ADD     ESI,ECX\r
\r
        CALL    MOVE\r
@@L2:\r
        POP     EDX\r
        INC     EDX\r
        DEC     EBP\r
        JMP     @@LOOP\r
@@ENDLOOP:\r
        MOV     WORD PTR [ESI],0\r
\r
        POP     EBP\r
        POP     EDX\r
        POP     ESI\r
        POP     EBX\r
///////////////////////////////////\r
        MOV     EAX,EBX                 // íîäî î÷èùàòü\r
        CALL    ClearSection\r
//////////////////////////////////\r
\r
        PUSH    [EBX].fFileName\r
        PUSH    ESI\r
        PUSH    [EBX].fSection\r
\r
        CALL    WritePrivateProfileSection\r
\r
        POP     EAX\r
        CALL    System.@FreeMem\r
\r
        POP     ECX\r
        POP     EBX\r
        POP     EDI\r
        POP     ESI\r
\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
\r
//[procedure TIniFile.GetSectionNames]\r
procedure TIniFile.GetSectionNames(Names: PStrList);\r
var\r
  i:integer;\r
  Pc:PChar;\r
  PcEnd:PChar;\r
  Buffer:Pointer;\r
begin\r
  GetMem(Buffer,IniBufferSize);\r
  Pc:=Buffer;\r
  i := GetPrivateProfileSectionNames(Buffer, IniBufferSize, PChar(fFileName));\r
  PcEnd:=Pc+i;\r
  repeat\r
    Names.Add(Pc);\r
    Pc:=PC+Length(PC)+1;\r
  until PC>=PcEnd;\r
  FreeMem(Buffer);\r
end;\r
\r
//[procedure TIniFile.SectionData]\r
procedure TIniFile.SectionData(Names: PStrList);\r
var\r
  i:integer;\r
  Pc:PChar;\r
  PcEnd:PChar;\r
  Buffer:Pointer;\r
begin\r
  GetMem(Buffer,IniBufferSize);\r
  Pc:=Buffer;\r
  if fMode = ifmRead then\r
  begin\r
    i:=GetPrivateProfileSection(PChar(fSection), Buffer, IniBufferSize, PChar(fFileName));\r
    PcEnd:=Pc+i;\r
    while PC < PcEnd do // Chg by ECM from REPEAT-UNTIL: i=0 (empty section) => Names.Count=1\r
    begin\r
      Names.Add(Pc);\r
      Pc:=PC+Length(PC)+1;\r
    end;\r
  end else\r
  begin\r
    for i:= 0 to Names.Count-1 do\r
    begin\r
      StrCopy(Pc,Names.ItemPtrs[i]);\r
      Pc:=PC+Length(PC)+1;\r
    end;\r
    Pc[0]:=#0;\r
    ClearSection;\r
    WritePrivateProfileSection(PChar(fSection), Buffer, PChar(fFileName));\r
\r
  end;\r
  FreeMem(Buffer);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//////////////////////////////////////////////////////////////////////\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
/////////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                                M  E  N  U\r
//\r
//\r
/////////////////////////////////////////////////////////////////////////\r
\r
{ -- Menu implementation -- }\r
\r
//[FUNCTION MakeAccelerator]\r
{$IFDEF ASM_VERSION}\r
function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;\r
asm\r
        MOVZX    EAX, AL\r
        PUSH     EAX\r
        MOV      [ESP+1], DX\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;\r
begin\r
  Result.fVirt := fVirt;\r
  Result.Key := Key;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END MakeAccelerator]\r
\r
//[FUNCTION GetAcceleratorText]\r
function GetAcceleratorText( const Accelerator: TMenuAccelerator ): string;\r
var\r
  KeyName: array[0..255] of Char;\r
\r
  procedure AddKeyName( Code: Integer );\r
  begin\r
    Code := MapVirtualKey(Code, 0);\r
    if Code = 0 then exit;\r
    if GetKeyNameText(Code shl 16, KeyName, SizeOf(KeyName)) > 0 then begin\r
      if Result <> '' then\r
        Result := Result + '+';\r
      Result := Result + KeyName;\r
    end;\r
  end;\r
\r
begin\r
  Result := '';\r
  with Accelerator do begin\r
    if fVirt and FCONTROL <> 0 then\r
      AddKeyName(VK_CONTROL);\r
    if fVirt and FSHIFT <> 0 then\r
      AddKeyName(VK_SHIFT);\r
    if fVirt and FALT <> 0 then\r
      AddKeyName(VK_ALT);\r
    if fVirt and $20 <> 0 then\r
      AddKeyName(VK_LWIN);\r
    if fVirt and $40 <> 0 then\r
      AddKeyName(VK_RWIN);\r
\r
    AddKeyName(Key);\r
  end;\r
end;\r
//[END GetAcceleratorText]\r
\r
\r
const\r
  MIDATA_CHECKITEM = $40000000;\r
  MIDATA_RADIOITEM = $80000000;\r
\r
//[function WndProcMenu]\r
{$IFNDEF NEW_MENU_ACCELL}\r
function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
var M, M1: PMenu;\r
    Idx: Integer;\r
    Id: Integer;\r
begin\r
  Result := False;\r
  if Msg.message = WM_COMMAND then\r
  begin\r
     if (Msg.lParam = 0) and (HIWORD( Msg.wParam ) <= 1) then\r
     begin\r
       M := PMenu( Sender.fMenuObj );\r
       while M <> nil do\r
       begin\r
         Id := LoWord( Msg.wParam );\r
         M1 := M.Items[ Id ];\r
         if M1 <> nil then\r
         begin\r
           Result := True;\r
           Rslt := 0;\r
           Idx := M.IndexOf( M1 );\r
           M.fByAccel := HiWord( Msg.wParam ) <> 0;\r
           if M1.FRadioGroup <> 0 then\r
             M1.RadioCheckItem\r
           else\r
           if M1.FIsCheckItem then\r
             M1.Checked := not M1.Checked;\r
           if Assigned(M1.FOnMenuItem) then\r
             M1.FOnMenuItem( M, Idx )\r
           else if Assigned( M.FOnMenuItem ) then\r
             M.FOnMenuItem( M, Idx );\r
           //M.FProcessed := True;\r
           break;\r
         end;\r
         M := M.fNextMenu;\r
       end;\r
     end;\r
  end;\r
end;\r
\r
{$ELSE}\r
\r
function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
\r
  function ProcessMenuItem(M: PMenu; Id: Integer): Boolean;\r
  var\r
    M1: PMenu;\r
    Idx: Integer;\r
  begin\r
    M1 := M.Items[ Id ];\r
    Result := (M1 <> nil);\r
    if Result then\r
    begin\r
      Idx := M.IndexOf( M1 );\r
      M.fByAccel := HiWord( Msg.wParam ) <> 0;\r
      if M1.FRadioGroup <> 0 then\r
        M1.RadioCheckItem\r
      else\r
      if M1.FIsCheckItem then\r
        M1.Checked := not M1.Checked;\r
      if Assigned(M1.FOnMenuItem) then begin\r
      {$IFDEF USE_MENU_CURCTL} // fixed\r
        M.fCurCtl := Sender;   // fixed\r
      {$ENDIF}                 // fixed\r
        M1.FOnMenuItem( M, Idx )\r
      end\r
      else if Assigned( M.FOnMenuItem ) then\r
        M.FOnMenuItem( M, Idx );\r
    end;\r
  end;\r
\r
var\r
  M: PMenu;\r
  Id: Integer;\r
begin\r
  Result := False;\r
  if Msg.message = WM_COMMAND then\r
    if (Msg.lParam = 0) and (HIWORD( Msg.wParam ) <= 1) then begin\r
      Id := LoWord(Msg.wParam);\r
      M := PMenu(Sender.fAutoPopupMenu);\r
      if (M <> nil) and ProcessMenuItem(M, Id) then begin\r
        Result := True;\r
        Rslt := 0;\r
      end\r
      else begin\r
        M := PMenu(Sender.fMenuObj);\r
        while M <> nil do begin\r
          if ProcessMenuItem(M, Id) then begin\r
            Result := True;\r
            Rslt := 0;\r
            Break;\r
          end;\r
          M := M.fNextMenu;\r
        end;\r
      end;\r
    end;\r
end;\r
{$ENDIF}\r
\r
\r
var FDynamicMenuID: DWORD = $1000;\r
\r
//[function NewMenu]\r
function NewMenu( AParent : PControl; MaxCmdReserve : DWORD; const Template : array of PChar;\r
                      aOnMenuItem: TOnMenuItem ): PMenu;\r
var M: PMenu;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PMenu.Create;*){--}\r
  Result.FVisible := TRUE;\r
  Result.FPopupFlags := TPM_LEFTALIGN or TPM_LEFTBUTTON;\r
  Result.FItems := NewList;\r
  Result.FOnMenuItem := aOnMenuItem;\r
  if (High(Template)>=0) and (Template[0] <> nil) then\r
  begin\r
    if (AParent <> nil) and (AParent.fMenuObj = nil) and not AParent.fIsControl then\r
      Result.FHandle := CreateMenu\r
    else\r
      Result.FHandle := CreatePopupMenu;\r
    Result.FillMenuItems( Result.FHandle, 0, Template );\r
  end;\r
  if assigned( AParent ) then\r
  begin\r
    Result.FControl := AParent;\r
    if AParent.fMenuObj <> nil then\r
    begin\r
      // add popup menu to the end of menu chain\r
      M := PMenu( AParent.fMenuObj );\r
      while M.fNextMenu <> nil do\r
        M := M.fNextMenu;\r
      M.fNextMenu := Result;\r
    end\r
       else\r
    begin\r
      if not AParent.fIsControl then\r
        AParent.Menu := Result.FHandle;\r
      AParent.fMenuObj := Result;\r
      AParent.AttachProc( WndProcMenu );\r
    end;\r
  end;\r
end;\r
//[END NewMenu]\r
\r
//[function NewMenuEx]\r
function NewMenuEx( AParent : PControl; FirstCmd : Integer; const Template : array of PChar;\r
                      aOnMenuItems: array of TOnMenuItem ): PMenu;\r
begin\r
  Result := NewMenu( AParent, FirstCmd, Template, nil );\r
  Result.AssignEvents( 0, aOnMenuItems );\r
end;\r
//[END NewMenuEx]\r
\r
{ TMenu }\r
\r
const\r
  Breaks: array[ TMenuBreak ] of DWORD = ( 0, MFT_MENUBREAK, MFT_MENUBARBREAK );\r
\r
{ + by AK - Andrzej Kubaszek }\r
//[function MenuStructSize]\r
function MenuStructSize: Integer;\r
begin\r
  Result := 44;\r
  if not( WinVer in [wv31, wv95, wvNT] ) then\r
    Result := {48=} Sizeof( TMenuItemInfo );\r
end;\r
\r
//[destructor TMenu.Destroy]\r
destructor TMenu.Destroy;\r
var Next, Prnt: PMenu;\r
begin\r
  if Count > 0 then\r
  begin\r
    FItems.ReleaseObjects;\r
    FItems := NewList;\r
  end;\r
  if FParent <> nil then\r
  begin\r
    Prnt := FParent;\r
    FParent := nil;\r
    Next := Prnt.RemoveSubMenu( FId );\r
    Prnt.FItems.Remove( @ Self );\r
    if Next = nil then Exit;\r
  end;\r
   if (FControl <> nil) and (FControl.fMenu = FHandle) and (FHandle <> 0) then\r
   begin\r
     //if FControl.fHandle <> 0 then\r
     begin\r
       Windows.SetMenu( FControl.fHandle, 0 );\r
       // this removes main menu from window, but does not destroy it\r
     end;\r
     FControl.fMenu := 0;\r
     Next := PMenu( FControl.fMenuObj );\r
     while Next <> nil  do\r
     begin\r
       if Next.fNextMenu = @Self then\r
       begin\r
         Next.fNextMenu := fNextMenu;\r
         break;\r
       end;\r
       Next := Next.fNextMenu;\r
     end;\r
   end;\r
   Next := fNextMenu;\r
   if FBitmap <> 0 then\r
     Bitmap := 0;\r
   if FHandle <> 0 then\r
     DestroyMenu( FHandle );\r
   FCaption := '';\r
   FItems.Free;\r
   inherited;\r
   Next.Free;\r
   // all later created (popup) menus (of the same control)\r
   // are destroyed too\r
end;\r
\r
//[function TMenu.GetInfo]\r
function TMenu.GetInfo( var MII: TMenuItemInfo ): Boolean;\r
begin\r
  MII.cbSize := MenuStructSize;\r
  Result := GetMenuItemInfo( Parent.FHandle, FId, FALSE,\r
            Windows.PMenuitemInfo( @ MII )^ );\r
end;\r
\r
//[procedure TMenu.RedrawFormMenuBar]\r
procedure TMenu.RedrawFormMenuBar;\r
var C: PControl;\r
begin\r
  C := TopParent.FControl;\r
  if not AppletTerminated then\r
  if (C <> nil) and (Pointer( C.fMenuObj ) = Pointer( TopParent )) then\r
    DrawMenuBar( C.FHandle );\r
end;\r
\r
//[function TMenu.SetInfo]\r
function TMenu.SetInfo( var MII: TMenuItemInfo ): Boolean;\r
var H: THandle;\r
begin\r
  MII.cbSize := MenuStructSize;\r
  H := FHandle;\r
  if FParent <> nil then\r
    H := FParent.FHandle;\r
  Result := SetMenuItemInfo( H, FId, FALSE, Windows.PMenuitemInfo( @ MII )^ );\r
  if Result and ((FParent = nil) or (FParent.FParent = nil)) then {YS}\r
    RedrawFormMenuBar;\r
end;\r
\r
//[function TMenu.SetTypeInfo]\r
function TMenu.SetTypeInfo( var MII: TMenuItemInfo ): Boolean;\r
begin\r
  if not FIsSeparator then\r
  begin\r
    if FBmpItem = 0 then\r
      MII.dwTypeData := PChar( FCaption )\r
    else\r
      MII.dwTypeData := Pointer( FBmpItem );\r
    MII.cch := Length( FCaption );\r
  end;\r
  Result := SetInfo( MII );\r
end;\r
\r
//[function TMenu.GetTopParent]\r
function TMenu.GetTopParent: PMenu;\r
begin\r
  Result := @ Self;\r
  while Result.FParent <> nil do\r
    Result := Result.FParent;\r
end;\r
\r
//[function TMenu.GetControl]\r
function TMenu.GetControl: PControl;\r
begin\r
  Result := TopParent.FControl;\r
end;\r
\r
//[function TMenu.GetItems]\r
function TMenu.GetItems( Id: HMenu ): PMenu;\r
  function SearchItems( ParentMenu: PMenu; var FromIdx: Integer ): PMenu;\r
  var I: Integer;\r
  begin\r
    Result := ParentMenu;\r
    if Id = HMenu( FromIdx ) then Exit;\r
    if (Id >= 4096) and (DWORD( ParentMenu.FId ) = Id) then Exit;\r
    if ParentMenu.FItems = nil then Exit;\r
    for I := 0 to ParentMenu.FItems.FCount-1 do\r
    begin\r
      Inc( FromIdx );\r
      Result := SearchItems( ParentMenu.FItems.Items[ I ], FromIdx );\r
      if Result <> nil then Exit;\r
    end;\r
    Result := nil;\r
  end;\r
var I: Integer;\r
begin\r
  I := -1;\r
  Result := SearchItems( @ Self, I );\r
end;\r
\r
//[function TMenu.GetCount]\r
function TMenu.GetCount: Integer;\r
var I: Integer;\r
    SubM: PMenu;\r
begin\r
  Result := FItems.FCount;\r
  for I := 0 to Result-1 do\r
  begin\r
    SubM := FItems.Items[ I ];\r
    Result := Result + SubM.Count;\r
  end;\r
end;\r
\r
//[function TMenu.IndexOf]\r
function TMenu.IndexOf( Item: PMenu ): Integer;\r
  function SearchMenu( ParentMenu: PMenu; var FromIdx: Integer ): PMenu;\r
  var I: Integer;\r
  begin\r
    Result := ParentMenu;\r
    if Result = Item then Exit;\r
    for I := 0 to ParentMenu.FItems.FCount-1 do\r
    begin\r
      Inc( FromIdx );\r
      Result := SearchMenu( ParentMenu.FItems.Items[ I ], FromIdx );\r
      if Result <> nil then Exit;\r
    end;\r
    Result := nil;\r
  end;\r
begin\r
  Result := -1;\r
  if SearchMenu( @ Self, Result ) = nil then\r
    Result := -2;\r
end;\r
\r
//[function TMenu.GetState]\r
function TMenu.GetState( const Index: Integer ): Boolean;\r
var MII: TMenuItemInfo;\r
begin\r
  if FVisible then\r
  begin\r
    MII.fMask := MIIM_STATE;\r
    if GetInfo( MII ) then\r
      FSavedState := MII.fState;\r
  end;\r
  Result := LongBool( FSavedState and Index );\r
  if Index < 0 then\r
    Result := not Result;\r
end;\r
\r
//[procedure TMenu.SetState]\r
procedure TMenu.SetState( const Index: Integer; Value: Boolean );\r
var MII: TMenuItemInfo;\r
begin\r
  GetState( 0 );\r
  if Value xor (Index < 0) then\r
    FSavedState := FSavedState or DWORD( Index and $7FFFFFFF )\r
  else\r
    FSavedState := FSavedState and not DWORD( Index );\r
  if FVisible then\r
  begin\r
    MII.fMask := MIIM_STATE;\r
    if GetInfo( MII ) then\r
    begin\r
      MII.fState := FSavedState;\r
      SetInfo( MII );\r
    end;\r
  end;\r
end;\r
\r
//[procedure TMenu.SetData]\r
procedure TMenu.SetData( Value: Pointer );\r
var MII: TMenuItemInfo;\r
begin\r
  MII.fMask := MIIM_DATA;\r
  MII.dwItemData := DWORD( Value );\r
  SetInfo( MII );\r
  FData := Value;\r
end;\r
\r
//[procedure TMenu.ClearBitmaps]\r
procedure TMenu.ClearBitmaps;\r
begin\r
  if FBitmap <> 0 then\r
    DeleteObject( FBitmap );\r
  if FBmpChecked <> 0 then\r
    DeleteObject( FBmpChecked );\r
  if FBmpItem <> 0 then\r
    DeleteObject( FBmpItem );\r
end;\r
\r
//[procedure TMenu.SetBitmap]\r
procedure TMenu.SetBitmap( Value: HBitmap );\r
var MII: TMenuItemInfo;\r
begin\r
  if not FClearBitmaps then\r
  begin\r
    FClearBitmaps := TRUE;\r
    Add2AutoFreeEx( ClearBitmaps );\r
  end;\r
  if Value = FBitmap then Exit;\r
  if FBitmap <> 0 then\r
    DeleteObject( FBitmap ); // seems not necessary.\r
  FBitmap := Value;\r
  MII.fMask := MIIM_CHECKMARKS;\r
  MII.hbmpChecked := FBmpChecked;\r
  MII.hbmpUnchecked := FBitmap;\r
  SetInfo( MII );\r
end;\r
\r
//[procedure TMenu.SetBmpChecked]\r
procedure TMenu.SetBmpChecked( Value: HBitmap );\r
var MII: TMenuItemInfo;\r
begin\r
  if not FClearBitmaps then\r
  begin\r
    FClearBitmaps := TRUE;\r
    Add2AutoFreeEx( ClearBitmaps );\r
  end;\r
  if Value = FBmpChecked then Exit;\r
  if FBmpChecked <> 0 then\r
    DeleteObject( FBmpChecked );\r
  FBmpChecked := Value;\r
  MII.fMask := MIIM_CHECKMARKS;\r
  MII.hbmpChecked := FBmpChecked;\r
  MII.hbmpUnchecked := FBitmap;\r
  SetInfo( MII );\r
end;\r
\r
//[procedure TMenu.SetBmpItem]\r
procedure TMenu.SetBmpItem( Value: HBitmap );\r
var MII: TMenuItemInfo;\r
begin\r
  if not FClearBitmaps then\r
  begin\r
    FClearBitmaps := TRUE;\r
    Add2AutoFreeEx( ClearBitmaps );\r
  end;\r
  if Value = FBmpItem then Exit;\r
  if FBmpItem <> 0 then\r
    DeleteObject( FBmpItem );\r
  FBmpItem := Value;\r
  if WinVer >= wv98 then {AK}\r
  begin                                            {AK}\r
    MII.fMask := $80 {MIIM_BITMAP} ;               {AK}\r
    MII.hbmpItem:=Value;                           {AK}\r
  end                                              {AK}\r
  else                                             {AK}\r
  begin//I haven't possibility to test it in Win95 {AK}\r
    MII.fType := MFT_BITMAP;\r
    MII.dwItemData := Value;\r
  end;                                             {AK}\r
  SetInfo( MII );\r
end;\r
\r
//[procedure TMenu.SetAccelerator]\r
{$IFNDEF NEW_MENU_ACCELL}\r
procedure TMenu.SetAccelerator(const Value: TMenuAccelerator);\r
const MaxAccel = 1000;\r
type TAccTab = array[0..10000] of TAccel;\r
     PAccTab = ^TAccTab;\r
     //TSetAcceleratorProc = procedure( Self_: PMenu; Idx: Integer; const Value: TMenuAccelerator );\r
var AccTab: PAccTab;\r
    I, N : Integer;\r
    M, SubM: PMenu;\r
    C: PControl;\r
    Main: Boolean;\r
begin\r
  //SetAcceleratorProc := TSetAcceleratorProc( MakeMethod( nil, @TMenu.SetAccelerator ).Code );\r
  if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then Exit;\r
  FAccelerator := Value;\r
  C := TopParent.FControl;\r
  if C = nil then Exit;\r
  if C.fAccelTable <> 0 then\r
     DestroyAcceleratorTable( C.fAccelTable );\r
  C.fAccelTable := 0;\r
  GetMem( AccTab, sizeof( TAccel ) * MaxAccel );\r
  N := 0;\r
  M := PMenu( C.fMenuObj );\r
  Main := TRUE;\r
  while M <> nil do\r
  begin\r
    if Main or M.Visible then\r
    begin\r
      for I := 0 to MaxInt-1 do\r
      begin\r
        SubM := M.Items[ I ];\r
        if SubM = nil then break;\r
        if SubM.FVisible then\r
        if (SubM.FAccelerator.Key <> 0) or (SubM.FAccelerator.fVirt <> 0) then\r
        begin\r
          AccTab[ N ].fVirt := SubM.FAccelerator.fVirt;\r
          AccTab[ N ].key := SubM.FAccelerator.Key;\r
          AccTab[ N ].cmd := WORD( SubM.FId );\r
          Inc( N );\r
          if N > MaxAccel then break;\r
        end;\r
      end;\r
    end;\r
    if N > MaxAccel then break;\r
    M := M.fNextMenu;\r
  end;\r
  if N > 0 then\r
  begin\r
    C.fAccelTable := CreateAcceleratorTable( AccTab[ 0 ], N );\r
    C := C.ParentForm;\r
    if C <> nil then\r
      C.SupportMnemonics;\r
  end;\r
  FreeMem( AccTab );\r
end;\r
\r
{$ELSE NEW_MENU_ACCELL}\r
\r
procedure TMenu.SetAccelerator(const Value: TMenuAccelerator);\r
var\r
  C: PControl;\r
  M: PMenu;\r
begin\r
  if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then Exit;\r
  FAccelerator := Value;\r
  C := FControl;\r
  M := @Self;\r
  while (C = nil) and (M <> nil) do begin\r
    M := M.Parent;\r
    if (M <> nil) then\r
      C := M.FControl;\r
  end;\r
  if (C <> nil) then\r
    C.SupportMnemonics;\r
end;\r
\r
{$ENDIF NEW_MENU_ACCELL}\r
\r
//[procedure TMenu.SetMenuItemCaption]\r
procedure TMenu.SetMenuItemCaption( const Value: String );\r
var MII: TMenuItemInfo;\r
begin\r
  FCaption := Value;\r
{AK}if not (WinVer in [wv95,wvNT]) then\r
{AK}  MII.fMask := $40 {MIIM_STRING}\r
{AK}else begin\r
  MII.fMask := MIIM_TYPE;\r
  MII.fType := MFT_STRING;\r
{AK}end;\r
  //+++++++++++++++++++ to fix turning radio mark to check mark in NT4\r
  MII.cch := 0;\r
  GetInfo( MII );\r
  //------------------------------------------------------------------\r
  MII.dwTypeData := PChar( Value );\r
  MII.cch := Length( Value );\r
  SetInfo( MII );\r
end;\r
\r
//[procedure TMenu.SetMenuBreak]\r
procedure TMenu.SetMenuBreak( Value: TMenuBreak );\r
var MII: TMenuItemInfo;\r
begin\r
  if FId = 0 then Exit;\r
  if FMenuBreak = Value then Exit;\r
  FMenuBreak := Value;\r
  FillChar( MII, Sizeof( MII ), 0 );\r
  MII.fMask := MIIM_TYPE;\r
  MII.dwTypeData := nil;\r
  if GetInfo( MII ) then\r
  begin\r
    MII.fType := MII.fType and not( MFT_MENUBREAK or MFT_MENUBARBREAK ) or\r
                 Breaks[ Value ];\r
    SetTypeInfo( MII );\r
  end;\r
end;\r
\r
//[procedure TMenu.SetVisible]\r
procedure TMenu.SetVisible( Value: Boolean );\r
var I, J: Integer;\r
    M: PMenu;\r
    Before: Integer;\r
    ByPosition: Boolean;\r
    MII: TMenuItemInfo;\r
begin\r
  if Value then\r
    if FParent <> nil then\r
      FParent.Visible := TRUE;\r
  if Value = FVisible then Exit;\r
  FVisible := Value;\r
  if (FControl <> nil) and (FControl.fMenuObj = @ Self) then\r
  begin\r
    FControl.GetWindowHandle;\r
    if Value then\r
      SetMenu( FControl.fHandle, FHandle )\r
    else\r
      SetMenu( FControl.fHandle, 0 );\r
    Exit;\r
  end;\r
  if FId = 0 then Exit;\r
  if FParent = nil then Exit;\r
  if Value then\r
  begin // show menu item inserting it again into appropriate position\r
    Before := -1;\r
    ByPosition := TRUE;\r
    I := FParent.FItems.IndexOf( @ Self );\r
    for J := I + 1 to FParent.FItems.FCount-1 do\r
    begin\r
      M := FParent.FItems.Items[ J ];\r
      if M.FVisible then\r
      begin\r
        Before := M.FId;\r
        ByPosition := FALSE;\r
        break;\r
      end;\r
    end;\r
\r
    FillChar( MII, Sizeof( MII ), 0 );\r
    MII.cbSize := MenuStructSize;\r
    MII.fMask := MIIM_CHECKMARKS or MIIM_ID or MIIM_STATE or\r
                 MIIM_TYPE;\r
    MII.fType := Breaks[ FMenuBreak ];\r
    MII.fState := FSavedState;\r
    MII.wID := FId;\r
    MII.dwItemData := DWORD( FData );\r
\r
    if not FIsSeparator then\r
    begin\r
      MII.fType := MII.fType or MFT_STRING;\r
      MII.dwTypeData := PChar( FCaption );\r
      MII.cch := Length( FCaption );\r
    end\r
      else\r
      MII.fType := MII.fType or MFT_SEPARATOR;\r
\r
    if FRadioGroup <> 0 then\r
      MII.fType := MII.fType or MFT_RADIOCHECK;\r
\r
    if FOwnerDraw then\r
      MII.fType := MII.fType or MFT_OWNERDRAW;\r
\r
    if FBitmap <> 0 then\r
    begin\r
      MII.fMask := MII.fMask or MIIM_CHECKMARKS;\r
      MII.hbmpUnchecked := FBitmap;\r
    end;\r
\r
    if FHandle <> 0 then\r
    begin\r
      MII.fMask := MII.fMask or MIIM_SUBMENU;\r
      MII.hSubMenu := FHandle;\r
    end;\r
\r
    InsertMenuItem( FParent.FHandle, Before, ByPosition,\r
                    Windows.PMenuitemInfo( @ MII )^ );\r
  end\r
    else\r
  begin // hide menu item removing it\r
    GetState( 0 ); // store menu item state in FSavedState to allow\r
                   // changing its state while it is not attached to\r
                   // a menu\r
    RemoveMenu( TopParent.FHandle, FId, MF_BYCOMMAND );\r
  end;\r
  if (FControl <> nil) or (FParent <> nil) and (FParent.FControl <> nil) then\r
    RedrawFormMenuBar;\r
end;\r
\r
//[procedure TMenu.RadioCheckItem]\r
procedure TMenu.RadioCheckItem;\r
var I, J: Integer;\r
    M, First, Last: PMenu;\r
begin\r
  if (FParent <> nil) and (FRadioGroup <> 0) then\r
  begin\r
    I := FParent.FItems.IndexOf( @ Self );\r
    if I >= 0 then\r
    begin\r
      First := @ Self;\r
      Last := @ Self;\r
      for J := I-1 downto 0 do\r
      begin\r
        M := FParent.FItems.Items[ J ];\r
        if M.FRadioGroup <> FRadioGroup then break;\r
        if M.FVisible then\r
          First := M;\r
      end;\r
      for J := I+1 to FParent.FItems.FCount-1 do\r
      begin\r
        M := FParent.FItems.Items[ J ];\r
        if M.FRadioGroup <> FRadioGroup then break;\r
        if M.FVisible then\r
          Last := M;\r
      end;\r
      if First <> Last then\r
      begin\r
        CheckMenuRadioItem( FParent.FHandle, First.FId, Last.FId,\r
                            FId, MF_BYCOMMAND {or MF_CHECKED} );\r
        Exit;\r
      end;\r
    end;\r
  end;\r
  Checked := TRUE;\r
end;\r
\r
//[function TMenu.FillMenuItems]\r
function TMenu.FillMenuItems(AHandle: HMenu; StartIdx: Integer;\r
  const Template: array of PChar): Integer;\r
var S, S1: PChar;\r
    I: Integer;\r
    MII: TMenuItemInfo;\r
    Item, PrevItem: PMenu;\r
begin\r
  PrevItem := nil;\r
  I := StartIdx;\r
  while I <= High( Template ) do\r
  begin\r
    S := Template[ I ];\r
    if (S = nil) or (S^ = #0) then break;\r
    if S = {$IFDEF F_P}'' +{$ENDIF} ')' then\r
    begin\r
       Result := I + 1;\r
       Exit;\r
    end;\r
\r
    {-}\r
    new( Item, Create );\r
    {+}{++}(*Item := PMenu.Create;*){--}\r
    Item.FVisible := TRUE;\r
    Item.FParent := @ Self;\r
    Item.FItems := NewList;\r
    FItems.Add( Item );\r
\r
    FillChar( MII, Sizeof( MII ), 0 );\r
    MII.cbSize := MenuStructSize;\r
    MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;\r
    if S <> {$IFDEF F_P}'' +{$ENDIF} '-' then\r
    begin\r
      if (S^ = {$IFDEF F_P}'' +{$ENDIF} '-') or\r
         (S^ = {$IFDEF F_P}'' +{$ENDIF} '+') then\r
      begin\r
        Item.FIsCheckItem := TRUE;\r
        MII.dwItemData := MIDATA_CHECKITEM;\r
        if S^ <> {$IFDEF F_P}'' +{$ENDIF} '-' then\r
          MII.fState := MII.fState or MFS_CHECKED;\r
        Inc( S );\r
        if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then\r
        begin\r
          MII.fType := MII.fType or MFT_RADIOCHECK;\r
          MII.dwItemData := MII.dwItemData or MIDATA_RADIOITEM;\r
          Inc( S );\r
          if PrevItem <> nil then\r
          begin\r
            if PrevItem.FRadioGroup <> 0 then\r
              Item.FRadioGroup := PrevItem.FRadioGroup;\r
          end;\r
          if Item.FRadioGroup = 0 then\r
            Inc( Item.FRadioGroup );\r
          if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then\r
          begin\r
            Inc( S );\r
            Inc( Item.FRadioGroup );\r
          end;\r
        end;\r
      end;\r
      Item.FCaption := S;\r
    end\r
      else\r
    begin\r
      Item.FIsSeparator := TRUE;\r
      MII.fType := MFT_SEPARATOR;\r
      MII.fState := MFS_GRAYED;\r
      MII.wID := 0;\r
    end;\r
    Item.FId := FDynamicMenuID;\r
    Inc( FDynamicMenuID );\r
    MII.wID := Item.FId;\r
    if I <> High( Template ) then            //YS\r
    begin                                    //YS\r
    S1 := Template[ I + 1 ];\r
    if S1 = {$IFDEF F_P}'' +{$ENDIF} '(' then Item.FHandle := CreatePopupMenu;\r
    end;                                     //YS\r
    MII.hSubMenu := Item.FHandle;\r
    MII.dwTypeData := PChar( S );\r
    MII.cch := StrLen( S );\r
    InsertMenuItem( AHandle, DWORD(-1), True, Windows.PMenuitemInfo( @ MII )^ );\r
    if Item.FHandle <> 0 then\r
      I := Item.FillMenuItems( Item.FHandle, I + 2, Template )\r
    else\r
      Inc( I );\r
    PrevItem := Item;\r
  end;\r
  Result := I;\r
end;\r
\r
//[procedure TMenu.AssignEvents]\r
procedure TMenu.AssignEvents(StartIdx: Integer;\r
  Events: array of TOnMenuItem);\r
var I: Integer;\r
    M: PMenu;\r
begin\r
  for I := 0 to High(Events) do\r
  begin\r
    M := Items[ StartIdx ];\r
    if M = nil then break;\r
    M.FOnMenuItem := Events[ I ];\r
    Inc( StartIdx );\r
  end;\r
end;\r
\r
//[procedure TMenu.Popup]\r
procedure TMenu.Popup(X, Y: Integer);\r
begin\r
  if Assigned( fOnPopup ) then fOnPopup( @Self );\r
  if not FNotPopup then\r
    TrackPopupMenu( FHandle, FPopupFlags,\r
                    X, Y, 0, FControl.Handle, nil );\r
end;\r
\r
//[procedure TMenu.PopupEx]\r
procedure TMenu.PopupEx( X, Y: Integer );\r
var OldBounds: TRect;\r
    WasVisible: Boolean;\r
begin\r
  WasVisible := TRUE;\r
  if FControl <> nil then\r
  begin\r
    OldBounds := FControl.BoundsRect;\r
    if not FControl.fIsControl then\r
    begin\r
      WasVisible := FControl.Visible;\r
      if not WasVisible then\r
        FControl.Top := ScreenHeight + 50;\r
      FControl.Show;\r
    end;\r
  end;\r
\r
  // -- by Martin Larsen: -----------------------\\r
  FControl.ProcessMessage; // specific for Win9x |\r
  //---------------------------------------------/\r
\r
  Popup( X, Y );\r
  if FControl <> nil then\r
  begin\r
    if FControl.Top = ScreenHeight + 50 then\r
    begin\r
      if not WasVisible then\r
        FControl.Visible := FALSE;\r
      FControl.BoundsRect := OldBounds;\r
    end;\r
  end;\r
end;\r
\r
//[function TMenu.GetItemChecked]\r
function TMenu.GetItemChecked( Item : Integer ) : Boolean;\r
begin\r
  Result := Items[ Item ].Checked;\r
end;\r
\r
//[procedure TMenu.SetItemChecked]\r
procedure TMenu.SetItemChecked( Item : Integer; Value : Boolean );\r
begin\r
  Items[ Item ].Checked := Value;\r
end;\r
\r
//[function TMenu.GetMenuItemHandle]\r
function TMenu.GetMenuItemHandle( Idx : Integer ): DWORD;\r
begin\r
  Result := Items[ Idx ].FId;\r
end;\r
\r
//[procedure TMenu.RadioCheck]\r
procedure TMenu.RadioCheck( Idx : Integer );\r
begin\r
  Items[ Idx ].RadioCheckItem;\r
end;\r
\r
//[function TMenu.GetItemBitmap]\r
function TMenu.GetItemBitmap(Idx: Integer): HBitmap;\r
begin\r
  Result := Items[ Idx ].Bitmap;\r
end;\r
\r
//[procedure TMenu.SetItemBitmap]\r
procedure TMenu.SetItemBitmap(Idx: Integer; const Value: HBitmap);\r
begin\r
  Items[ Idx ].Bitmap := Value;\r
end;\r
\r
//[procedure TMenu.AssignBitmaps]\r
procedure TMenu.AssignBitmaps(StartIdx: Integer; Bitmaps: array of HBitmap);\r
var I: Integer;\r
begin\r
  for I := 0 to High(Bitmaps) do\r
    ItemBitmap[ I + StartIdx ] := Bitmaps[ I ];\r
end;\r
\r
//[function TMenu.GetItemText]\r
function TMenu.GetItemText(Idx: Integer): String;\r
begin\r
  Result := Items[ Idx ].FCaption;\r
end;\r
\r
//[procedure TMenu.SetItemText]\r
procedure TMenu.SetItemText(Idx: Integer; const Value: String);\r
begin\r
  Items[ Idx ].Caption := Value;\r
end;\r
\r
//[function TMenu.GetItemEnabled]\r
function TMenu.GetItemEnabled(Idx: Integer): Boolean;\r
begin\r
  Result := Items[ Idx ].Enabled;\r
end;\r
\r
//[procedure TMenu.SetItemEnabled]\r
procedure TMenu.SetItemEnabled(Idx: Integer; const Value: Boolean);\r
begin\r
  Items[ Idx ].Enabled := Value;\r
end;\r
\r
//[function TMenu.GetItemVisible]\r
function TMenu.GetItemVisible(Idx: Integer): Boolean;\r
begin\r
  Result := Items[ Idx ].Visible;\r
end;\r
\r
//[procedure TMenu.SetItemVisible]\r
procedure TMenu.SetItemVisible(Idx: Integer; const Value: Boolean);\r
begin\r
  Items[ Idx ].Visible := Value;\r
end;\r
\r
//[function TMenu.ParentItem]\r
function TMenu.ParentItem( Idx: Integer ): Integer;\r
begin\r
  Result := TopParent.IndexOf( Items[ Idx ].FParent );\r
end;\r
\r
//[function TMenu.GetItemAccelerator]\r
function TMenu.GetItemAccelerator(Idx: Integer): TMenuAccelerator;\r
begin\r
  Result := Items[ Idx ].Accelerator;\r
end;\r
\r
//[procedure TMenu.SetItemAccelerator]\r
procedure TMenu.SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator);\r
begin\r
  Items[ Idx ].Accelerator := Value;\r
end;\r
\r
//[function TMenu.GetItemSubMenu]\r
function TMenu.GetItemSubMenu( Idx: Integer ): HMenu;\r
begin\r
  Result := Items[ Idx ].SubMenu;\r
end;\r
\r
//[function WndProcHelp FORWARD DECLARATION]\r
function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
forward;\r
\r
//[procedure TMenu.SetHelpContext]\r
procedure TMenu.SetHelpContext( Value: Integer );\r
var Form, C: PControl;\r
begin\r
  if TopParent <> @ Self then Exit;\r
  // Help context can not be associated with individual menu items\r
  FHelpContext := Value;\r
  C := FControl;\r
  if C = nil then Exit;\r
  Form := C.ParentForm;\r
  Form.AttachProc( WndProcHelp );\r
  SetMenuContextHelpID( FHandle, Value );\r
end;\r
\r
//[procedure TMenu.SetSubmenu]\r
procedure TMenu.SetSubmenu( Value: HMenu );\r
var MII: TMenuItemInfo;\r
begin\r
  MII.fMask := MIIM_SUBMENU;\r
  MII.hSubMenu := Value;\r
  SetInfo( MII );\r
  FHandle := Value;\r
end;\r
\r
//[function WndProcMeasureItem]\r
function WndProcMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var MIS: PMeasureItemStruct;\r
    M, SM: PMenu;\r
    H, I: Integer;\r
begin\r
  Result := FALSE;\r
  if (Msg.message = WM_MEASUREITEM) and (Msg.wParam = 0) then\r
  begin\r
    MIS := Pointer( Msg.lParam );\r
    if MIS.CtlType = ODT_MENU then\r
    begin\r
      M := Pointer( Sender.fMenuObj );\r
      while M <> nil do\r
      begin\r
        SM := M.Items[ MIS.itemID ];\r
        if SM <> nil then\r
        begin\r
          Sender.CallDefWndProc( Msg );\r
          I := M.IndexOf( SM );\r
          if Assigned( SM.OnMeasureItem ) then\r
            M := SM;\r
          if not Assigned( M.OnMeasureItem ) then\r
            Exit;\r
          H := M.OnMeasureItem( M, I );\r
          if HiWord( H ) <> 0 then\r
            MIS.itemWidth := HiWord( H );\r
          if LoWord( H ) <> 0 then\r
            MIS.itemHeight := LoWord( H );\r
          Rslt := 1;\r
          Result := TRUE;\r
          break;\r
        end;\r
        M := M.fNextMenu;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//[procedure TMenu.SetOnMeasureItem]\r
procedure TMenu.SetOnMeasureItem( const Value: TOnMeasureItem );\r
var C: PControl;\r
begin\r
  FOnMeasureItem := Value;\r
  C := TopParent.FControl;\r
  if C <> nil then\r
    C.AttachProc( WndProcMeasureItem );\r
end;\r
\r
//[function WndProcDrawItem]\r
function WndProcDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
type PDrawAction = ^TDrawAction;\r
     PDrawState = ^TDrawState;\r
var DIS: PDrawItemStruct;\r
    M, SM: PMenu;\r
    I: Integer;\r
begin\r
  Result := FALSE;\r
  if (Msg.message = WM_DRAWITEM) and (Msg.wParam = 0) then\r
  begin\r
    DIS := Pointer( Msg.lParam );\r
    if DIS.CtlType = ODT_MENU then\r
    begin\r
      M := Pointer( Sender.fMenuObj );\r
      while M <> nil do\r
      begin\r
        SM := M.Items[ DIS.itemID ];\r
        if SM <> nil then\r
        begin\r
          I := M.IndexOf( SM );\r
          if Assigned( SM.OnDrawItem ) then\r
            M := SM;\r
          if Assigned( M.OnDrawItem ) then\r
          begin\r
            if not M.OnDrawItem( M, DIS.hDC, DIS.rcItem, I,\r
                          PDrawAction( @ DIS.itemAction )^,\r
                          PDrawState( @ DIS.itemState )^ ) then Exit;\r
          end\r
            else Exit;\r
          Rslt := 1;\r
          Result := TRUE;\r
          break;\r
        end;\r
        M := M.fNextMenu;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//[procedure TMenu.SetOnDrawItem]\r
procedure TMenu.SetOnDrawItem( const Value: TOnDrawItem );\r
var C: PControl;\r
begin\r
  FOnDrawItem := Value;\r
  C := TopParent.FControl;\r
  if C <> nil then\r
    C.AttachProc( WndProcDrawItem );\r
end;\r
\r
//[procedure TMenu.SetOwnerDraw]\r
procedure TMenu.SetOwnerDraw( Value: Boolean );\r
const Masks: array[ Boolean ] of DWORD = ( 0, $FFFFFFFF );\r
var MII: TMenuItemInfo;\r
begin\r
  FOwnerDraw := Value;\r
  FillChar( MII, Sizeof( MII ), 0 );\r
  MII.fMask := MIIM_TYPE;\r
  MII.dwTypeData := nil;\r
  if GetInfo( MII ) then\r
  begin\r
    MII.fType := MII.fType and not MFT_OWNERDRAW or\r
              (MFT_OWNERDRAW and Masks[ Value ]);\r
    SetTypeInfo( MII );\r
  end;\r
end;\r
\r
//[function TMenu.Insert]\r
function TMenu.Insert(InsertBefore: Integer; ACaption: PChar; Event: TOnMenuItem;\r
             Options: TMenuOptions): PMenu;\r
const\r
  MenuStateFlags: array[TMenuOption] of Integer = (MFS_DEFAULT, MFS_DISABLED, MFS_CHECKED, 0, 0,\r
                  MFS_DISABLED, 0, 0, 0, 0);\r
  MenuTypeFlags: array[TMenuOption] of Integer =  (0, 0, 0, 0, MFT_RADIOCHECK, MFT_SEPARATOR, MFT_BITMAP, 0,\r
                 MFT_MENUBREAK, MFT_MENUBARBREAK);\r
var M: PMenu;\r
    MII: TMenuItemInfo;\r
begin\r
  {-}\r
  new( Result, Create );\r
  {+}{++}(*Result := PMenu.Create;*){--}\r
  Result.FVisible := TRUE;\r
  Result.FParent := @ Self;\r
  Result.FItems := NewList;\r
  Result.FIsSeparator := moSeparator in Options;\r
  if FHandle = 0 then\r
    SetSubMenu( CreatePopupMenu );\r
  M := nil;\r
  if (InsertBefore >= 0) and (InsertBefore < 4096) then\r
  begin\r
    M := Items[ InsertBefore ];\r
    if M <> nil then\r
    begin\r
      InsertBefore := M.FId;\r
      M.Parent.FItems.Insert( M.Parent.FItems.IndexOf( M ), Result );\r
    end;\r
  end;\r
  if M = nil then\r
  begin\r
    InsertBefore := -1;\r
    FItems.Add( Result );\r
  end;\r
  Result.FOnMenuItem := Event;\r
\r
  FillChar( MII, Sizeof( MII ), 0 );\r
  MII.cbSize := MenuStructSize;\r
  MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;\r
\r
  MII.fState := MakeFlags( Pointer( @Options ), MenuStateFlags);\r
  MII.fType := MakeFlags( Pointer( @Options ), MenuTypeFlags);\r
  Result.FId := FDynamicMenuID;\r
  Inc( FDynamicMenuID );\r
  MII.wID := Result.FId;\r
  if moSubMenu in Options\r
  then begin\r
    Result.FHandle := CreatePopupMenu;\r
    MII.hSubMenu := Result.FHandle;\r
  end;\r
  MII.dwTypeData := ACaption;\r
  if not (moBitmap in Options) then MII.cch := StrLen( ACaption );\r
  InsertMenuItem( FHandle, InsertBefore, InsertBefore = -1,\r
                  Windows.PMenuItemInfo( @ MII )^ );\r
  if moBitmap in Options then\r
  begin\r
    Result.BitmapItem := DWORD( ACaption );\r
  end\r
  else\r
    Result.FCaption := ACaption;\r
  RedrawFormMenuBar;\r
end;\r
\r
//[function TMenu.AddItem]\r
function TMenu.AddItem(ACaption: PChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;\r
begin\r
  Result := InsertItem( -1, ACaption, Event, Options );\r
end;\r
\r
//[function TMenu.InsertItem]\r
function TMenu.InsertItem( InsertBefore: Integer; ACaption: PChar; Event: TOnMenuItem;\r
  Options: TMenuOptions): Integer;\r
begin\r
  Result := InsertItemEx( InsertBefore, ACaption, Event, Options, FALSE );\r
end;\r
\r
//[function TMenu.InsertItemEx]\r
function TMenu.InsertItemEx(InsertBefore: Integer; ACaption: PChar;\r
  Event: TOnMenuItem; Options: TMenuOptions; ByPosition: Boolean): Integer;\r
var M: PMenu;\r
begin\r
  M := Insert( InsertBefore, ACaption, Event, Options );\r
  Result := M.FId;\r
end;\r
\r
//[procedure TMenu.InsertSubMenu]\r
procedure TMenu.InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer );\r
var AFlags: DWORD;\r
    M: PMenu;\r
    MII: TMenuItemInfo;\r
begin\r
  if SubMenuToInsert.FParent <> nil then\r
    SubMenuToInsert := SubMenuToInsert.FParent.RemoveSubMenu( SubMenuToInsert.FId );\r
  if SubMenuToInsert = nil then Exit;\r
\r
  AFlags := MF_BYPOSITION;\r
  M := nil;\r
  if (InsertBefore >= 0) and (InsertBefore < 4096) then\r
  begin\r
    M := Items[ InsertBefore ];\r
    if M = nil then\r
      InsertBefore := -1\r
    else\r
      InsertBefore := M.FId;\r
  end;\r
  if M = nil then\r
  begin\r
    FItems.Add( SubMenuToInsert );\r
    SubMenuToInsert.FParent := @ Self;\r
  end\r
    else\r
  begin\r
    M.FParent.FItems.Insert( M.FParent.FItems.IndexOf( M ), SubMenuToInsert );\r
    SubMenuToInsert.FParent := M.FParent;\r
  end;\r
\r
  if InsertBefore > 0 then\r
    AFlags := MF_BYCOMMAND;\r
  if SubMenuToInsert.FBmpItem <> 0 then\r
    InsertMenu( FHandle, InsertBefore, AFlags or MF_BITMAP or MF_POPUP, SubMenuToInsert.FHandle,\r
                PChar( SubMenuToInsert.FBmpItem ) )\r
  else\r
    InsertMenu( FHandle, InsertBefore, AFlags or MF_STRING or MF_POPUP, SubMenuToInsert.FHandle,\r
                PChar( SubMenuToInsert.Caption ) );\r
  if SubMenuToInsert.FId = 0 then\r
  begin\r
    SubMenuToInsert.FId := FDynamicMenuID;\r
    Inc( FDynamicMenuID );\r
    MII.cbSize := MenuStructSize;\r
    MII.fMask := MIIM_ID;\r
    MII.wID := SubMenuToInsert.FId;\r
    SetMenuItemInfo( SubMenuToInsert.FParent.FHandle, SubMenuToInsert.FParent.FItems.IndexOf( SubMenuToInsert ),\r
                     TRUE, Windows.PMenuItemInfo( @ MII )^ );\r
  end;\r
  RedrawFormMenuBar;\r
end;\r
\r
//[function TMenu.RemoveSubMenu]\r
function TMenu.RemoveSubMenu( ItemToRemove: Integer ): PMenu;\r
{$IFDEF DEBUG_MENU}var OK: Boolean; {$ENDIF}\r
begin\r
  Result := Items[ ItemToRemove ];\r
  if Result = nil then Exit;\r
  if Result.FParent <> nil then\r
    {$IFDEF DEBUG_MENU} OK := {$ENDIF}\r
    RemoveMenu( Result.FParent.FHandle, Result.FId, MF_BYCOMMAND )\r
  else\r
    {$IFDEF DEBUG_MENU} OK := {$ENDIF}\r
    RemoveMenu( FHandle, Result.FId, MF_BYCOMMAND );\r
  {$IFDEF DEBUG_MENU}\r
  if not OK then\r
    ShowMessage( 'Error removing menu: ' + Int2Str( GetLastError ) + ' - ' +\r
                 SysErrorMessage( GetLastError ) );\r
  {$ENDIF}\r
  if Count = 0 then\r
  begin\r
    Result.Free;\r
    Result := nil;\r
  end;\r
  RedrawFormMenuBar;\r
end;\r
\r
//[procedure ClearText]\r
procedure ClearText( Sender: PControl );\r
begin\r
  Sender.Caption := '';\r
end;\r
\r
//[procedure ClearListbox]\r
procedure ClearListbox( Sender: PControl );\r
begin\r
  Sender.Perform( LB_RESETCONTENT, 0, 0 );\r
end;\r
\r
//[procedure ClearCombobox]\r
procedure ClearCombobox( Sender: PControl );\r
begin\r
  Sender.Perform( CB_RESETCONTENT, 0, 0 );\r
end;\r
\r
//[procedure ClearListView]\r
procedure ClearListView( Sender: PControl );\r
begin\r
  Sender.Perform( LVM_DELETEALLITEMS, 0, 0 );\r
end;\r
\r
//[procedure ClearToolbar]\r
procedure ClearToolbar( Sender: PControl );\r
begin\r
  while Sender.TBButtonCount > 0 do\r
    Sender.TBDeleteButton( Sender.TBIndex2Item( 0 ) );\r
  Sender.Perform( TB_SETBITMAPSIZE, 0, 0 );\r
end;\r
\r
{ -- Constructor of canvas -- }\r
//[function NewCanvas]\r
function NewCanvas( DC: HDC ): PCanvas;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}\r
  {++}(*\r
  Result := PCanvas.Create;\r
  *){--}\r
  Result.ModeCopy := cmSrcCopy;\r
  if DC <> 0 then\r
  begin\r
    Result.SetHandle( DC );\r
    //Result.fIsPaintDC := True; // If Canvas will be destroyed, DC will not be deleted\r
  end;\r
end;\r
//[END NewCanvas]\r
\r
{ -- Contructors of controls -- }\r
\r
{$IFDEF ASM_VERSION}\r
//[FUNCTION _NewTControl]\r
function _NewTControl( AParent: PControl ): PControl;\r
begin\r
  New( Result, CreateParented( AParent ) );\r
end;\r
//[END _NewTControl]\r
\r
//[function _NewWindowed]\r
function _NewWindowed( AParent: PControl; ControlClassName: PChar; Ctl3D: Boolean ): PControl;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
\r
        PUSH     ECX // Ctl3D\r
        PUSH     EDX // ControlClassName\r
\r
        MOV      ESI, EAX // ESI = AParent\r
        CALL     _NewTControl\r
        XCHG     EBX, EAX // EBX = Result\r
        POP      [EBX].TControl.fControlClassName\r
        INC      [EBX].TControl.fWindowed\r
\r
        INC      EAX\r
        POP      EDX // DL = parameter Ctl3D\r
        TEST     ESI, ESI\r
        JZ       @@no_parent\r
\r
        LEA      ESI, [ESI].TControl.fWndProcResizeFlicks\r
        LEA      EDI, [EBX].TControl.fWndProcResizeFlicks\r
        MOVSD    // fWndProcResizeFlicks\r
        MOVSD    // fGotoControl\r
        //MOVSW    // fDoubleBuffered, fTransparent\r
        LODSB    // fCtl3Dchild\r
        STOSB\r
        DEC      AL\r
        LODSB    // fCtl3D\r
        JZ       @@passed3D\r
        XOR      EDX, EDX\r
@@passed3D:\r
        XCHG     EAX, EDX\r
        STOSB    // fCtl3D\r
\r
        MOVSD    // fTextColor\r
        LODSD\r
        XCHG     EDX, EAX\r
        XOR      EAX, EAX\r
        PUSH     EDX\r
        CALL     TGraphicTool.Assign\r
        STOSD    // fFont\r
        POP      EDX\r
        XCHG     ECX, EAX\r
        JECXZ    @@no_font\r
        MOV      [ECX].TGraphicTool.fParentGDITool, EDX\r
        MOV      [ECX].TGraphicTool.fOnChange.TMethod.Code, offset[TControl.FontChanged]\r
        MOV      [ECX].TGraphicTool.fOnChange.TMethod.Data, EBX\r
        MOV      EAX, EBX\r
        MOV      EDX, ECX\r
        CALL     TControl.FontChanged\r
@@no_font:\r
\r
        MOVSD    // fColor\r
        LODSD\r
        XCHG     EDX, EAX\r
        XOR      EAX, EAX\r
        PUSH     EDX\r
        CALL     TGraphicTool.Assign\r
        STOSD    // fBrush\r
        POP      EDX\r
        XCHG     ECX, EAX\r
        JECXZ    @@no_brush\r
        MOV      [ECX].TGraphicTool.fParentGDITool, EDX\r
        MOV      [ECX].TGraphicTool.fOnChange.TMethod.Code, offset[TControl.BrushChanged]\r
        MOV      [ECX].TGraphicTool.fOnChange.TMethod.Data, EBX\r
        MOV      EAX, EBX\r
        MOV      EDX, ECX\r
        CALL     TControl.BrushChanged\r
@@no_brush:\r
\r
        LODSD\r
        STOSD    // fMargin\r
        STOSD    // fBoundsRect.Left\r
        PUSH     EAX\r
        ADD      EAX, [ESI+16] // AParent.fClientTop\r
        STOSD    // fBoundsRect.Top\r
        POP      EAX\r
        ADD      EAX, 64\r
        STOSD    // fBoundsRect.Right\r
        STOSD    // fBoundsRect.Bottom\r
\r
@@no_parent:\r
        XCHG     EAX, EBX\r
        //DEC      byte ptr [EAX].TControl.fAlphaBlend\r
        //INC      byte ptr [EAX].TControl.fEraseUpdRgn\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function _NewWindowed( AParent: PControl; ControlClassName: PChar; Ctl3D: Boolean ): PControl;\r
begin\r
  {-}\r
  New( Result, CreateParented( AParent ) );\r
  {+}{++}(*Result := PControl.CreateParented( AParent );*){--}\r
  Result.fControlClassName := ControlClassName;\r
  if AParent <> nil then\r
  begin\r
     Result.fWndProcResizeFlicks := AParent.fWndProcResizeFlicks;\r
     Result.fGotoControl := AParent.fGotoControl;\r
     //Result.fDoubleBuffered := AParent.fDoubleBuffered;\r
     //Result.fTransparent := AParent.fTransparent;\r
     Result.fCtl3Dchild := AParent.fCtl3Dchild;\r
     if AParent.fCtl3Dchild then\r
       Result.fCtl3D := Ctl3D\r
     else\r
       Result.fCtl3D := False;\r
     Result.fMargin := AParent.fMargin;\r
     with Result.fBoundsRect do\r
     begin\r
       Left := AParent.fMargin + AParent.fClientLeft;\r
       Top  := AParent.fMargin + AParent.fClientTop;\r
       Right := Left + 64;\r
       Bottom := Top + 64;\r
     end;\r
     Result.fTextColor := AParent.fTextColor;\r
     Result.fFont := Result.fFont.Assign( AParent.fFont );\r
     if Result.fFont <> nil then\r
     begin\r
       Result.fFont.fParentGDITool := AParent.fFont;\r
       Result.fFont.fOnChange := Result.FontChanged;\r
       Result.FontChanged( Result.fFont );\r
     end;\r
     Result.fColor := AParent.fColor;\r
     Result.fBrush := Result.fBrush.Assign( AParent.fBrush );\r
     if Result.fBrush <> nil then\r
     begin\r
       Result.fBrush.fParentGDITool := AParent.fBrush;\r
       Result.fBrush.fOnChange := Result.BrushChanged;\r
       Result.BrushChanged( Result.fBrush );\r
     end;\r
  end;\r
  //Result.fAlphaBlend := 255;\r
  //Result.fEraseUpdRgn := TRUE;\r
end;\r
//[END _NewWindowed]\r
{$ENDIF ASM_VERSION}\r
\r
//===================== Form ========================//\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewForm]\r
function NewForm( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  new( Result, CreateForm( AParent, Caption ) );\r
end;\r
//[END NewForm]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewForm]\r
{$IFDEF ASM_VERSION}\r
function NewForm( AParent: PControl; const Caption: String ): PControl;\r
const FormClass: array[ 0..4 ] of Char = ( 'F', 'o', 'r', 'm', #0 );\r
asm\r
        PUSH     EBX\r
        PUSH     EDX\r
        MOV      EDX, offset[FormClass]\r
        MOV      CL, 1\r
        CALL     _NewWindowed\r
        MOV      EBX, EAX\r
        INC      [EBX].TControl.fSizeGrip\r
        OR       byte ptr [EBX].TControl.fClsStyle, CS_DBLCLKS\r
        MOV      EDX, offset[WndProcForm]\r
        CALL     TControl.AttachProc\r
        MOV      EDX, offset[WndProcDoEraseBkgnd]\r
        MOV      EAX, EBX\r
        CALL     TControl.AttachProc\r
        POP      EDX\r
        MOV      EAX, EBX\r
        CALL     TControl.SetCaption\r
        INC      [EBX].TControl.fSizeGrip\r
        INC      [EBX].TControl.fIsForm\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewForm( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  Result := _NewWindowed( AParent, 'Form', True );\r
  Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS;\r
  Result.AttachProc( WndProcForm );\r
  Result.AttachProc( WndProcDoEraseBkgnd );\r
  Result.Caption := Caption;\r
  Result.fSizeGrip := TRUE;\r
  Result.fIsForm := TRUE;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewForm]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Applet button ========================//\r
\r
//{$DEFINE WNDPROCAPP_USED}\r
{$IFDEF WNDPROCAPP_USED}\r
\r
//[FUNCTION WndProcApp]\r
{$IFDEF ASM_VERSION}\r
  {$IFDEF WNDPROCAPP_ASM_USED}\r
  function WndProcApp(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
  asm\r
          CMP      word ptr [EDX].TMsg.message, WM_SETFOCUS\r
          JNZ      @@chk_CLOSE\r
          MOV      ECX, [EAX].TControl.FCurrentControl\r
          JECXZ    @@ret_false\r
          XCHG     EAX, ECX\r
          PUSH     EAX\r
          CALL     CallTControlCreateWindow\r
          POP      EAX\r
          PUSH     [EAX].TControl.fHandle\r
          CALL     SetFocus\r
          MOV      AL, 1\r
          RET\r
  @@chk_CLOSE:\r
          CMP      word ptr [EDX].TMsg.message, WM_SYSCOMMAND\r
          JNZ      @@ret_false\r
          MOV      EDX, dword ptr [EDX].TMsg.wParam\r
          AND      DX, $FFF0\r
          CMP      DX, SC_CLOSE\r
          JNZ      @@ret_false\r
          PUSH     ECX\r
          MOV      ECX, [EAX].TControl.fChildren\r
          JECXZ    @@ret_false1\r
          XCHG     EAX, ECX\r
          MOV      ECX, [EAX].TList.fCount\r
          JECXZ    @@ret_false1\r
          MOV      EAX, [EAX].TList.fItems\r
          MOV      ECX, dword ptr [EAX]\r
          JECXZ    @@ret_false1\r
          XCHG     EAX, ECX\r
          PUSH     EAX\r
          CALL     TControl.IsMainWindow\r
          TEST     EAX, EAX\r
          POP      EAX\r
          JZ       @@ret_false1\r
          CALL     TControl.Close\r
          POP      ECX\r
          XOR      EAX, EAX\r
          MOV      dword ptr [ECX], EAX\r
          INC      EAX\r
          JMP      @@exit     \r
  @@ret_false1:\r
          POP      ECX\r
  @@ret_false:\r
          XOR      EAX, EAX\r
  @@exit:\r
  end;\r
  {$ENDIF}\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcApp(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
begin\r
  Result := False;\r
  case Msg.message of\r
  WM_SETFOCUS:\r
    {$IFDEF NEW_MODAL}\r
    if Self_.fModalForm <> nil then\r
      SetFocus( Self_.fModalForm.fHandle )\r
    else if ( Self_.FCurrentControl <> nil ) and not\r
            ( Self_.fCurrentControl.IsForm xor Self_.fIsApplet ) then\r
    {$ELSE not_NEW_MODAL}\r
    if Self_.FCurrentControl <> nil then\r
    {$ENDIF NEW_MODAL}\r
    begin\r
      Self_.FCurrentControl.CreateWindow; //virtual!!!\r
      SetFocus( Self_.FCurrentControl.fHandle );\r
      Result := True;\r
    end;\r
  WM_SYSCOMMAND:\r
    if Msg.wParam and $FFF0 = SC_CLOSE then\r
    if (Self_.fChildren <> nil) and (Self_.fChildren.fCount > 0) and\r
       PControl( Self_.fChildren.fItems[ 0 ] ).IsMainWindow then\r
    begin\r
      PControl( Self_.fChildren.fItems[ 0 ] ).Close;\r
      Rslt := 0;\r
      Result := TRUE;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcApp]\r
\r
{$ENDIF WNDPROCAPP_USED}\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
{$DEFINE CREATEAPPBUTTON_USED}\r
//[function NewApplet]\r
function NewApplet( const Caption: String ): PControl;\r
begin\r
  new( Result, CreateApplet( Caption ) );\r
end;\r
//[END NewApplet]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewApplet]\r
{$IFDEF ASM_VERSION}\r
function NewApplet( const Caption: String ): PControl;\r
const AppClass: array[ 0..3 ] of Char = ( 'A', 'p', 'p', #0 );\r
asm\r
        XOR      ECX, ECX\r
        INC      ECX\r
        MOV      [AppButtonUsed], CL\r
        PUSH     EAX\r
        MOV      EDX, offset[AppClass]\r
        XOR      EAX, EAX\r
        CALL     _NewWindowed\r
        INC      [EAX].TControl.FIsApplet\r
        MOV      word ptr [EAX].TControl.fStyle + 2, $90CA //WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX or WS_CAPTION\r
        MOV      byte ptr [EAX].TControl.fExStyle + 2, WS_EX_APPWINDOW shr 16 // WS_EX_APPWINDOW = $40000\r
        CALL     @@newapp1\r
\r
        // BODY of CreateAppButton here:\r
        PUSH     ESI\r
        PUSH     0\r
        PUSH     [EAX].TControl.fHandle\r
        CALL     GetSystemMenu\r
        MOV      ESI, offset[DeleteMenu]\r
\r
        XCHG     ECX, EAX\r
        MOV      EAX, SC_MAXIMIZE\r
        CDQ\r
\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        PUSH     EDX\r
        {$IFDEF PARANOIA}\r
        DB $2C, $20\r
        {$ELSE}\r
        SUB      AL, $20  // SC_MOVE\r
        {$ENDIF}\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        PUSH     EDX\r
        {$IFDEF PARANOIA}\r
        DB $2C, $10\r
        {$ELSE}\r
        SUB      AL, $10  // SC_SIZE\r
        {$ENDIF}\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        PUSH     1    // MF_GRAYED or MF_BYCOMMAND\r
        MOV      AX, SC_RESTORE\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        CALL     EnableMenuItem\r
        CALL     ESI\r
        CALL     ESI\r
        CALL     ESI\r
        POP      ESI\r
@@ret_false:\r
        XOR      EAX, EAX\r
        RET\r
\r
@@chk_CLOSE:\r
          CMP      word ptr [EDX].TMsg.message, WM_SYSCOMMAND\r
          JNZ      @@ret_false\r
          MOV      EDX, dword ptr [EDX].TMsg.wParam\r
          AND      DX, $FFF0\r
          CMP      DX, SC_CLOSE\r
          JNZ      @@ret_false\r
          PUSH     ECX\r
          MOV      ECX, [EAX].TControl.fChildren\r
          JECXZ    @@ret_false1\r
          XCHG     EAX, ECX\r
          MOV      ECX, [EAX].TList.fCount\r
          JECXZ    @@ret_false1\r
          MOV      EAX, [EAX].TList.fItems\r
          MOV      ECX, dword ptr [EAX]\r
          JECXZ    @@ret_false1\r
          XCHG     EAX, ECX\r
          PUSH     EAX\r
          CALL     TControl.IsMainWindow\r
          TEST     EAX, EAX\r
          POP      EAX\r
          JZ       @@ret_false1\r
          CALL     TControl.Close\r
          POP      ECX\r
          XOR      EAX, EAX\r
          MOV      dword ptr [ECX], EAX\r
          INC      EAX\r
          RET\r
  @@ret_false1:\r
          POP      ECX\r
          JMP      @@ret_false\r
\r
@@newapp1:\r
        //MOV      [EAX].TControl.FCreateWndExt, offset[CreateAppButton]\r
        POP      [EAX].TControl.FCreateWndExt\r
        PUSH     EAX\r
        CALL     @@newapp2\r
\r
        // BODY of WndProcApp here:\r
        CMP      word ptr [EDX].TMsg.message, WM_SETFOCUS\r
        JNZ      @@chk_CLOSE\r
        MOV      ECX, [EAX].TControl.FCurrentControl\r
        JECXZ    @@ret_false\r
        XCHG     EAX, ECX\r
\r
        PUSH     EAX\r
        CALL     CallTControlCreateWindow\r
        POP      EAX\r
        PUSH     [EAX].TControl.fHandle\r
\r
        CALL     SetFocus\r
        MOV      AL, 1\r
        RET\r
\r
@@newapp2:\r
        POP      EDX\r
        CALL     TControl.AttachProc\r
        POP      EAX\r
        POP      EDX\r
        PUSH     EAX\r
        CALL     TControl.SetCaption\r
        POP      EAX\r
end;\r
\r
{$ELSE ASM_VERSION} //Pascal\r
\r
//[procedure CreateAppButton]\r
procedure CreateAppButton( App: PControl );\r
var M: HMenu;\r
begin\r
  M := GetSystemMenu( App.fHandle, False );\r
  DeleteMenu( M, SC_MAXIMIZE, MF_BYCOMMAND );\r
  DeleteMenu( M, SC_MOVE, MF_BYCOMMAND );\r
  DeleteMenu( M, SC_SIZE, MF_BYCOMMAND );\r
  EnableMenuItem( M, SC_RESTORE, MF_GRAYED or MF_BYCOMMAND );\r
end;\r
\r
//[function NewApplet]\r
function NewApplet( const Caption: String ): PControl;\r
begin\r
  AppButtonUsed := True;\r
  Result := _NewWindowed( nil, 'App', True );\r
  Result.FIsApplet := TRUE;\r
  Result.fStyle := WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX or WS_CAPTION;\r
  Result.fExStyle := WS_EX_APPWINDOW;\r
  Result.FCreateWndExt := CreateAppButton;\r
  Result.AttachProc( WndProcApp );\r
  Result.Caption := Caption;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewApplet]\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
{$IFDEF CREATEAPPBUTTON_USED}\r
procedure CreateAppButton( App: PControl );\r
asm\r
  {$IFDEF F_P}\r
        MOV      EAX, [App]\r
  {$ENDIF F_P}\r
        PUSH     ESI\r
        PUSH     0\r
        PUSH     [EAX].TControl.fHandle\r
        CALL     GetSystemMenu\r
        MOV      ESI, offset[DeleteMenu]\r
\r
        XCHG     ECX, EAX\r
        MOV      EAX, SC_MAXIMIZE\r
        CDQ\r
\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        PUSH     EDX\r
        {$IFDEF PARANOIA}\r
        DB $2C, $20\r
        {$ELSE}\r
        SUB      AL, $20  // SC_MOVE\r
        {$ENDIF}\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        PUSH     EDX\r
        {$IFDEF PARANOIA}\r
        DB $2C, $10\r
        {$ELSE}\r
        SUB      AL, $10  // SC_SIZE\r
        {$ENDIF}\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        PUSH     1    // MF_GRAYED or MF_BYCOMMAND\r
        MOV      AX, SC_RESTORE\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        CALL     EnableMenuItem\r
        CALL     ESI\r
        CALL     ESI\r
        CALL     ESI\r
        POP      ESI\r
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};\r
{$ENDIF CREATEAPPBUTTON_USED}\r
\r
var CtlIdCount: WORD = $8000;\r
\r
{-}\r
{$IFNDEF ASM_VERSION}\r
  //{$DEFINE CREATEPARAMS2_USED}\r
{$ENDIF}\r
{$IFDEF USE_CONSTRUCTORS}\r
  //{$DEFINE CREATEPARAMS2_USED}\r
{$ENDIF}\r
{+}\r
\r
{$IFDEF CREATEPARAMS2_USED} // seems not needed more\r
//[procedure CreateParams2]\r
procedure CreateParams2( Self_: PControl; var Params: TCreateParams);\r
begin\r
  Self_.CreateSubclass( Params, Self_.fControlClassName );\r
end;\r
{$ENDIF}\r
\r
//[FUNCTION _NewControl]\r
{$IFDEF ASM_VERSION}\r
function _NewControl( AParent: PControl; ControlClassName: PChar;\r
                      Style: DWORD; Ctl3D: Boolean; Actions: PCommandActions ): PControl;\r
const szActions = sizeof(TCommandActions);\r
asm\r
        PUSH     EBX\r
        PUSH     EAX  // push AParent\r
        PUSH     ECX  // push Style\r
        MOVZX    ECX, Ctl3D\r
        CALL     _NewWindowed\r
        XCHG     EBX, EAX\r
        INC      [EBX].TControl.fIsControl\r
        INC      [EBX].TControl.fVerticalAlign\r
        MOV      EAX, Actions\r
        TEST     EAX, EAX\r
        JZ       @@noActions\r
        LEA      EDX, [EBX].TControl.fCommandActions\r
        XOR      ECX, ECX\r
        MOV      CL, szActions\r
        CALL     System.Move\r
@@noActions:\r
        POP      EDX  // pop Style\r
        OR       EDX, WS_CLIPSIBLINGS or WS_CLIPCHILDREN\r
        MOV      byte ptr [EBX].TControl.fLookTabKeys, $0F\r
        CMP      [EBX].TControl.fCtl3D, 0\r
        JZ       @@noCtl3D\r
        AND      EDX, not WS_BORDER\r
        OR       byte ptr [EBX].TControl.fExStyle + 1, WS_EX_CLIENTEDGE shr 8\r
@@noCtl3D:\r
        MOV      [EBX].TControl.fStyle, EDX\r
        TEST     EDX, WS_VISIBLE\r
        SETNZ    AL\r
        MOV      [EBX].TControl.fVisible, AL\r
        TEST     EDX, WS_TABSTOP\r
        POP      ECX // pop AParent\r
        PUSHFD\r
        JECXZ    @@noParent\r
        MOV      EAX, [ECX].TControl.fCursor\r
        MOV      [EBX].TControl.fCursor, EAX\r
        XCHG     EAX, ECX\r
        CALL     TControl.ParentForm\r
        XCHG     ECX, EAX\r
        JECXZ    @@noParent\r
        INC      [ECX].TControl.fTabOrder\r
        MOV      EDX, [ECX].TControl.fTabOrder\r
        MOV      [EBX].TControl.fTabOrder, EDX\r
@@noParent:\r
        POPFD\r
        JZ       @@noTabStop\r
        INC      [EBX].TControl.fTabstop\r
        JECXZ    @@noTabstop\r
        XCHG     EAX, ECX\r
        MOV      ECX, [EAX].TControl.FCurrentControl\r
        INC      ECX\r
        LOOP     @@noTabStop\r
        MOV      [EAX].TControl.FCurrentControl, EBX\r
@@noTabStop:\r
        MOVZX    EDX, [CtlIdCount]\r
        INC      [CtlIdCount]\r
        MOV      [EBX].TControl.fMenu, EDX\r
        MOV      EDX, offset[WndProcCtrl]\r
        MOV      EAX, EBX\r
        CALL     TControl.AttachProc\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function _NewControl( AParent: PControl; ControlClassName: PChar;\r
                      Style: DWORD; Ctl3D: Boolean; Actions: PCommandActions ): PControl;\r
var Form: PControl;\r
begin\r
  Result := _NewWindowed( AParent, ControlClassName, Ctl3D );\r
  if Actions <> nil then\r
    Result.fCommandActions := Actions^;\r
  Result.fIsControl := True;\r
  Result.fStyle := Style or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;\r
  Result.fVerticalAlign := vaTop;\r
  Result.fVisible := (Style and WS_VISIBLE) <> 0;\r
  Result.fTabstop := (Style and WS_TABSTOP) <> 0;\r
  if (AParent <> nil) then\r
  begin\r
    Inc( AParent.ParentForm.fTabOrder );\r
    Result.fTabOrder := AParent.ParentForm.fTabOrder;\r
    Result.fCursor := AParent.fCursor;\r
  end;\r
  Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];\r
  if Result.fCtl3D then\r
  begin\r
    Result.fStyle := Result.fStyle and not WS_BORDER;\r
    Result.fExStyle := Result.fExStyle or WS_EX_CLIENTEDGE;\r
  end;\r
  if (Style and WS_TABSTOP) <> 0 then\r
  begin\r
    Form := Result.ParentForm;\r
    if Form <> nil then\r
    if Form.FCurrentControl = nil then\r
       Form.FCurrentControl := Result;\r
  end;\r
  //Result.fCreateParamsExt := CreateParams2;\r
  Result.fMenu := CtlIdCount;\r
  Inc( CtlIdCount );\r
  Result.AttachProc( WndProcCtrl );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _NewControl]\r
\r
//===================== Button ========================//\r
\r
//[function TControl.SetButtonIcon]\r
function TControl.SetButtonIcon(aIcon: HIcon): PControl;\r
var PrevImg: THandle;\r
begin\r
  Style := Style or BS_ICON;\r
  PrevImg := Perform( BM_SETIMAGE, IMAGE_ICON, aIcon );\r
  if PrevImg <> 0 then\r
    DeleteObject( PrevImg );\r
  Result := @ Self;\r
end;\r
\r
//[function TControl.SetButtonBitmap]\r
function TControl.SetButtonBitmap(aBmp: HBitmap): PControl;\r
var PrevImg: THandle;\r
begin\r
  Style := Style or BS_BITMAP;\r
  PrevImg := Perform( BM_SETIMAGE, IMAGE_BITMAP, aBmp );\r
  if PrevImg <> 0 then\r
    DeleteObject( PrevImg );\r
  Result := @ Self;\r
end;\r
\r
{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}\r
//[function WndProcBtnReturnClick]\r
function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  Result := FALSE;\r
  if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or\r
      (Msg.message = WM_CHAR)) and (Msg.wParam = 13) then\r
    Msg.wParam := 32;\r
end;\r
{$ENDIF}\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewButton]\r
function NewButton( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  new( Result, CreateButton( AParent, Caption ) );\r
end;\r
{$ELSE USE_CONSTRUCTORS}\r
\r
{$IFDEF ASM_VERSION}\r
const ButtonClass: array[ 0..6 ] of Char = ( 'B','U','T','T','O','N',#0 );\r
{$ENDIF ASM_VERSION}\r
\r
//[FUNCTION NewButton]\r
{$IFDEF ASM_VERSION}\r
function NewButton( AParent: PControl; const Caption: String ): PControl;\r
const szActions = sizeof(TCommandActions);\r
asm\r
        PUSH     EDX\r
\r
        PUSH     0\r
        PUSH     offset[ButtonActions]\r
\r
        MOV      EDX, offset[ButtonClass]\r
        MOV      ECX, WS_VISIBLE or WS_CHILD or BS_PUSHLIKE or WS_TABSTOP\r
        CALL     _NewControl\r
        INC      [EAX].TControl.fIgnoreDefault\r
        MOV      EDX, [EAX].TControl.fBoundsRect.Top\r
        ADD      EDX, 22\r
        MOV      [EAX].TControl.fBoundsRect.Bottom, EDX\r
        MOV      [EAX].TControl.fTextAlign, taCenter\r
        INC      [EAX].TControl.fIsButton\r
\r
        POP      EDX\r
        PUSH     EAX\r
        CALL     TControl.SetCaption\r
        POP      EAX\r
        {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}\r
        PUSH     EAX\r
        MOV      EDX, offset[WndProcBtnReturnClick]\r
        CALL     TControl.AttachProc\r
        POP      EAX\r
        {$ENDIF}\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewButton( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  Result := _NewControl( AParent, 'BUTTON',\r
            WS_VISIBLE or WS_CHILD or\r
            BS_PUSHLIKE or WS_TABSTOP, False, @ButtonActions );\r
  Result.fIgnoreDefault := TRUE;\r
  Result.fCtl3D := TRUE;\r
  with Result.fBoundsRect do\r
    Bottom := Top + 22;\r
  Result.fTextAlign := taCenter;\r
  Result.Caption := Caption;\r
  Result.fIsButton := TRUE;\r
  {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}\r
  Result.AttachProc( WndProcBtnReturnClick );\r
  {$ENDIF}\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewButton]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//----------------- BitBtn -----------------------\r
\r
//[FUNCTION WndProc_DrawItem]\r
{$IFDEF ASM_VERSION}\r
function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )\r
                          : Boolean;\r
asm     //cmd    //opd\r
       CMP       word ptr [EDX].TMsg.message, WM_DRAWITEM\r
       JNZ       @@ret_false\r
       MOV       EAX, [EDX].TMsg.lParam\r
       MOV       ECX, [EAX].TDrawItemStruct.hwndItem\r
       JECXZ     @@ret_false\r
       PUSH      EDX\r
       PUSH      offset[ID_SELF]\r
       PUSH      ECX\r
       CALL      GetProp\r
       POP       EDX\r
       TEST      EAX, EAX\r
       JZ        @@ret_false\r
       PUSH      [EDX].TMsg.lParam\r
       PUSH      [EDX].TMsg.wParam\r
       PUSH      CN_DRAWITEM\r
       PUSH      EAX\r
       CALL      TControl.Perform\r
       MOV       AL, 1\r
       RET\r
@@ret_false:\r
       XOR       EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )\r
                          : Boolean;\r
var DI: PDrawItemStruct;\r
    Control: PControl;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_DRAWITEM then\r
  begin\r
    DI := Pointer( Msg.lParam );\r
    Control := Pointer( GetProp( DI.hwndItem, ID_SELF ) );\r
    if Control <> nil then\r
    begin\r
      {Rslt := Integer(\r
      Control.OnDrawItem( Control, DI.hDC, DI.rcItem, DI.itemID,\r
                         TDrawAction( Byte( DI.itemAction ) ),\r
                         TDrawState( Word( DI.itemState ) ) ) );}\r
      Rslt := Control.Perform( CN_DRAWITEM, Msg.wParam, Msg.lParam );\r
      Result := TRUE;\r
    end;\r
      //else Rslt := 0;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProc_DrawItem]\r
\r
//[function ExcludeAmpersands]\r
function ExcludeAmpersands( Self_: PControl; const S: String ): String;\r
var I: Integer;\r
begin\r
  Result := S;\r
  if not Self_.FBitBtnDrawMnemonic then Exit;\r
  for I := Length( Result ) downto 1 do\r
  begin\r
    if Result[ I ] = '&' then\r
      Delete( Result, I, 1 );\r
  end;\r
end;\r
\r
//[procedure BitBtnExtDraw]\r
procedure BitBtnExtDraw( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect;\r
          const CapText, CapTxtOrig: String; Color: TColor );\r
var I, J, W, H: Integer;\r
    Sz: TSize;\r
    Pen, OldPen: HPen;\r
begin\r
  if not Self_.FBitBtnDrawMnemonic then Exit;\r
  J := 0;\r
  for I := 1 to Length( CapTxtOrig ) do\r
  begin\r
    if CapTxtOrig[ I ] <> '&' then\r
      Inc( J )\r
    else\r
    begin\r
      Windows.GetTextExtentPoint32( DC, PChar( CapText ), J, Sz );\r
      W := Sz.cx;\r
      Windows.GetTextExtentPoint32( DC, '_', 1, Sz );\r
      H := Sz.cy - 1;\r
      Windows.GetTextExtentPoint32( DC, @ CapTxtOrig[ I + 1 ], 1, Sz );\r
      Windows.MoveToEx( DC, X + W, Y + H, nil );\r
\r
      Pen := CreatePen( PS_SOLID, 0, Color2RGB( Color ) );\r
      OldPen := SelectObject( DC, Pen );\r
\r
      Windows.LineTo( DC, X + W + Sz.cx, Y + H );\r
\r
      SelectObject( DC, OldPen );\r
      DeleteObject( Pen );\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.SetBitBtnDrawMnemonic]\r
procedure TControl.SetBitBtnDrawMnemonic(const Value: Boolean);\r
begin\r
  FBitBtnDrawMnemonic := Value;\r
  FBitBtnGetCaption := ExcludeAmpersands;\r
  FBitBtnExtDraw := BitBtnExtDraw;\r
  Invalidate;\r
end;\r
\r
//[function TControl.GetBitBtnImgIdx]\r
function TControl.GetBitBtnImgIdx: Integer;\r
begin\r
  Result := LoWord( fGlyphCount );\r
end;\r
\r
//[procedure TControl.SetBitBtnImgIdx]\r
procedure TControl.SetBitBtnImgIdx(const Value: Integer);\r
begin\r
  if not( bboImageList in fBitBtnOptions ) then Exit;\r
  fGlyphCount := HiWord( fGlyphCount ) or (Value and $FFFF);\r
  Invalidate;\r
end;\r
\r
//[function TControl.GetBitBtnImageList]\r
function TControl.GetBitBtnImageList: THandle;\r
begin\r
  Result := 0;\r
  if bboImageList in fBitBtnOptions then\r
    Result := fGlyphBitmap;\r
end;\r
\r
//[procedure TControl.SetBitBtnImageList]\r
procedure TControl.SetBitBtnImageList(const Value: THandle);\r
begin\r
  fGlyphBitmap := Value;\r
  if Value <> 0 then\r
  begin\r
    fBitBtnOptions := fBitBtnOptions + [ bboImageList ];\r
    ImageList_GetIconSize( Value, fGlyphWidth, fGlyphHeight );\r
  end\r
  else\r
    fBitBtnOptions := fBitBtnOptions - [ bboImageList ];\r
  Invalidate;\r
end;\r
\r
//[FUNCTION WndProcBitBtn]\r
{$IFDEF ASM_noVERSION} // remove &-s from view //+ TextShift & if Y < 0 then Y := 0; // + glyph + TextShift if not glyphOver\r
function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
const szBitmapInfo = sizeof(TBitmapInfo);\r
asm\r
        CMP      word ptr [EDX].TMsg.message, WM_LBUTTONDBLCLK\r
        JNZ      @@noWM_LBUTTONDBLCLK\r
        PUSH     ECX\r
        PUSH     [EDX].TMsg.wParam\r
        PUSH     [EDX].TMsg.lParam\r
        PUSH     WM_LBUTTONDOWN\r
        PUSH     EAX\r
        CALL     TControl.Perform\r
        POP      ECX\r
        MOV      [ECX], EAX\r
        MOV      AL, 1\r
        RET\r
@@noWM_LBUTTONDBLCLK:\r
        PUSH     EBX\r
        CMP      [EDX].TMsg.message, CN_DRAWITEM\r
        JNZ      @@noCN_DRAWITEM\r
        PUSH     EDI\r
        PUSH     ESI\r
        XCHG     EDI, EAX // EDI = @Self\r
        MOV      dword ptr [ECX], 1\r
        MOV      ESI, [EDX].TMsg.lParam // ESI = DIS\r
        XOR      EBX, EBX // G = 0\r
        MOV      EAX, [ESI].TDrawItemStruct.itemState\r
        TEST     byte ptr [EDI].TControl.fBitBtnOptions, 8 //1 shl Ord(bboFixed)\r
        JNZ      @@fixed_in_options\r
        {$IFDEF PARANOIA}\r
        DB $A8, ODS_SELECTED\r
        {$ELSE}\r
        TEST     AL, ODS_SELECTED\r
        {$ENDIF}\r
        JZ       @@not1\r
        JMP      @@1\r
@@fixed_in_options:\r
        TEST     byte ptr [EDI].TControl.fChecked, 1\r
        JZ       @@not1\r
@@1:    INC      EBX\r
@@not1:\r
        {$IFDEF PARANOIA}\r
        DB $A8, ODS_DISABLED\r
        {$ELSE}\r
        TEST     AL, ODS_DISABLED\r
        {$ENDIF}\r
        JZ       @@not2\r
        MOV      BL, 2\r
@@not2: TEST     EBX, EBX\r
        JNZ      @@not3\r
        {$IFDEF PARANOIA}\r
        DB $A8, ODS_FOCUS\r
        {$ELSE}\r
        TEST     AL, ODS_FOCUS\r
        {$ENDIF}\r
        JZ       @@not3\r
        MOV      BL, 3\r
@@not3: CMP      [EDI].TControl.fMouseInControl, BH\r
        JZ       @@not4\r
        TEST     EBX, EBX\r
        JZ       @@4\r
        CMP      BL, 3\r
        JNZ      @@not4\r
@@4:    MOV      BL, 4\r
@@not4: MOV      ECX, [EDI].TControl.fOnBitBtnDraw.TMethod.Code\r
        TEST     ECX, ECX\r
        JZ       @@noOnBitBtnDraw\r
        //JECXZ    @@noOnBitBtnDraw\r
        MOV      EAX, [EDI].TControl.fCanvas\r
          PUSH     EAX\r
        TEST     EAX, EAX\r
        JZ       @@noCanvas\r
        MOV      EDX, [ESI].TDrawItemStruct.hDC\r
        CALL     TCanvas.SetHandle\r
@@noCanvas:\r
        MOV      EAX, [EDI].TControl.fOnBitBtnDraw.TMethod.Data\r
        MOV      EDX, EDI\r
        PUSH     EBX\r
        XCHG     ECX, EBX\r
        CALL     EBX\r
        POP      EBX\r
          POP      ECX // Canvas\r
        PUSH     EAX\r
        JECXZ    @@noCanvas2\r
        XCHG     EAX, ECX\r
        XOR      EDX, EDX\r
        CALL     TCanvas.SetHandle\r
@@noCanvas2:\r
        POP      EAX\r
        TEST     AL, AL\r
        JNZ      @@exit_draw\r
@@noOnBitBtnDraw:\r
        TEST     byte ptr [EDI].TControl.fBitBtnOptions, 2 //1 shl Ord(bboNoBorder)\r
        JNZ      @@noborder\r
        TEST     byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS\r
        JZ       @@noDefaultBorder\r
        PUSH     BLACK_BRUSH\r
        CALL     GetStockObject\r
        LEA      EDX, [ESI].TDrawItemStruct.rcItem\r
        OR       ECX, -1\r
        PUSH     ECX\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     [ESI].TDrawItemStruct.hDC\r
        CALL     Windows.FrameRect\r
        CALL     InflateRect\r
        XOR      ECX, ECX\r
        JMP      @@noFlat\r
@@noDefaultBorder:\r
        MOVZX    ECX, [EDI].TControl.fFlat\r
        JECXZ    @@noFlat\r
        AND      CL, [EDI].TControl.fMouseInControl\r
        JZ       @@noborder\r
@@noFlat:\r
        TEST     byte ptr [ESI].TDrawItemStruct.itemState, ODS_SELECTED\r
        MOV      CL, BDR_SUNKENOUTER or BDR_SUNKENINNER\r
        JNZ      @@border_sunken\r
        MOV      CL, BDR_RAISEDOUTER or BDR_RAISEDINNER\r
@@border_sunken:\r
        LEA      EDX, [ESI].TDrawItemStruct.rcItem\r
        OR       EAX, -1\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     BF_ADJUST or BF_RECT\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     [ESI].TDrawItemStruct.hDC\r
        CALL     DrawEdge\r
        CALL     InflateRect\r
@@noborder:\r
        PUSH     [ESI].TDrawItemStruct.rcItem.Bottom\r
        PUSH     [ESI].TDrawItemStruct.rcItem.Right\r
        PUSH     [ESI].TDrawItemStruct.rcItem.Top\r
        PUSH     [ESI].TDrawItemStruct.rcItem.Left\r
        MOV      EAX, [EDI].TControl.fGlyphWidth\r
        MOV      EDX, [EDI].TControl.fGlyphHeight\r
        TEST     EAX, EAX\r
        JLE      @@noglyph\r
        TEST     EDX, EDX\r
        JLE      @@noglyph\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
        // [EBP+4] = TxRect\r
\r
        PUSH     EDX // ImgH -> [EBP-4]\r
        PUSH     EAX // ImgW -> [EBP-8]\r
        PUSH     EDX // OutH -> [EBP-12]\r
        PUSH     EAX // OutW -> [EBP-16]\r
        MOV      EAX, [ESI].TDrawItemStruct.rcItem.Left // X = DIS.rcItem.Left\r
        MOV      EDX, [ESI].TDrawItemStruct.rcItem.Top  // Y = DIS.rcItem.Top\r
        MOV      ECX, [ESI].TDrawItemStruct.rcItem.Bottom\r
        SUB      ECX, EDX\r
        PUSH     ECX // H -> [EBP-20]\r
        MOV      ECX, [ESI].TDrawItemStruct.rcItem.Right\r
        SUB      ECX, EAX\r
        PUSH     ECX // W -> [EBP-24]\r
        MOVZX    ECX, [EDI].TControl.fGlyphLayout\r
        PUSH     EBX\r
        INC      ECX\r
        LOOP     @@noGlyphLeft\r
        MOV      EBX, EAX      // X\r
        ADD      EBX, [EBP-16] // +OutW\r
        MOV      [EBP+4].TRect.Left, EBX // TxRect.Left = X+OutW\r
        JMP      @@centerY\r
@@noGlyphLeft:\r
        LOOP     @@noGlyphTop\r
        MOV      EBX, EDX      // Y\r
        ADD      EBX, [EBP-12] // +OutH\r
        MOV      [EBP+4].TRect.Top, EBX // TxRect.Top = Y+OutH\r
        LOOP     @@centerX // always JMP, ECX := -1\r
@@noGlyphTop:\r
        LOOP     @@noGlyphRight\r
        MOV      EAX, [ESI].TDrawItemStruct.rcItem.Right\r
        SUB      EAX, [EBP-16] // -OutW -> X\r
        MOV      [EBP+4].TRect.Right, EAX\r
@@centerY:\r
        MOV      EBX, [EBP-20] // H\r
        SUB      EBX, [EBP-12] // -OutH\r
        JLE      @@noGlyphRight\r
        SAR      EBX, 1\r
        ADD      EDX, EBX      // Y = Y + (H-OutH)/2\r
@@noGlyphRight:\r
        LOOP     @@noGlyphBottom\r
        MOV      EDX, [ESI].TDrawItemStruct.rcItem.Bottom\r
        SUB      EDX, [EBP-12] // -OutH -> Y\r
        MOV      [EBP+4].TRect.Bottom, EDX\r
        LOOP     @@centerX // always JMP, ECX := -1\r
@@noGlyphBottom:\r
        LOOP     @@noGlyphOver\r
@@centerX:\r
        MOV      EBX, [EBP-24] // W\r
        SUB      EBX, [EBP-16] // -OutW\r
        SHR      EBX, 1        // /2\r
        ADD      EAX, EBX      // +EAX, X = X + (W-OutW)/2\r
        JECXZ    @@centerY\r
@@noGlyphOver:\r
        MOV      ECX, [ESI].TDrawItemStruct.rcItem.Left\r
        CMP      EAX, ECX\r
        JGE      @@ok1\r
        XCHG     EAX, ECX\r
@@ok1:  CMP      EDX, [ESI].TDrawItemStruct.rcItem.Top\r
        {$IFDEF USE_CMOV}\r
        CMOVL    EDX, [ESI].TDrawItemStruct.rcItem.Top\r
        {$ELSE}\r
        JGE      @@ok2\r
        MOV      EDX, [ESI].TDrawItemStruct.rcItem.Top\r
@@ok2:  {$ENDIF}\r
\r
        MOV      ECX, [ESI].TDrawItemStruct.rcItem.Right\r
        SUB      ECX, EAX\r
        CMP      [EBP-16], ECX\r
        JLE      @@ok3\r
        MOV      [EBP-16], ECX // OutW := rcItem.Right - X;\r
@@ok3:  MOV      ECX, [ESI].TDrawItemStruct.rcItem.Bottom\r
        SUB      ECX, EDX\r
        CMP      ECX, [EBP-12]\r
        JGE      @@ok4\r
        MOV      [EBP-12], ECX // OutH := rcItem.Bottom - Y;\r
@@ok4:\r
        POP      EBX // EBX = G\r
        TEST     byte ptr [EDI].TControl.fBitBtnOptions, 1 //1 shl Ord(bboImageList)\r
        JZ       @@draw_bitmap\r
        MOVZX    ECX, word ptr [EDI].TControl.fGlyphCount\r
        CMP      word ptr [EDI].TControl.fGlyphCount + 2, BX\r
        JLE      @@no_add_glyphIdx\r
        ADD      ECX, EBX\r
@@no_add_glyphIdx:\r
        XOR      EBX, EBX\r
        PUSH     ILD_TRANSPARENT // Flags = 1 (ILD_TRANSPARENT)\r
        PUSH     EBX // Blend = 0\r
        PUSH     -1  // Bk = CLR_NONE\r
        PUSH     EBX // 0\r
        PUSH     EBX // 0\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     [ESI].TDrawItemStruct.hDC\r
        PUSH     ECX\r
        PUSH     [EDI].TControl.fGlyphBitmap\r
        CMP      [EDI].TControl.fTransparent, BL\r
        JNZ      @@imgl_transp\r
        MOV      EAX, [EDI].TControl.fColor\r
        CALL     Color2RGB\r
        MOV      [ESP+32], EAX // Bk = Color2RGB(fColor)\r
        MOV      [ESP+40], EBX // Flags = 0\r
@@imgl_transp:\r
        INC      EBX\r
        CMP      word ptr [EDI].TControl.fGlyphCount + 2, BX\r
        JNZ      @@draw_imagelist\r
        DEC      byte ptr [ESP+36+3] // $FF, CLR_DEFAULT = $FF000000\r
        TEST     byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS\r
        JZ       @@draw_imagelist\r
        OR       byte ptr [ESP+40], ILD_BLEND25 // Flags != 2\r
@@draw_imagelist:\r
        CALL     ImageList_DrawEx\r
        JMP      @@glyph_drawn\r
\r
@@draw_bitmap:\r
        PUSH     EAX // PlaceHold for DC\r
        PUSH     EAX // PlaceHold for OldBmp\r
        PUSH     SRCCOPY\r
        PUSH     dword ptr [EBP-4] // ImgH\r
        PUSH     dword ptr [EBP-8] // ImgW\r
        PUSH     0\r
        PUSH     EAX // PlaceHold for I\r
        PUSH     EAX // PlaceHold for DC\r
        PUSH     dword ptr [EBP-12] // OutH\r
        PUSH     dword ptr [EBP-16] // OutW\r
        PUSH     EDX // Y\r
        PUSH     EAX // X\r
        PUSH     [ESI].TDrawItemStruct.hDC\r
\r
        PUSH     0\r
        CALL     CreateCompatibleDC\r
        MOV      [ESP+48], EAX // save DC\r
        MOV      [ESP+20], EAX // place DC\r
        PUSH     [EDI].TControl.fGlyphBitmap\r
        PUSH     EAX\r
        CALL     SelectObject\r
        MOV      [ESP+44], EAX // save OldBitmap\r
        XOR      EAX, EAX\r
        CMP      [EDI].TControl.fGlyphCount, EBX\r
        JLE      @@no_incGlyIdx\r
        MOV      EAX, [EBP-8] // ImgW\r
        IMUL     EBX\r
@@no_incGlyIdx:\r
        MOV      [ESP+24], EAX // place I\r
        CALL     StretchBlt\r
        CALL     FinishDC\r
\r
@@glyph_drawn:\r
        MOV      ESP, EBP\r
        POP      EBP\r
\r
@@noglyph:\r
        TEST     byte ptr[EDI].TControl.fBitBtnOptions, 4 //1 shl Ord(bboNoCaption)\r
        JNZ      @@noCaption\r
\r
\r
        POP      EAX\r
        PUSH     EAX\r
        MOV      EDX, [ESP].TRect.Right\r
        CMP      EDX, EAX\r
        JLE      @@noCaption\r
        MOV      EDX, [ESP].TRect.Bottom\r
        CMP      EDX, [ESP].TRect.Top\r
        JLE      @@noCaption\r
\r
        XOR      EBX, EBX\r
        PUSH     EBX                      // > CapText\r
        MOV      EDX, ESP\r
        MOV      EAX, EDI\r
        CALL     TControl.GetCaption\r
        PUSH     EBX                      // > Bk\r
        PUSH     EBX                      // > Blend\r
        CMP      [EDI].TControl.fTransparent, BL\r
        MOV      BL, ETO_CLIPPED\r
        JNZ      @@drwTxTransparent\r
        CMP      [EDI].TControl.fGlyphLayout, glyphOver\r
        JNZ      @@drwTxOpaque\r
@@drwTxTransparent:\r
        PUSH     TRANSPARENT\r
        PUSH     [ESI].TDrawItemStruct.hDC\r
        CALL     SetBkMode\r
        MOV      [ESP+4], EAX // Bk := SetBkMode( DIS.hDC, TRANSPARENT )\r
        JMP      @@drwTx1\r
@@drwTxOpaque:\r
        MOV      BL, ETO_CLIPPED or ETO_OPAQUE\r
        MOV      EAX, [EDI].TControl.fColor\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        PUSH     [ESI].TDrawItemStruct.hDC\r
        CALL     SetBkColor\r
        POP      ECX\r
        PUSH     EAX // Blend := SetBkColor(DIS.hDC,fColor)\r
@@drwTx1:\r
        PUSH     0   // > OldFont\r
        PUSH     0   // > OldTextColor\r
\r
        PUSH     0                 // push <nil>\r
        MOV      EDX, [ESP+20] // CapText\r
        CALL     EDX2PChar\r
        PUSH     dword ptr [EDX-4] // push Length(CapText)\r
        PUSH     EDX               // push PChar(CapText)\r
        LEA      EAX, [ESP+32]\r
        PUSH     EAX               // push @TxRect\r
        PUSH     EBX               // push Flags\r
\r
        MOV      EBX, [ESI].TDrawItemStruct.hDC\r
\r
        MOV      ECX, [EDI].TControl.fFont\r
        JECXZ    @@drwTx_noFont\r
        XCHG     EAX, ECX\r
        CALL     TGraphicTool.GetHandle\r
        PUSH     EAX\r
        PUSH     EBX\r
        CALL     SelectObject\r
        MOV      [ESP+24], EAX // OldFont := SelectObject...\r
@@drwTx_noFont:\r
        MOV      EAX, [EDI].TControl.fTextColor\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        PUSH     EBX\r
        CALL     SetTextColor\r
        MOV      [ESP+20], EAX // OldTextColor := SetTextColor...\r
\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     ESP\r
        MOV      ECX, [ESP+48] // ECX = CapText\r
        XOR      EAX, EAX\r
        JECXZ    @@drwTx0\r
        MOV      EAX, [ECX-4]  // EAX = Length(CapText)\r
@@drwTx0:\r
        PUSH     EAX\r
        PUSH     ECX\r
        PUSH     EBX\r
        CALL     GetTextExtentPoint32\r
        POP      ECX // ECX = TextSz.cx\r
        POP      EDX // EDX = TextSz.cy\r
        MOV      EAX, [ESP+40].TRect.Bottom\r
        SUB      EAX, [ESP+40].TRect.Top\r
        SUB      EAX, EDX\r
        JGE      @@yOk\r
        XOR      EAX, EAX\r
@@yOk:  SHR      EAX, 1\r
        ADD      EAX, [ESP+40].TRect.Top\r
        PUSH     EAX                      // push Y\r
        MOV      EDX, [ESP+44].TRect.Right\r
        MOV      EAX, [ESP+44].TRect.Left // EAX = TxRect.Left\r
        SUB      EDX, EAX // EDX = W\r
        PUSH     EAX\r
        CMP      [EDI].TControl.fTextAlign, taRight\r
        JL       @@chk_X\r
        JE       @@alignR\r
        SUB      ECX, EDX\r
        SAR      ECX, 1\r
        JMP      @@alignC\r
@@alignR:\r
        ADD      EAX, EDX\r
@@alignC:\r
        SUB      EAX, ECX\r
@@chk_X:POP      EDX\r
        CMP      EAX, EDX\r
        JGE      @@xOk\r
        XCHG     EAX, EDX\r
@@xOk:  PUSH     EAX                      // push X\r
        PUSH     EBX                      // push hDC\r
        CALL     ExtTextOut\r
\r
        PUSH     EBX\r
        CALL     SetTextColor\r
        POP      ECX\r
        JECXZ    @@noRestoreFont\r
        PUSH     ECX\r
        PUSH     EBX\r
        CALL     SelectObject\r
@@noRestoreFont:\r
        POP      ECX // Blend\r
        JECXZ    @@restoreBk\r
        PUSH     ECX\r
        PUSH     EBX\r
        CALL     SetBkColor\r
        POP      ECX\r
        JMP      @@delCaption\r
@@restoreBk:\r
        PUSH     EBX\r
        CALL     SetBkMode\r
@@delCaption:\r
        CALL     RemoveStr\r
\r
@@noCaption:\r
        ADD      ESP, 16\r
\r
@@exit_draw:\r
        POP      ESI\r
        POP      EDI\r
        POP      EBX\r
        MOV      AL, 1\r
        RET\r
\r
@@noCN_DRAWITEM:\r
        CMP      word ptr [EDX].TMsg.message, WM_LBUTTONDOWN\r
        JZ       @@doDown\r
        CMP      word ptr [EDX].TMsg.message, WM_KEYDOWN\r
        JNZ      @@noWM_LBUTTONDOWN\r
        CMP      [EDX].TMsg.wParam, 32\r
        JNZ      @@noWM_LBUTTONDOWN\r
@@doDown:\r
        PUSH     EDX\r
        XCHG     EBX, EAX\r
\r
        CALL     @@fixed_proc\r
        MOV      ECX, [EBX].TControl.fRepeatInterval\r
        JECXZ    @@exit_LBUTTONDOWN\r
        //MOV      EAX, EBX\r
        //CALL     TControl.DoClick\r
        POP      EDX\r
        PUSH     EDX\r
        CMP      word ptr [EDX].TMsg.message, WM_KEYDOWN\r
        JZ       @@not_SetTimer\r
        PUSH     0\r
        PUSH     [EBX].TControl.fRepeatInterval\r
        PUSH     1\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     SetTimer\r
@@exit_LBUTTONDOWN:\r
@@not_SetTimer:\r
        POP      EDX\r
        JMP      @@invalidate\r
\r
@@noWM_LBUTTONDOWN:\r
        CMP      word ptr [EDX].TMsg.message, WM_TIMER\r
        JNZ      @@noWM_TIMER\r
\r
        XCHG      EBX, EAX\r
        PUSH     0\r
        PUSH     0\r
        PUSH     BM_GETSTATE\r
        PUSH     EBX\r
        CALL     TControl.Perform\r
        {$IFDEF PARANOIA}\r
        DB $A8, 4\r
        {$ELSE}\r
        TEST AL, BST_PUSHED\r
        {$ENDIF}\r
        JNZ      @@pushed\r
        PUSH     1\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     KillTimer\r
        CALL     ReleaseCapture\r
        JMP      @@noWM_TIMER\r
@@fixed_proc:\r
        TEST     byte ptr [EBX].TControl.fBitBtnOptions, 8 // bboFixed\r
        JZ       @@not_fixed\r
        XOR      [EBX].TControl.fChecked, 1\r
        MOV      ECX, [EBX].TControl.fOnChange.TMethod.Code\r
        JECXZ    @@not_fixed\r
        MOV      EAX, [EBX].TControl.fOnChange.TMethod.Data\r
        MOV      EDX, EBX\r
        JMP      ECX\r
@@pushed:\r
        CALL     @@fixed_proc\r
        MOV      EAX, EBX\r
        CALL     TControl.DoClick\r
@@invalidate:\r
        XCHG     EAX, EBX\r
        CALL     TControl.Invalidate\r
@@noWM_TIMER:\r
        XOR      EAX, EAX\r
        POP      EBX\r
@@not_fixed:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var DIS: PDrawItemStruct;\r
    IsDown, IsDefault, IsDisabled: Boolean;\r
    Flags: Integer;\r
    X, Y, W, H, ImgW, ImgH, OutW, OutH, I, G, Bk, Blend: Integer;\r
    //BI: TBitmapInfo;\r
    //Dib: TDibSection;\r
    TxRect: TRect;\r
    OldFont: HFont;\r
    OldTextColor: TColor;\r
    CapText, CapTxtOrig: String;\r
    TextSz: TSize;\r
    DC: HDC;\r
    OldBmp: HBitmap;\r
    Handled: Boolean;\r
    //Br: HBrush;\r
begin\r
  Result := False;\r
  if (Msg.message = WM_LBUTTONDBLCLK) then\r
  begin\r
    Rslt := Self_.Perform( WM_LBUTTONDOWN, Msg.wParam, Msg.lParam );\r
    Result := True;\r
    Exit;\r
  end;\r
  if (Msg.message = CN_DRAWITEM) then\r
  begin\r
    Result := True;\r
    Rslt := 1;\r
    DIS := Pointer( Msg.lParam );\r
    IsDown := DIS.itemState and ODS_SELECTED <> 0;\r
    IsDefault := DIS.itemState and ODS_FOCUS <> 0;\r
    IsDisabled := DIS.itemState and ODS_DISABLED <> 0;\r
    G := 0;\r
    if IsDown and not(bboFixed in Self_.fBitBtnOptions)\r
    or (bboFixed in Self_.fBitBtnOptions) and Self_.fChecked then\r
      G := 1;\r
    if IsDisabled then\r
      G := 2;\r
    if (G = 0) and IsDefault then\r
      G := 3;\r
    if ((G = 0) or (G = 3)) and Self_.MouseInControl then\r
      G := 4;\r
    if Assigned( Self_.fOnBitBtnDraw ) then\r
    begin\r
      if Assigned( Self_.fCanvas ) then\r
        Self_.fCanvas.SetHandle( DIS.hDC );\r
      Handled := Self_.fOnBitBtnDraw( Self_, G );\r
      if Assigned( Self_.fCanvas ) then\r
        Self_.fCanvas.SetHandle( 0 );\r
      if Handled then Exit;\r
    end;\r
    if not ( bboNoBorder in Self_.fBitBtnOptions ) then\r
    begin\r
      if IsDefault then\r
      begin\r
        Windows.FrameRect( DIS.hDC, DIS.rcItem, GetStockObject( BLACK_BRUSH ) );\r
        InflateRect( DIS.rcItem, -1, -1 );\r
      end;\r
      if not Self_.fFlat or Self_.fMouseInControl or IsDefault then\r
      begin\r
        if IsDown then\r
          Flags := BDR_SUNKENOUTER or BDR_SUNKENINNER\r
        else\r
          Flags := BDR_RAISEDOUTER or BDR_RAISEDINNER;\r
        DrawEdge( DIS.hDC, DIS.rcItem, Flags, BF_ADJUST or BF_RECT );\r
        InflateRect( DIS.rcItem, -1, -1 );\r
      end;\r
    end;\r
    TxRect := DIS.rcItem;\r
    if Self_.fGlyphBitmap <> 0 then\r
    begin\r
      ImgW := Self_.fGlyphWidth;\r
      ImgH := Self_.fGlyphHeight;\r
      if (ImgW > 0) and (ImgH > 0) then\r
      begin\r
        OutW := ImgW;\r
        OutH := ImgH;\r
        W := DIS.rcItem.Right - DIS.rcItem.Left;\r
        H := DIS.rcItem.Bottom - DIS.rcItem.Top;\r
        X := DIS.rcItem.Left;\r
        Y := DIS.rcItem.Top;\r
        if isDown and (Self_.fGlyphLayout <> glyphOver) then\r
        begin\r
          Inc( X, Self_.TextShiftX );\r
          Inc( Y, Self_.TextShiftY );\r
        end;\r
        case Self_.fGlyphLayout of\r
          glyphLeft:\r
            begin\r
              Y := Y + (H - OutH) div 2;\r
              TxRect.Left := X + OutW;\r
            end;\r
          glyphTop:\r
            begin\r
              X := X + (W - OutW) div 2;\r
              TxRect.Top := Y + OutH;\r
            end;\r
          glyphRight:\r
            begin\r
              X := DIS.rcItem.Right - OutW;\r
              TxRect.Right := X;\r
              Y := Y + (H - OutH) div 2;\r
            end;\r
          glyphBottom:\r
            begin\r
              Y := DIS.rcItem.Bottom - OutH;\r
              TxRect.Bottom := Y;\r
              X := X + (W - OutW) div 2;\r
            end;\r
          glyphOver:\r
            begin\r
              X := X + (W - OutW) div 2;\r
              Y := Y + (H - OutH) div 2;\r
            end;\r
        end;\r
        if X < DIS.rcItem.Left then\r
          X := DIS.rcItem.Left;\r
        if Y < DIS.rcItem.Top then\r
          Y := DIS.rcItem.Top;\r
        if X + OutW > DIS.rcItem.Right then\r
          OutW := DIS.rcItem.Right - X;\r
        if Y + OutH > DIS.rcItem.Bottom then\r
          OutH := DIS.rcItem.Bottom - Y;\r
\r
        //Br := CreateSolidBrush( Color2RGB( Self_.fColor ) );\r
        //Windows.FillRect( DIS.hDC, MakeRect( X, DIS.rcItem.Top, X + OutW, DIS.rcItem.Bottom ), Br );\r
        //DeleteObject( Br );\r
\r
        if bboImageList in Self_.fBitBtnOptions then\r
          begin\r
            I := LoWord( Self_.fGlyphCount );\r
            if //(HiWord( Self_.fGlyphCount ) > 1) and\r
               (HiWord( Self_.fGlyphCount ) > G) then\r
               I := I + G;\r
            Flags := 0; // ILD_NORMAL\r
            Blend := 0;\r
            if not Self_.fTransparent then\r
              Bk := Color2RGB( Self_.fColor )\r
            else\r
              begin\r
                Bk := Integer(CLR_NONE);\r
                Flags := ILD_TRANSPARENT;\r
              end;\r
            if HiWord( Self_.fGlyphCount ) = 1 then\r
            begin\r
              Blend := Integer(CLR_DEFAULT);\r
              if IsDefault then\r
                Flags := Flags or ILD_BLEND25;\r
            end;\r
            ImageList_DrawEx( Self_.fGlyphBitmap, I, DIS.hDC, X, Y, 0, 0,\r
              Bk, Blend, Flags );\r
          end\r
        else\r
          begin\r
            DC := CreateCompatibleDC( 0 );\r
            OldBmp := SelectObject( DC, Self_.fGlyphBitmap );\r
\r
            I := 0;\r
            if Self_.fGlyphCount > G then\r
              I := I + G * ImgW;\r
            StretchBlt( DIS.hDC, X, Y, OutW, OutH, DC, I, 0, ImgW, ImgH, SRCCOPY );\r
\r
            SelectObject( DC, OldBmp );\r
            DeleteDC( DC );\r
          end;\r
      end;\r
    end;\r
    if not (bboNoCaption in Self_.fBitBtnOptions) then\r
    //if (Self_.Text <> '') then\r
    if (TxRect.Right > TxRect.Left) and (TxRect.Bottom > TxRect.Top) then\r
    begin\r
      CapText := Self_.Caption;\r
      /////////////////////////////////////////////  added 19 Nov 2001\r
      CapTxtOrig := CapText;\r
      if Assigned( Self_.FBitBtnGetCaption ) then\r
        CapText := Self_.FBitBtnGetCaption( Self_, CapText );\r
      /////////////////////////////////////////////\r
\r
      Bk := 0;\r
      Blend := 0;\r
      Flags := ETO_CLIPPED;\r
      if Self_.fTransparent or (Self_.fGlyphLayout = glyphOver) then\r
        Bk := SetBkMode( DIS.hDC, TRANSPARENT )\r
      else\r
      begin\r
        Flags := Flags or ETO_OPAQUE;\r
        Blend := SetBkColor( DIS.hDC, Color2RGB( Self_.fColor ) );\r
      end;\r
        // Returned previous BkMode is either OPAQUE=1 or TRANSPARENT=2\r
\r
      OldFont := 0;\r
      if assigned( Self_.fFont ) then\r
        OldFont := SelectObject( DIS.hDC, Self_.fFont.Handle );\r
      OldTextColor := SetTextColor( DIS.hDC, Color2RGB( Self_.fTextColor ) );\r
\r
      Windows.GetTextExtentPoint32( DIS.hDC, PChar( CapText ), Length( CapText ),\r
        TextSz );\r
      W := TxRect.Right - TxRect.Left;\r
      H := TxRect.Bottom - TxRect.Top;\r
      Y := TxRect.Top + (H - TextSz.cy) div 2;\r
      case Self_.fTextAlign of\r
        taLeft: X := TxRect.Left;\r
        taCenter: X := TxRect.Left + (W - TextSz.cx) div 2;\r
        else {taRight:} X := TxRect.Right - TextSz.cx;\r
      end;\r
      if isDown then\r
      begin\r
        Inc( X, Self_.TextShiftX );\r
        Inc( Y, Self_.TextShiftY );\r
      end;\r
      if Y < 0 then\r
        Y := 0;\r
      if X < TxRect.Left then\r
        X := TxRect.Left;\r
\r
      Windows.ExtTextOut( DIS.hDC, X, Y, Flags, @TxRect,\r
        PChar( CapText ), Length( CapText ), nil );\r
\r
      //////////////////////////////////////////////////////////////////////////\r
      //  added 19 Nov 2001 to provide underlying mnemonic characters\r
      if Assigned( Self_.FBitBtnExtDraw ) then\r
        Self_.FBitBtnExtDraw( Self_, DIS.hDC, X, Y, TxRect, CapText, CapTxtOrig,\r
                              OldTextColor );\r
      //////////////////////////////////////////////////////////////////////////\r
\r
      SetTextColor( DIS.hDC, OldTextColor );\r
      if OldFont <> 0 then\r
        SelectObject( DIS.hDC, OldFont );\r
\r
      if Blend = 0 then\r
        SetBkMode( DIS.hDC, Bk )\r
      else\r
        SetBkColor( DIS.hDC, Blend );\r
    end;\r
  end;\r
  if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_KEYDOWN) and (Msg.wParam = 32) then\r
  begin\r
    if bboFixed in Self_.fBitBtnOptions then\r
    begin\r
      Self_.fChecked := not Self_.fChecked;\r
      if Assigned( Self_.fOnChange ) then\r
        Self_.fOnChange( Self_ );\r
    end;\r
    if Self_.fRepeatInterval > 0 then\r
    begin\r
      //Self_.DoClick;\r
      if Msg.message <> WM_KEYDOWN then\r
        SetTimer( Self_.fHandle, 1, Self_.fRepeatInterval, nil );\r
      Self_.Invalidate;\r
    end;\r
  end;\r
\r
  // added 15 Aug 2002 to repaint when focus lost:\r
  if Msg.message = WM_KILLFOCUS then\r
    Self_.Invalidate;\r
\r
  if Msg.message = WM_TIMER then\r
  begin\r
    if Self_.Perform( BM_GETSTATE, 0, 0 ) and BST_PUSHED = 0 then\r
    begin\r
      KillTimer( Self_.fHandle, 1 );\r
      ReleaseCapture;\r
    end\r
       else\r
    begin\r
      if bboFixed in Self_.fBitBtnOptions then\r
      begin\r
        Self_.fChecked := not Self_.fChecked;\r
        if Assigned( Self_.fOnChange ) then\r
          Self_.fOnChange( Self_ );\r
      end;\r
      Self_.DoClick;\r
      Self_.Invalidate;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcBitBtn]\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewBitBtn]\r
function NewBitBtn( AParent: PControl; const Caption: String;\r
         Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap;\r
         GlyphCount: Integer ): PControl;\r
begin\r
  new( Result, CreateBitBtn( AParent, Caption, Options, Layout, GlyphBitmap, GlyphCount ) );\r
end;\r
//[END NewBitBtn]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewBitBtn]\r
{$IFDEF ASM_VERSION}\r
function NewBitBtn( AParent: PControl; const Caption: String;\r
         Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl;\r
const szBitmapInfo = sizeof(TBitmapInfo);\r
asm\r
        PUSH     EBX\r
        PUSH     EDX\r
        PUSH     ECX\r
\r
        PUSH     0\r
        PUSH     offset[ButtonActions]\r
        MOV      EDX, offset[ButtonClass]\r
        MOV      ECX, WS_VISIBLE or WS_CHILD or WS_TABSTOP or BS_OWNERDRAW\r
        CALL     _NewControl\r
        XCHG     EBX, EAX\r
        INC      [EBX].TControl.fIgnoreDefault\r
        INC      [EBX].TControl.fIsButton\r
        MOV      byte ptr [EBX].TControl.fCommandActions.aAutoSzX, 8\r
        MOV      byte ptr [EBX].TControl.fCommandActions.aAutoSzY, 8\r
        POP      EAX\r
        MOV      [EBX].TControl.fBitBtnOptions, AL\r
        MOVZX    EDX, Layout\r
        MOV      [EBX].TControl.fGlyphLayout, DL\r
        MOV      ECX, GlyphBitmap\r
        MOV      [EBX].TControl.fGlyphBitmap, ECX\r
        MOV      EDX, [EBX].TControl.fBoundsRect.Top\r
        ADD      EDX, 22\r
        MOV      [EBX].TControl.fBoundsRect.Bottom, EDX\r
        TEST     ECX, ECX\r
        JZ       @@noGlyphWH\r
        {$IFDEF PARANOIA}\r
        DB $A8, 01\r
        {$ELSE}\r
        TEST AL, bboImageList\r
        {$ENDIF}\r
        JZ       @@getBmpWH\r
        PUSH     EAX\r
        MOV      EAX, ESP\r
        PUSH     EAX\r
        MOV      EDX, ESP\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     ECX\r
        CALL     ImageList_GetIconSize\r
        POP      EAX\r
        POP      EDX\r
        MOV      ECX, GlyphCount\r
        JMP      @@WHready\r
@@getBmpWH:\r
        ADD      ESP, -szBitmapInfo\r
        PUSH     ESP\r
        PUSH     szBitmapInfo\r
        PUSH     ECX\r
        CALL     GetObject\r
        XCHG     ECX, EAX\r
        POP      EAX\r
        POP      EAX\r
        POP      EDX\r
        ADD      ESP, szBitmapInfo-12\r
        TEST     ECX, ECX\r
        JZ       @@noGlyphWH\r
        MOV      ECX, GlyphCount\r
        INC      ECX\r
        LOOP     @@GlyphCountOK\r
        PUSH     EAX\r
        PUSH     EDX\r
        XCHG     EDX, ECX\r
        DIV      ECX\r
        XCHG     ECX, EAX\r
        POP      EDX\r
        POP      EAX\r
@@GlyphCountOK:\r
        CMP      ECX, 1\r
        JLE      @@WHReady\r
        PUSH     EDX\r
        CDQ\r
        IDIV     ECX\r
        POP      EDX\r
@@WHReady:\r
        MOV      [EBX].TControl.fGlyphWidth, EAX\r
        MOV      [EBX].TControl.fGlyphHeight, EDX\r
        MOV      [EBX].TControl.fGlyphCount, ECX\r
        POP      ECX     // ECX = @ Caption[ 1 ]\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     EAX\r
        TEST     EAX, EAX\r
        JLE      @@noWidthResize\r
        JECXZ    @@addWLeft\r
        CMP      [Layout], glyphOver\r
        JE       @@addWLeft\r
        MOVZX    ECX, byte ptr[ECX]\r
        JECXZ    @@addWLeft\r
        // else\r
        CMP      [Layout], glyphLeft\r
        JZ       @@addWRight\r
        CMP      [Layout], glyphRight\r
        JNZ      @@noWidthResize\r
@@addWRight:\r
        ADD      [EBX].TControl.fBoundsRect.Right, EAX\r
        ADD      [EBX].TControl.fCommandActions.aAutoSzX, AX\r
        JMP      @@noWidthResize\r
@@addWLeft:\r
        // then\r
        ADD      EAX, [EBX].TControl.fBoundsRect.Left\r
        MOV      [EBX].TControl.fBoundsRect.Right, EAX\r
        MOV      byte ptr [EBX].TControl.fCommandActions.aAutoSzX, 0\r
@@noWidthResize:\r
        TEST     EDX, EDX\r
        JLE      @@noHeightResize\r
        CMP      [Layout], glyphTop\r
        JE       @@addHBottom\r
        CMP      [Layout], glyphBottom\r
        JNE      @@addHTop\r
@@addHBottom:\r
        ADD      [EBX].TControl.fBoundsRect.Bottom, EDX\r
        ADD      [EBX].TControl.fCommandActions.aAutoSzY, DX\r
        JMP      @@noHeightResize\r
@@addHTop:\r
        ADD      EDX, [EBX].TControl.fBoundsRect.Top\r
        MOV      [EBX].TControl.fBoundsRect.Bottom, EDX\r
        MOV      [EBX].TControl.fCommandActions.aAutoSzY, 0\r
@@noHeightResize:\r
        POP      ECX\r
        POP      EAX\r
        CDQ\r
        MOV      DL, 4\r
        TEST     [EBX].TControl.fBitBtnOptions, 2 //1 shl bboNoBorder\r
        JNZ      @@noBorderResize\r
        JECXZ    @@noBorderWinc\r
        ADD      [EBX].TControl.fBoundsRect.Right, EDX\r
        CMP      [EBX].TControl.fCommandActions.aAutoSzX, 0\r
        JZ       @@noBorderWinc\r
        ADD      [EBX].TControl.fCommandActions.aAutoSzX, DX\r
@@noBorderWinc:\r
        TEST     EAX, EAX\r
        JLE      @@noBorderResize\r
        ADD      [EBX].TControl.fBoundsRect.Bottom, EDX\r
        CMP      [EBX].TControl.fCommandActions.aAutoSzY, 0\r
        JZ       @@noBorderResize\r
        ADD      [EBX].TControl.fCommandActions.aAutoSzY, DX\r
@@noBorderResize:\r
@@noGlyphWH:\r
        MOV      ECX, [EBX].TControl.fParent\r
        JECXZ    @@notAttach2Parent\r
        XCHG     EAX, ECX\r
        MOV      EDX, offset[WndProc_DrawItem]\r
        CALL     TControl.AttachProc\r
@@notAttach2Parent:\r
        MOV      EAX, EBX\r
        MOV      EDX, offset[WndProcBitBtn]\r
        CALL     TControl.AttachProc\r
        MOV      EAX, EBX\r
        POP      EDX\r
        CALL     TControl.SetCaption\r
        MOV      [EBX].TControl.fTextAlign, taCenter\r
        {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}\r
        MOV      EAX, EBX\r
        MOV      EDX, offset[WndProcBtnReturnClick]\r
        CALL     TControl.AttachProc\r
        {$ENDIF}\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewBitBtn( AParent: PControl; const Caption: String;\r
         Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap;\r
         GlyphCount: Integer ): PControl;\r
var\r
    B: TBitmapInfo;\r
    W, H: Integer;\r
begin\r
  Result := _NewControl( AParent, 'BUTTON', WS_VISIBLE or WS_CHILD or\r
            WS_TABSTOP or BS_OWNERDRAW, False, @ButtonActions );\r
  Result.fIgnoreDefault := TRUE;\r
  Result.fIsButton := TRUE;\r
  Result.fCommandActions.aAutoSzX := 8;\r
  Result.fCommandActions.aAutoSzY := 8;\r
  //Result.fExStyle := Result.fExStyle and not WS_EX_CONTROLPARENT;\r
  Result.fBitBtnOptions := Options;\r
  Result.fGlyphLayout := Layout;\r
  Result.fGlyphBitmap := GlyphBitmap;\r
  with Result.fBoundsRect do\r
  begin\r
    Bottom := Top + 22;\r
    W := 0; H := 0;\r
    if GlyphBitmap <> 0 then\r
    begin\r
      if bboImageList in Options then\r
        ImageList_GetIconSize( GlyphBitmap, W, H )\r
      else\r
        begin\r
          if GetObject( GlyphBitmap, Sizeof(B), @B ) > 0 then\r
          begin\r
            W := B.bmiHeader.biWidth;\r
            H := B.bmiHeader.biHeight;\r
            if GlyphCount = 0 then\r
              GlyphCount := W div H;\r
            if GlyphCount > 1 then\r
              W := W div GlyphCount;\r
          end;\r
        end;\r
      if W > 0 then\r
      begin\r
        if (Caption = '') or (Layout = glyphOver) then\r
        begin\r
          Right := Left + W;\r
          Result.fCommandActions.aAutoSzX := 0;\r
        end\r
          else\r
        if Layout in [ glyphLeft, glyphRight ] then\r
        begin\r
          Right := Right + W;\r
          Inc( Result.fCommandActions.aAutoSzX, W );\r
        end;\r
      end;\r
      if H > 0 then\r
      begin\r
        if Layout in [ glyphTop, glyphBottom ] then\r
        begin\r
          Bottom := Bottom + H;\r
          Inc( Result.fCommandActions.aAutoSzY, H );\r
        end\r
          else\r
        begin\r
          Bottom := Top + H;\r
          Result.fCommandActions.aAutoSzY := 0;\r
        end;\r
      end;\r
      if not ( bboNoBorder in Options ) then\r
      begin\r
        if W > 0 then\r
        begin\r
          Inc( Right, 4 );\r
          if Result.fCommandActions.aAutoSzX > 0 then\r
            Inc( Result.fCommandActions.aAutoSzX, 4 );\r
        end;\r
        if H > 0 then\r
        begin\r
          Inc( Bottom, 4 );\r
          if Result.fCommandActions.aAutoSzY > 0 then\r
            Inc( Result.fCommandActions.aAutoSzY, 4 );\r
        end;\r
      end;\r
    end;\r
    Result.fGlyphWidth := W;\r
    Result.fGlyphHeight := H;\r
  end;\r
  Result.fGlyphCount := GlyphCount;\r
  if AParent <> nil then\r
    AParent.AttachProc( WndProc_DrawItem );\r
  Result.AttachProc( WndProcBitBtn );\r
  //Result.AttachProc( WndProcDoEraseBkgnd );\r
  Result.fTextAlign := taCenter;\r
  Result.Caption := Caption;\r
  {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}\r
  Result.AttachProc( WndProcBtnReturnClick );\r
  {$ENDIF}\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewBitBtn]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Check box ========================//\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewCheckbox]\r
function NewCheckbox( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  new( Result, CreateCheckbox( AParent, Caption ) );\r
end;\r
//[END NewCheckbox]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewCheckbox]\r
{$IFDEF ASM_VERSION}\r
function NewCheckbox( AParent: PControl; const Caption: String ): PControl;\r
asm\r
        CALL     NewButton\r
        MOV      EDX, [EAX].TControl.fBoundsRect.Left\r
        ADD      EDX, 72\r
        MOV      [EAX].TControl.fBoundsRect.Right, EDX\r
        MOV      [EAX].TControl.fStyle, WS_VISIBLE or WS_CHILD or BS_AUTOCHECKBOX or WS_TABSTOP\r
        MOV      [EAX].TControl.fCommandActions.aAutoSzX, 24\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewCheckbox( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  Result := NewButton( AParent, Caption );\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 72;\r
  end;\r
  Result.fStyle := WS_VISIBLE or WS_CHILD or\r
            BS_AUTOCHECKBOX or WS_TABSTOP;\r
  Result.fCommandActions.aAutoSzX := 24;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewCheckbox]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//[function NewCheckBox3State]\r
function NewCheckBox3State( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  Result := NewCheckbox( AParent, Caption );\r
  Result.fStyle := Result.fStyle and not BS_AUTOCHECKBOX or BS_AUTO3STATE;\r
end;\r
\r
//===================== Radiobox ========================//\r
\r
//[FUNCTION ClickRadio]\r
{$IFDEF ASM_VERSION}\r
procedure ClickRadio( Sender:PObj );\r
asm\r
        MOV      ECX, [EAX].TControl.fParent\r
        JECXZ    @@exit\r
        PUSH     [EAX].TControl.fMenu\r
        PUSH     [ECX].TControl.fRadioLast\r
        PUSH     [ECX].TControl.fRadio1st\r
        PUSH     [ECX].TControl.fHandle\r
        CALL     CheckRadioButton\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure ClickRadio( Sender:PObj );\r
var Self_:PControl;\r
begin\r
  Self_ := PControl( Sender );\r
  if Self_.FParent <> nil then\r
    CheckRadioButton( Self_.fParent.fHandle,\r
                      Self_.fParent.fRadio1st,\r
                      Self_.fParent.fRadioLast,\r
                      Self_.fMenu );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END ClickRadio]\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewRadiobox]\r
function NewRadiobox( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  new( Result, CreateRadiobox( AParent, Caption ) );\r
end;\r
//[END NewRadiobox]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewRadiobox]\r
{$IFDEF ASM_VERSION}\r
function NewRadiobox( AParent: PControl; const Caption: String ): PControl;\r
const\r
  RadioboxStyles = WS_VISIBLE or WS_CHILD or BS_RADIOBUTTON or\r
                   WS_TABSTOP or WS_GROUP or BS_NOTIFY;\r
asm\r
        PUSH     EBX\r
        PUSH     EAX\r
        CALL     NewCheckbox\r
        XCHG     EBX, EAX\r
        MOV      [EBX].TControl.fStyle, RadioboxStyles\r
        MOV      [EBX].TControl.fControlClick, offset[ClickRadio]\r
        POP      ECX\r
        JECXZ    @@exit\r
        MOV      EDX, [EBX].TControl.fMenu\r
        MOV      [ECX].TControl.fRadioLast, EDX\r
        MOV      EAX, [ECX].TControl.fRadio1st\r
        TEST     EAX, EAX\r
        JNZ      @@exit\r
        MOV      [ECX].TControl.fRadio1st, EDX\r
        MOV      EAX, EBX\r
        CALL     TControl.SetRadioChecked\r
@@exit: XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewRadiobox( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  Result := NewCheckbox( AParent, Caption );\r
  Result.fStyle := WS_VISIBLE or WS_CHILD or\r
            BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP or BS_NOTIFY;\r
  Result.fControlClick := ClickRadio;\r
  if AParent <> nil then\r
  begin\r
    AParent.fRadioLast := Result.fMenu;\r
    if AParent.fRadio1st = 0 then\r
    begin\r
       AParent.fRadio1st := Result.fMenu;\r
       Result.SetRadioChecked;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewRadiobox]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Label ========================//\r
\r
{$IFNDEF USE_CONSTRUCTORS}\r
{$IFDEF ASM_VERSION}\r
const StaticClass: array[0..6]of Char=('S','T','A','T','I','C',#0);\r
{$ENDIF ASM_VERSION}\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewLabel]\r
function NewLabel( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  new( Result, CreateLabel( AParent, Caption ) );\r
end;\r
//[END NewLabel]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewLabel]\r
{$IFDEF ASM_VERSION}\r
function NewLabel( AParent: PControl; const Caption: String ): PControl;\r
asm\r
        PUSH     EDX\r
\r
        PUSH     0\r
        PUSH     offset[LabelActions]\r
        MOV      ECX, WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY\r
        MOV      EDX, offset[StaticClass]\r
        CALL     _NewControl\r
        INC      [EAX].TControl.fIsStaticControl\r
        INC      [EAX].TControl.fSizeRedraw\r
        MOV      EDX, [EAX].TControl.fBoundsRect.Top\r
        ADD      EDX, 22\r
        MOV      [EAX].TControl.fBoundsRect.Bottom, EDX\r
        POP      EDX\r
        PUSH     EAX\r
        CALL     TControl.SetCaption\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewLabel( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or\r
                         SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,\r
                         False, @LabelActions );\r
  Result.fIsStaticControl := True;\r
  Result.fSizeRedraw := True;\r
  with Result.fBoundsRect do\r
  begin\r
    //Right := Left + 64;\r
    Bottom := Top + 22;\r
  end;\r
  Result.Caption := Caption;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewLabel]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== word wrap Label ========================//\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewWordWrapLabel]\r
function NewWordWrapLabel( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  new( Result, CreateWordWrapLabel( AParent, Caption ) );\r
end;\r
//[END NewWordWrapLabel]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewWordWrapLabel]\r
{$IFDEF ASM_VERSION}\r
function NewWordWrapLabel( AParent: PControl; const Caption: String ): PControl;\r
asm\r
        CALL     NewLabel\r
        MOV      EDX, [EAX].TControl.fBoundsRect.Top\r
        ADD      EDX, 44\r
        MOV      [EAX].TControl.fBoundsRect.Bottom, EDX\r
        INC      [EAX].TControl.fWordWrap\r
        AND      byte ptr [EAX].TControl.fStyle, not SS_LEFTNOWORDWRAP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewWordWrapLabel( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  Result := NewLabel( AParent, Caption );\r
  Result.fWordWrap := TRUE;\r
  with Result.fBoundsRect do\r
  begin\r
    Bottom := Top + 44;\r
  end;\r
  Result.fStyle := Result.fStyle and not SS_LEFTNOWORDWRAP;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewWordWrapLabel]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Label Effect ========================//\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
function NewLabelEffect( AParent: PControl; const Caption: String; ShadowDeep: Integer ): PControl;\r
begin\r
  new( Result, CreateLabelEffect( AParent, Caption, ShadowDeep ) );\r
end;\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewLabelEffect]\r
{$IFDEF ASM_VERSION}\r
function NewLabelEffect( AParent: PControl; const Caption: String; ShadowDeep: Integer ): PControl;\r
asm\r
        PUSH     EBX\r
\r
        PUSH     ECX\r
        PUSH     EDX\r
        XOR      EDX, EDX\r
        CALL     NewLabel\r
        MOV      EBX, EAX\r
        DEC      [EBX].TControl.fIsStaticControl\r
        MOV      EDX, offset[WndProcLabelEffect]\r
        CALL     TControl.AttachProc\r
\r
        //MOV      EAX, EBX\r
        //CALL     TControl.GetWindowHandle\r
\r
        POP      EDX\r
        MOV      EAX, EBX\r
        CALL     TControl.SetCaption\r
\r
        MOV      EDX, offset[WndProcDoEraseBkgnd]\r
        MOV      EAX,EBX\r
        CALL     TControl.AttachProc\r
        MOV      [EBX].TControl.fTextAlign, taCenter\r
        MOV      [EBX].TControl.fTextColor, clWindowText\r
        POP      [EBX].TControl.fShadowDeep\r
        INC      [EBX].TControl.fIgnoreWndCaption\r
        ADD      [EBX].TControl.fBoundsRect.Bottom, 40 - 22\r
        MOV      [EBX].TControl.fColor2, clNone\r
\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewLabelEffect( AParent: PControl; const Caption: String; ShadowDeep: Integer ): PControl;\r
begin\r
  Result := NewLabel( AParent, '' );\r
  Result.fIsStaticControl := False;\r
  Result.AttachProc( WndProcLabelEffect );\r
  //Result.GetWindowHandle;\r
  Result.Caption := Caption;\r
  Result.AttachProc( WndProcDoEraseBkgnd );\r
  Result.fTextAlign := taCenter;\r
  Result.fTextColor := clWindowText;\r
  Result.fShadowDeep := ShadowDeep;\r
  Result.fIgnoreWndCaption := True;\r
  with Result.fBoundsRect do\r
  begin\r
    Bottom := Top + 40;\r
  end;\r
  Result.fColor2 := clNone;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewLabelEffect]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Paint box ========================//\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewPaintbox]\r
function NewPaintbox( AParent: PControl ): PControl;\r
begin\r
  new( Result, CreatePaintBox( AParent ) );\r
end;\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewPaintbox]\r
{$IFDEF ASM_VERSION}\r
function NewPaintbox( AParent: PControl ): PControl;\r
asm\r
        XOR      EDX, EDX\r
        CALL     NewLabel\r
        //PUSH     EAX\r
        //MOV      EDX, offset[WndProcPaintBox]\r
        //CALL     TControl.AttachProc\r
        //POP      EAX\r
        ADD      [EAX].TControl.fBoundsRect.Right, 40-64\r
        ADD      [EAX].TControl.fBoundsRect.Bottom, 40-22\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewPaintbox( AParent: PControl ): PControl;\r
begin\r
  Result := NewLabel( AParent, '' );\r
  //Result.AttachProc( WndProcPaintBox );\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 40;\r
    Bottom := Top + 40;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewPaintbox]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
{$IFDEF _D2}\r
//[API SetBrushOrgEx]\r
function SetBrushOrgEx(DC: HDC; X, Y: Integer; PrevPt: PPoint): BOOL; stdcall;\r
external gdi32 name 'SetBrushOrgEx';\r
{$ENDIF}\r
\r
//[FUNCTION WndProcDoEraseBkgnd]\r
{$IFDEF ASM_VERSION}\r
function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm     //        //\r
        CMP       word ptr [EDX].TMsg.message, WM_ERASEBKGND\r
        JNE       @@ret_false\r
        MOV       byte ptr [ECX], 1\r
        PUSH      EBX\r
        PUSH      EDI\r
        MOV       EBX, EAX\r
        MOV       EDI, [EDX].TMsg.wParam\r
\r
        CALL      TControl.CreateChildWindows\r
        CMP       [EBX].TControl.fTransparent, 0\r
        JNE       @@exit\r
\r
        PUSH      OPAQUE\r
        PUSH      EDI\r
        CALL      SetBkMode\r
        MOV       EAX, [EBX].TControl.fColor\r
        CALL      Color2RGB\r
        PUSH      EAX\r
        PUSH      EDI\r
        CALL      SetBkColor\r
        XOR       EAX, EAX\r
        PUSH      EAX\r
        PUSH      EAX\r
        PUSH      EAX\r
        PUSH      EDI\r
        CALL      SetBrushOrgEx\r
        SUB       ESP, 16\r
        PUSH      ESP\r
        PUSH      [EBX].TControl.fHandle\r
        CALL      GetClientRect\r
        MOV       EAX, EBX\r
        CALL      dword ptr[Global_GetCtlBrushHandle]\r
        MOV       EDX, ESP\r
        PUSH      EAX\r
        PUSH      EDX\r
        PUSH      EDI\r
        CALL      Windows.FillRect\r
        ADD       ESP, 16\r
@@exit: POP       EDI\r
        POP       EBX\r
@@ret_false:\r
        XOR       EAX, EAX\r
end;\r
{$ELSE ASM_VERSION PAS_VERSION}\r
function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var DC: HDC;\r
    R: TRect;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_ERASEBKGND then\r
  begin\r
    Self_.CreateChildWindows;\r
    if Self_.Transparent then Exit;\r
    DC := Msg.wParam;\r
    SetBkMode( DC, OPAQUE );\r
    SetBkColor( DC, Color2RGB( Self_.fColor ) );\r
    SetBrushOrgEx( DC, 0, 0, nil );\r
    GetClientRect( Self_.fHandle, R );\r
    Windows.FillRect( DC, R, Global_GetCtlBrushHandle( Self_ ) );\r
    Rslt := 1;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcDoEraseBkgnd]\r
\r
//[function WndProcImageShow]\r
function WndProcImageShow( Sender: PControl; var Msg: TMsg;\r
         var Rslt: Integer ): Boolean;\r
var PaintStruct: TPaintStruct;\r
    IL: PImageList;\r
    OldPaintDC: HDC;\r
begin\r
  Result := FALSE;\r
  if (Msg.message = WM_PAINT) or (Msg.message = WM_PRINT) then\r
  begin\r
    OldPaintDC := Sender.fPaintDC;\r
    Sender.fPaintDC := Msg.wParam;\r
    if Sender.fPaintDC = 0 then\r
      Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct );\r
    //fOnPaint( Self_, fPaintDC );\r
    IL := Sender.ImageListNormal;\r
    if IL <> nil then\r
    begin\r
      IL.Draw( Sender.fCurIndex, Sender.fPaintDC, 0, 0 );\r
      Result := TRUE;\r
    end;\r
    if Msg.wParam = 0 then\r
      EndPaint( Sender.fHandle, PaintStruct );\r
    Sender.fPaintDC := OldPaintDC;\r
    Rslt := 0;\r
    //Result := True;\r
    Exit;\r
  end;\r
end;\r
\r
//[function NewImageShow]\r
function NewImageShow( AParent: PControl; AImgList: PImageList;\r
         ImgIdx: Integer ): PControl;\r
var W, H: Integer;\r
begin\r
  Result := NewLabel( AParent, '' );\r
  Result.ImageListNormal := AImgList;\r
  Result.AttachProc( WndProcImageShow );\r
  Result.AttachProc( WndProcDoEraseBkgnd );\r
  W := 32; H := 32;\r
  if AImgList <> nil then\r
  begin\r
    W := AImgList.ImgWidth;\r
    H := AImgList.ImgHeight;\r
  end;\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + W;\r
    Bottom := Top + H;\r
  end;\r
end;\r
//[END NewImageShow]\r
\r
//===================== Scrollbar ========================//\r
const\r
  KSB_INITIALIZE = WM_USER + 10000;\r
  KSB_KEY = $3232;\r
\r
//[function WndProcScrollBar]\r
function WndProcScrollBar( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  Result := False;\r
  case Msg.message of\r
    WM_CREATE:\r
      PostMessage(Sender.Handle, KSB_INITIALIZE, KSB_KEY, KSB_KEY);\r
\r
    KSB_INITIALIZE:\r
      if (Msg.wParam = Msg.lParam) and (Msg.wParam = KSB_KEY) then\r
      begin\r
        Sender.SBPageSize := Sender.fSBPageSize;\r
        Sender.SBMinMax := Sender.fSBMinMax;\r
        Sender.SBPosition := Sender.fSBPosition;\r
      end;\r
  end;\r
end;\r
//[END WndProcScrollBar]\r
\r
//[function WndProcScrollBarParent]\r
function WndProcScrollBarParent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var\r
  Bar: PControl;\r
  SI: TScrollInfo;\r
  NewPos: Integer;\r
  AllowChange: Boolean;\r
  Cmd: Word;\r
\r
begin\r
  Result := False;\r
  case Msg.message of\r
    WM_HSCROLL, WM_VSCROLL:\r
    if (Msg.lParam <> 0) then begin\r
      Bar := Pointer(GetProp(Msg.lParam, ID_SELF));\r
      if (Bar <> nil) then begin\r
        FillChar(SI, SizeOf(SI), 0);\r
        SI.cbSize := SizeOf(SI);\r
        SI.fMask := SIF_RANGE or SIF_POS or SIF_TRACKPOS or SIF_PAGE;\r
        Bar.SBGetScrollInfo(SI);\r
\r
        Cmd := Msg.wParam and $0000FFFF;\r
        case Cmd of\r
          SB_BOTTOM: NewPos := SI.nMax;\r
          SB_TOP: NewPos := SI.nMin;\r
          SB_LINEDOWN: NewPos := SI.nPos + 1;\r
          SB_LINEUP: NewPos := SI.nPos - 1;\r
          SB_PAGEDOWN: NewPos := SI.nPos + Integer(SI.nPage);\r
          SB_PAGEUP: NewPos := SI.nPos - Integer(SI.nPage);\r
          SB_THUMBTRACK: NewPos := SI.nTrackPos;\r
          else\r
            Exit;\r
        end;\r
\r
        if (NewPos > SI.nMax - Integer(SI.nPage) + 1) then\r
          NewPos := SI.nMax - Integer(SI.nPage) + 1;\r
        if (NewPos < SI.nMin) then\r
          NewPos := SI.nMin;\r
\r
        AllowChange := True;\r
        if Assigned(Bar.OnSBBeforeScroll) then\r
          Bar.OnSBBeforeScroll(Bar, SI.nPos, NewPos, Cmd, AllowChange);\r
        if AllowChange then\r
          SI.nPos := NewPos\r
        else\r
          SI.nTrackPos := SI.nPos;\r
        Bar.fSBPosition := SI.nPos;\r
        Bar.fSBPosition := Bar.SBSetScrollInfo(SI);\r
        if AllowChange and Assigned(Bar.OnSBScroll) then\r
            Bar.OnSBScroll(Bar, Cmd);\r
      end;\r
    end;\r
  end;\r
end;\r
//[END WndProcScrollBarParent]\r
\r
//[function NewScrollBar]\r
function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl;\r
const SBS_Directions: array[ TScrollerBar ] of DWORD = ( SBS_HORZ or SBS_BOTTOMALIGN,\r
      SBS_VERT or SBS_RIGHTALIGN );\r
begin\r
  Result := _NewCommonControl(\r
    AParent,\r
    'SCROLLBAR',\r
    WS_VISIBLE or WS_CHILD or SBS_Directions[ BarSide ],\r
    False,\r
    nil\r
  );\r
  Result.DetachProc(WndProcCtrl);\r
  Result.fLookTabKeys := [tkTab];\r
  Result.AttachProc(WndProcScrollBar);\r
  AParent.AttachProc(WndProcScrollBarParent);\r
end;\r
//[END NewScrollBar]\r
\r
//===================== Scrollbox ========================//\r
//[function WndProcScrollBox]\r
function WndProcScrollBox( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Bar: DWORD;\r
    SI: TScrollInfo;\r
    OldNotifyProc: pointer;\r
begin\r
\r
  case Msg.message of\r
  WM_HSCROLL: Bar := SB_HORZ;\r
  WM_VSCROLL: Bar := SB_VERT;\r
  WM_SIZE: begin\r
              if Assigned( Sender.fNotifyChild ) then\r
                Sender.fNotifyChild( Sender, nil );\r
              Result := FALSE;\r
              Exit;\r
           end;\r
  else begin\r
         Result := FALSE;\r
         Exit;\r
       end;\r
  end;\r
\r
  SI.cbSize := Sizeof( SI );\r
  SI.fMask := SIF_RANGE or SIF_POS or SIF_PAGE or\r
              {$IFDEF F_P}$10{$ELSE}SIF_TRACKPOS{$ENDIF};\r
  {$IFDEF _D2}\r
  GetScrollInfo( Sender.fHandle, Bar, SI );\r
  {$ELSE}\r
  GetScrollInfo( Sender.fHandle, Bar, SI );\r
  {$ENDIF}\r
  SI.fMask := SIF_POS;\r
  case LoWord( Msg.wParam ) of\r
  SB_BOTTOM:    SI.nPos := SI.nMax;\r
  SB_TOP:       SI.nPos := SI.nMin;\r
  SB_LINEDOWN:  Inc( SI.nPos, Sender.FScrollLineDist[ Bar ] );\r
  SB_LINEUP:    Dec( SI.nPos, Sender.FScrollLineDist[ Bar ] );\r
  SB_PAGEDOWN:  Inc( SI.nPos, Max( SI.nPage, 1 ) );\r
  SB_PAGEUP:    Dec( SI.nPos, Max( SI.nPage, 1 ) );\r
  SB_THUMBTRACK:SI.nPos := SI.nTrackPos;\r
  end;\r
  if SI.nPos > SI.nMax { - Integer( SI.nPage ) } then\r
    SI.nPos := SI.nMax { - Integer( SI.nPage ) };\r
  if SI.nPos < SI.nMin then\r
    SI.nPos := SI.nMin;\r
  SetScrollInfo( Sender.fHandle, Bar, SI, TRUE );\r
\r
  if Assigned( Sender.fScrollChildren ) then\r
  begin\r
    OldNotifyProc := @ Sender.fNotifyChild;\r
    Sender.fNotifyChild := nil;\r
    Sender.fScrollChildren( Sender );\r
    Sender.fNotifyChild := OldNotifyProc;\r
  end;\r
\r
  SetScrollInfo( Sender.fHandle, Bar, SI, TRUE );\r
  Result := FALSE;\r
end;\r
//[END WndProcScrollBox]\r
\r
//[function NewScrollBox]\r
function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle;\r
         Bars: TScrollerBars ): PControl;\r
const Edgestyles: array[ TEdgeStyle ] of DWORD = ( WS_DLGFRAME, SS_SUNKEN, 0 );\r
var SBFlag: Integer;\r
begin\r
  SBFlag := EdgeStyles[ EdgeStyle ];\r
  if sbHorizontal in Bars then\r
    SBFlag := SBFlag or WS_HSCROLL;\r
  if sbVertical in Bars then\r
    SBFlag := SBFlag or WS_VSCROLL;\r
\r
  Result := _NewControl( AParent, 'ScrollBox', WS_VISIBLE or WS_CHILD or\r
         SBFlag, EdgeStyle = esLowered, nil );\r
  Result.AttachProc( WndProcForm ); //!!!\r
  Result.AttachProc( WndProcScrollBox );\r
  Result.AttachProc( WndProcDoEraseBkgnd );\r
  Result.fIsControl := TRUE;\r
end;\r
//[END NewScrollBox]\r
\r
//[function WndProcNotifyParentAboutResize]\r
function WndProcNotifyParentAboutResize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var P: PControl;\r
begin\r
  if (Msg.message = WM_SIZE) or (Msg.message = WM_MOVE) or (Msg.message = CM_SHOW) then\r
  begin\r
    P := Sender.Parent;\r
    if P <> nil then\r
      if Assigned( P.fNotifyChild ) then\r
        P.fNotifyChild( P, nil );\r
  end\r
    else\r
  if Msg.message = WM_SHOWWINDOW then\r
    PostMessage( Sender.fHandle, CM_SHOW, 0, 0 );\r
  Result := FALSE;\r
end;\r
\r
//[procedure CalcMinMaxChildren]\r
procedure CalcMinMaxChildren( Self_: PControl; var SzR: TRect );\r
var I: Integer;\r
    C: PControl;\r
    R: TRect;\r
begin\r
  Szr := MakeRect( 0, 0, 0, 0 );\r
  for I := 0 to Self_.fChildren.fCount - 1 do\r
  begin\r
    C := Self_.fChildren.fItems[ I ];\r
    if C.ToBeVisible then\r
    begin\r
      R := C.BoundsRect;\r
      if (SzR.Left = SzR.Right) or (R.Left < SzR.Left) or (R.Right > SzR.Right) then\r
      begin\r
        if SzR.Left = SzR.Right then\r
        begin\r
          SzR.Left := R.Left;\r
          SzR.Right := R.Right;\r
        end\r
          else\r
        begin\r
          if R.Left < SzR.Left then SzR.Left := R.Left;\r
          if R.Right > SzR.Right then SzR.Right := R.Right;\r
        end;\r
      end;\r
      if (SzR.Top = SzR.Bottom) or (R.Top < SzR.Top) or (R.Bottom > SzR.Bottom) then\r
      begin\r
        if SzR.Top = SzR.Bottom then\r
        begin\r
          SzR.Top := R.Top;\r
          SzR.Bottom := R.Bottom;\r
        end\r
          else\r
        begin\r
          if R.Top < SzR.Top then SzR.Top := R.Top;\r
          if R.Bottom > SzR.Bottom then SzR.Bottom := R.Bottom;\r
        end;\r
      end;\r
    end;\r
  end;\r
  Dec( SzR.Left, Self_.Border );\r
  Inc( SzR.Right, Self_.Border - 1 );\r
  Dec( SzR.Top, Self_.Border );\r
  Inc( SzR.Bottom, Self_.Border - 1 );\r
end;\r
\r
//[procedure NotifyScrollBox]\r
procedure NotifyScrollBox( Self_, Child: PControl );\r
var SI: TScrollInfo;\r
\r
    procedure GetSetScrollInfo( SBar: DWORD; WH, R_RightBottom, SzR_LeftTop, SzR_RightBottom: Integer );\r
    var OldPos: Double;\r
    begin\r
      OldPos := 0;\r
      if not GetScrollInfo( Self_.fHandle, SBar, SI ) then\r
      begin\r
        SI.nMin := 0;\r
        SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );\r
      end\r
        else\r
      begin\r
        if SI.nMax > SI.nMin then\r
        begin\r
          OldPos := (SI.nPos - SI.nMin) / (SI.nMax - SI.nMin);\r
          SI.nMin := 0;\r
          SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );\r
          if SzR_LeftTop < 0 then\r
            SI.nMax := Max( R_RightBottom - SzR_LeftTop - 1, WH - 1 );\r
        end\r
          else\r
        begin\r
          SI.nMin := 0;\r
          SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );\r
        end;\r
      end;\r
      SI.nPos := SI.nMin + Round( (SI.nMax - SI.nMin) * OldPos );\r
      SI.nPage := R_RightBottom;\r
      SetScrollInfo( Self_.fHandle, SBar, SI, TRUE );\r
    end;\r
\r
var W, H: Integer;\r
    SzR: TRect;\r
    R: TRect;\r
begin\r
  if Assigned( Child ) then\r
  begin\r
    Child.AttachProc( WndProcNotifyParentAboutResize );\r
    Exit;\r
  end;\r
  CalcMinMaxChildren( Self_, SzR );\r
  W := SzR.Right - SzR.Left;\r
  H := SzR.Bottom - SzR.Top;\r
\r
  R := Self_.ClientRect;\r
  if (R.Right = 0) or (R.Bottom = 0) then Exit; // for case when form is minimized\r
  SI.cbSize := sizeof( SI );\r
  SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS;\r
\r
  GetSetScrollInfo( SB_HORZ, W, R.Right, SzR.Left, SzR.Right );\r
  GetSetScrollInfo( SB_VERT, H, R.Bottom, SzR.Top, SzR.Bottom );\r
\r
end;\r
\r
//[procedure ScrollChildren]\r
procedure ScrollChildren( _Self_: PControl );\r
var SzR, R: TRect;\r
    I, Xpos, Ypos: Integer;\r
    OldNotifyProc: Pointer;\r
    C: PControl;\r
    DeltaX, DeltaY: Integer;\r
\r
begin\r
\r
  CalcMinMaxChildren( _Self_, SzR );\r
  Xpos := GetScrollPos( _Self_.fHandle, SB_HORZ );\r
  Ypos := GetScrollPos( _Self_.fHandle, SB_VERT );\r
\r
  DeltaX := -Xpos - SzR.Left;\r
  DeltaY := -Ypos - SzR.Top;\r
\r
  if (DeltaX <> 0) or (DeltaY <> 0) then\r
  begin\r
\r
    OldNotifyProc := @ _Self_.fNotifyChild;\r
    _Self_.fNotifyChild := nil;\r
\r
    for I := 0 to _Self_.fChildren.fCount - 1 do\r
    begin\r
      C := _Self_.fChildren.fItems[ I ];\r
      R := C.BoundsRect;\r
      OffsetRect( R, DeltaX, DeltaY  );\r
      C.BoundsRect := R;\r
    end;\r
\r
    _Self_.fNotifyChild := OldNotifyProc;\r
    CalcMinMaxChildren( _Self_, R );\r
    if //(SzR.Left <> R.Left) or (SzR.Top <> R.Top) or\r
       //(Szr.Right <> R.Right) or (SzR.Bottom <> R.Bottom)\r
       ((SzR.Right - SzR.Left) <> (R.Right - R.Left)) or\r
       ((SzR.Bottom - SzR.Top) <> (R.Bottom - R.Top))\r
       then\r
    if Assigned( _Self_.fNotifyChild ) then\r
      _Self_.fNotifyChild( _Self_, nil );\r
\r
  end;\r
\r
end;\r
\r
//[function NewScrollBoxEx]\r
function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;\r
begin\r
  Result := NewScrollBox( AParent, EdgeStyle, [ ] );\r
  Result.fNotifyChild := NotifyScrollBox;\r
  Result.fScrollChildren := ScrollChildren;\r
  Result.FScrollLineDist[ 0 ] := 16;\r
  Result.FScrollLineDist[ 1 ] := 16;\r
end;\r
\r
//[function WndProcOnScroll]\r
function WndProcOnScroll( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Bar: TScrollerBar;\r
begin\r
  Bar := sbHorizontal; //0\r
  if Msg.message = WM_VSCROLL then\r
    Bar := sbVertical\r
  else\r
  if Msg.message <> WM_HSCROLL then\r
  begin\r
    Result := FALSE;\r
    Exit;\r
  end;\r
\r
  if Assigned( Sender.OnScroll ) then\r
    Sender.OnScroll( Sender, Bar, LoWord( Msg.wParam ), HiWord( Msg.wParam ) );\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.SetOnScroll]\r
procedure TControl.SetOnScroll(const Value: TOnScroll);\r
begin\r
  FOnScroll := Value;\r
  AttachProc( @ WndProcOnScroll );\r
end;\r
\r
//===================== Groupbox ========================//\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewGroupbox]\r
function NewGroupbox( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  new( Result, CreateGroupbox( AParent, Caption ) );\r
end;\r
//[END NewGroupbox]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewGroupbox]\r
{$IFDEF ASM_VERSION}\r
function NewGroupbox( AParent: PControl; const Caption: String ): PControl;\r
asm\r
        PUSH     EDX\r
        PUSH     0\r
        PUSH     offset[ButtonActions]\r
        MOV      EDX, offset[ButtonClass]\r
        MOV      ECX, WS_VISIBLE or WS_CHILD or BS_GROUPBOX or WS_TABSTOP or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or WS_GROUP\r
        CALL     _NewControl\r
        OR       [EAX].TControl.fExStyle, WS_EX_CONTROLPARENT\r
        ADD      [EAX].TControl.fBoundsRect.Right, 100-64\r
        ADD      [EAX].TControl.fBoundsRect.Bottom, 100-22\r
        ADD      [EAX].TControl.fClientTop, 22\r
        XOR      EDX, EDX\r
        MOV      [EAX].TControl.fTabstop, DL\r
        MOV      DL, 2\r
        ADD      [EAX].TControl.fClientBottom, EDX\r
        ADD      [EAX].TControl.fClientLeft, EDX\r
        ADD      [EAX].TControl.fClientRight, EDX\r
        POP      EDX\r
        PUSH     EAX\r
        CALL     TControl.SetCaption\r
        POP      EAX\r
        PUSH     EAX\r
        MOV      EDX, offset[WndProcDoEraseBkgnd]\r
        CALL     TControl.AttachProc\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewGroupbox( AParent: PControl; const Caption: String ): PControl;\r
begin\r
  Result := _NewControl( AParent, 'BUTTON',\r
                   WS_CHILD or\r
                   WS_CLIPSIBLINGS or\r
                   WS_CLIPCHILDREN or\r
                   WS_TABSTOP or\r
                   WS_VISIBLE or\r
                   BS_NOTIFY or\r
                   BS_GROUPBOX\r
                   or WS_GROUP,\r
                   FALSE, @ ButtonActions );\r
  Result.fExStyle := Result.fExStyle or WS_EX_CONTROLPARENT;\r
  Result.Caption := Caption;\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 100;\r
    Bottom := Top + 100;\r
  end;\r
  Result.fClientTop := 22;\r
  Result.fClientBottom := 2;\r
  Result.fClientLeft := 2;\r
  Result.fClientRight := 2;\r
  Result.fTabstop := False;\r
  Result.AttachProc( WndProcDoEraseBkgnd );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewGroupbox]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Panel ========================//\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewPanel]\r
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;\r
begin\r
  new( Result, CreatePanel( AParent, EdgeStyle ) );\r
end;\r
//[END NewPanel]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewPanel]\r
{$IFDEF ASM_VERSION}\r
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;\r
asm\r
        PUSH     EDX\r
        MOV      EDX, offset[StaticClass]\r
        MOV      ECX, WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY\r
        PUSH     0\r
        PUSH     offset[LabelActions]\r
        CALL     _NewControl\r
        ADD      [EAX].TControl.fBoundsRect.Right, 100-64\r
        ADD      [EAX].TControl.fBoundsRect.Bottom, 100-64\r
        OR       byte ptr [EAX].TControl.fExStyle+2, 1\r
        POP      ECX\r
        CMP      CL, 1\r
        JG       @@exit\r
        JE       @@sunken\r
        OR       byte ptr [EAX].TControl.fStyle+2, $40\r
        RET\r
@@sunken:\r
        OR       byte ptr [EAX].TControl.fStyle+1, $10\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;\r
const Edgestyles: array[ TEdgeStyle ] of DWORD = ( WS_DLGFRAME, SS_SUNKEN, 0 );\r
begin\r
  Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or SS_NOTIFY or\r
                         SS_LEFTNOWORDWRAP or SS_NOPREFIX, False, @LabelActions );\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 100;\r
    Bottom := Top + 100;\r
  end;\r
  Result.Style := Result.Style or Edgestyles[ EdgeStyle ];\r
  Result.ExStyle := Result.fExStyle or WS_EX_CONTROLPARENT;\r
  Result.fVerticalAlign := vaTop;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewPanel]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Splitter ==============================//\r
\r
//{$DEFINE USE_ASM_DODRAG}\r
\r
       {$IFNDEF USE_ASM_DODRAG}\r
         {$DEFINE USE_PAS_DODRAG}\r
       {$ENDIF}\r
       {$IFNDEF ASM_VERSION}\r
         {$DEFINE USE_PAS_DODRAG}\r
       {$ENDIF}\r
{$IFDEF USE_PAS_DODRAG}\r
//[procedure DoDrag]\r
procedure DoDrag( Self_: PControl; Cancel: Boolean );\r
var NewSize1, NewSize2: Integer;\r
    MousePos: TPoint;\r
    R: TRect;\r
    Prev: PControl;\r
    I, M : Integer;\r
begin\r
  if Self_.fDragging then\r
  begin\r
    I := Self_.fParent.fChildren.IndexOf( Self_ );\r
    Prev := Self_;\r
    if I > 0 then\r
      Prev := Self_.FParent.fChildren.fItems[ I - 1 ];\r
    GetCursorPos( MousePos );\r
    if Cancel then\r
      MousePos := Self_.fSplitStartPos;\r
    M := 1;\r
    if Self_.FAlign in [ caRight, caBottom ] then\r
      M := -1;\r
    if Self_.FAlign in [ caTop, caBottom ] then\r
    begin\r
      NewSize1 := (MousePos.y - Self_.fSplitStartPos.y)* M\r
                + Self_.fSplitStartSize;\r
      NewSize2 := Self_.fParent.ClientHeight - NewSize1\r
                - Self_.fBoundsRect.Bottom + Self_.fBoundsRect.Top\r
                - Self_.fParent.fMargin * 4;\r
      if Self_.fSecondControl <> nil then\r
      begin\r
        NewSize2 := Self_.fSecondControl.fBoundsRect.Bottom\r
                  - Self_.fSecondControl.fBoundsRect.Top;\r
        if Self_.fSecondControl.FAlign = caClient then\r
          NewSize2 := Self_.fSplitStartPos2.y\r
                    - (MousePos.y - Self_.fSplitStartPos.y)* M\r
                    - Self_.fParent.fMargin * 4;\r
      end;\r
    end\r
       else\r
    begin\r
      NewSize1 := (MousePos.x - Self_.fSplitStartPos.x)* M\r
                + Self_.fSplitStartSize;\r
      NewSize2 := Self_.fParent.ClientWidth - NewSize1\r
                - Self_.fBoundsRect.Right + Self_.fBoundsRect.Left\r
                - Self_.fParent.fMargin * 4;\r
      if Self_.fSecondControl <> nil then\r
      begin\r
        NewSize2 := Self_.fSecondControl.fBoundsRect.Right\r
                  - Self_.fSecondControl.fBoundsRect.Left;\r
        if Self_.fSecondControl.FAlign = caClient then\r
          NewSize2 := Self_.fSplitStartPos2.x\r
                    - (MousePos.x - Self_.fSplitStartPos.x)* M\r
                    - Self_.fParent.Margin * 4;\r
      end;\r
    end;\r
    if {(Self_.fSplitMinSize1 <> 0) and} (NewSize1 < Self_.fSplitMinSize1) then\r
    begin\r
      Dec( NewSize2, Self_.fSplitMinSize1 - NewSize1 );\r
      NewSize1 := Self_.fSplitMinSize1;\r
    end;\r
    if {(Self_.fSplitMinSize2 <> 0) and} (NewSize2 < Self_.fSplitMinSize2) then\r
    begin\r
      Dec( NewSize1, Self_.fSplitMinSize2 - NewSize2 );\r
      NewSize2 := Self_.fSplitMinSize2;\r
    end;\r
    //if Self_.fSplitMinSize1 <> 0 then\r
      if NewSize1 < Self_.fSplitMinSize1 then Exit;\r
    //if Self_.fSplitMinSize2 <> 0 then\r
      if NewSize2 < Self_.fSplitMinSize2 then Exit;\r
    if assigned( Self_.fOnSplit ) then\r
      if not Self_.fOnSplit( Self_, NewSize1, NewSize2 ) then Exit;\r
    R := Prev.BoundsRect;\r
    case Self_.FAlign of\r
    caTop: R.Bottom := R.Top + NewSize1;\r
    caBottom: R.Top := R.Bottom - NewSize1;\r
    caRight: R.Left := R.Right - NewSize1;\r
    else R.Right := R.Left + NewSize1;\r
    end;\r
    Prev.BoundsRect := R;\r
    Global_Align( Self_.fParent );\r
  end;\r
end;\r
{$ENDIF}\r
\r
const\r
  chkLeft=2;\r
  chkTop=4;\r
  chkRight=8;\r
  chkBott=16;\r
\r
{$DEFINE USE!_ASM_DODRAG}\r
\r
//[FUNCTION WndProcSplitter]\r
{$IFDEF ASM_VERSION}\r
function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm\r
        CMP      word ptr [EDX].TMsg.message, WM_NCHITTEST\r
        JNE      @@noWM_NCHITTEST\r
        PUSH     ECX\r
        PUSH     [EDX].TMsg.lParam\r
        PUSH     [EDX].TMsg.wParam\r
        PUSH     [EDX].TMsg.message\r
        PUSH     [EAX].TControl.fHandle\r
        CALL     DefWindowProc\r
        TEST     EAX, EAX\r
        JLE      @@htReady\r
        XOR      EAX, EAX\r
        INC      EAX\r
@@htReady:\r
        POP      ECX\r
        MOV      [ECX], EAX\r
        MOV      AL, 1\r
        RET\r
\r
@@noWM_NCHITTEST:\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        CMP      word ptr [EDX].TMsg.message, WM_MOUSEMOVE\r
        JNE      @@noWM_MOUSEMOVE\r
\r
        PUSH     [EBX].TControl.fCursor\r
        CALL     Windows.SetCursor\r
\r
        XOR      EDX, EDX\r
\r
        {$IFDEF USE_ASM_DODRAG}\r
        CALL     @@DoDrag\r
        {$ELSE}\r
        MOV      EAX, EBX\r
        CALL     DoDrag\r
        {$ENDIF}\r
\r
        POP      EBX\r
        RET\r
\r
{$IFDEF USE_ASM_DODRAG}\r
@@DoDrag:\r
        PUSHAD\r
        MOVZX    EDI, DL // EDI = 1 if Cancel, 0 otherwise\r
        CMP      [EBX].TControl.fDragging, 0\r
        JZ       @@e_DoDrag\r
        MOV      EAX, [EBX].TControl.fParent\r
        MOV      EAX, [EAX].TControl.fChildren\r
        PUSH     EAX\r
        MOV      EDX, EBX\r
        CALL     TList.IndexOf\r
        POP      EDX // EDX = Self_.fParent.fChildren:PList\r
        MOV      EBP, EBX  // Prev := Self_;\r
        TEST     EAX, EAX\r
        JLE      @@noPrev\r
        MOV      EDX, [EDX].TList.fItems\r
        MOV      EBP, [EDX+EAX*4-4] // Prev = Self_.fParent.fChildren.fItems[I-1]\r
        PUSH     EBP  // push Prev\r
@@noPrev:\r
        PUSH     EDX\r
        PUSH     EDX\r
        PUSH     ESP\r
        CALL     GetCursorPos\r
        DEC      EDI\r
        JNZ      @@noCancel\r
        POP      EDX\r
        POP      EDX\r
        PUSH     [EBX].TControl.fSplitStartPos.y\r
        PUSH     [EBX].TControl.fSplitStartPos.x\r
@@noCancel:\r
        OR       EDI, -1\r
        MOV      CL, [EBX].TControl.fAlign\r
        MOV      AL, 1\r
        SHL      EAX, CL\r
        {$IFDEF PARANOIA}\r
        DB $A8, chkRight or chkBott\r
        {$ELSE}\r
        TEST AL, chkRight or chkBott //fAlign in [ caRight, caBottom ] ?\r
        {$ENDIF}\r
        JNZ      @@mReady\r
        INC      EDI\r
        INC      EDI\r
@@mReady:\r
        MOV      EDX, [EBX].TControl.fParent\r
        MOV      EBP, [EDX].TControl.fMargin\r
        NEG      EBP\r
        {$IFDEF PARANOIA}\r
        DB $A8, chkTop or chkBott\r
        {$ELSE}\r
        TEST AL, chkTop or chkBott // fAlign in [ caTop, caBottom ] ?\r
        {$ENDIF}\r
        XCHG     EAX, EDX\r
        JZ       @@noTopBottom\r
\r
        CALL     TControl.GetClientHeight\r
        XCHG     EDX, EAX\r
\r
        POP      EAX\r
        POP      ESI // MousePos.y\r
        MOV      EAX, ESI\r
        PUSH     EDX // Self_.fParent.ClientHeight\r
        SUB      EAX, [EBX].TControl.fSplitStartPos.y\r
        IMUL     EAX, EDI\r
        ADD      EAX, [EBX].TControl.fSplitStartSize // EAX = NewSize1\r
\r
        POP      EDX\r
        SUB      EDX, EAX\r
        SUB      EDX, [EBX].TControl.fBoundsRect.Bottom\r
        ADD      EDX, [EBX].TControl.fBoundsRect.Top\r
        LEA      EDX, [EDX+EBP*4]\r
\r
        MOV      ECX, [EBX].TControl.fSecondControl\r
        JECXZ    @@noSecondControl\r
        MOV      EDX, [ECX].TControl.fBoundsRect.Bottom\r
        SUB      EDX, [ECX].TControl.fBoundsRect.Top\r
        CMP      [ECX].TControl.fAlign, caClient\r
        JNZ      @@noSecondControl\r
\r
        PUSH     EAX\r
        MOV      EAX, [EBX].TControl.fSplitStartPos.y\r
        SUB      EAX, ESI\r
        IMUL     EAX, EDI\r
        ADD      EAX, [EBX].TControl.fSplitStartPos2.y\r
        LEA      EDX, [EAX+EBP*4]\r
        POP      EAX\r
\r
@@noSecondControl:\r
        JMP      @@newSizesReady\r
\r
@@noTopBottom:\r
        CALL     TControl.GetClientWidth\r
        XCHG     EDX, EAX\r
\r
        POP      ESI // MousePos.x\r
        POP      ECX\r
        MOV      EAX, ESI\r
        PUSH     EDX // Self_.fParent.ClientWidth\r
        SUB      EAX, [EBX].TControl.fSplitStartPos.x\r
        IMUL     EAX, EDI\r
        ADD      EAX, [EBX].TControl.fSplitStartSize // EAX = NewSize1\r
\r
        POP      EDX\r
        SUB      EDX, EAX\r
        SUB      EDX, [EBX].TControl.fBoundsRect.Right\r
        ADD      EDX, [EBX].TControl.fBoundsRect.Left\r
        LEA      EDX, [EDX+EBP*4]\r
\r
        MOV      ECX, [EBX].TControl.fSecondControl\r
        JECXZ    @@newSizesReady\r
        MOV      EDX, [ECX].TControl.fBoundsRect.Right\r
        SUB      EDX, [ECX].TControl.fBoundsRect.Left\r
        CMP      [ECX].TControl.fAlign, caClient\r
        JNZ      @@noSecondControl\r
\r
        PUSH     EAX\r
        MOV      EAX, [EBX].TControl.fSplitStartPos.x\r
        SUB      EAX, ESI\r
        IMUL     EAX, EDI\r
        ADD      EAX, [EBX].TControl.fSplitStartPos2.x\r
        LEA      EDX, [EAX+EBP*4]\r
        POP      EAX\r
\r
@@newSizesReady:\r
        MOV      ECX, [EBX].TControl.fSplitMinSize1\r
        //JECXZ    @@noCheckMinSize1\r
        SUB      ECX, EAX\r
        JLE      @@noCheckMinSize1\r
        SUB      EDX, ECX\r
        ADD      EAX, ECX\r
\r
@@noCheckMinSize1:\r
        MOV      ECX, [EBX].TControl.fSplitMinSize2\r
        //JECXZ    @@noCheckMinSize2\r
        SUB      ECX, EDX\r
        JLE      @@noCheckMinSize2\r
        SUB      EAX, ECX\r
        ADD      EDX, ECX\r
\r
@@noCheckMinSize2:\r
        MOV      ECX, [EBX].TControl.fOnSplit.TMethod.Code\r
        JECXZ    @@noOnSplit\r
        PUSHAD\r
        PUSH     EDX\r
        MOV      ESI, ECX\r
        XCHG     ECX, EAX\r
        MOV      EDX, EBX\r
        MOV      EAX, [EBX].TControl.fOnSplit.TMethod.Data\r
        CALL     ESI\r
        TEST     AL, AL\r
        POPAD\r
        JZ       @@e_DoDrag\r
\r
@@noOnSplit:\r
        XCHG     ESI, EAX // NewSize1 -> ESI\r
        //MOV      EDI, EDX // NewSize2 -> EDI\r
        POP      EBP\r
        ADD      ESP, -16\r
        MOV      EAX, EBP\r
        MOV      EDX, ESP\r
        CALL     TControl.GetBoundsRect\r
        MOVZX    ECX, [EBX].TControl.fAlign\r
        LOOP     @@noPrev_caLeft\r
        ADD      ESI, [ESP].TRect.Left\r
        MOV      [ESP].TRect.Right, ESI\r
@@noPrev_caLeft:\r
        LOOP     @@noPrev_caTop\r
        ADD      ESI, [ESP].TRect.Top\r
        MOV      [ESP].TRect.Bottom, ESI\r
@@noPrev_caTop:\r
        LOOP     @@noPrev_caRight\r
        MOV      EAX, [ESP].TRect.Right\r
        SUB      EAX, ESI\r
        MOV      [ESP].TRect.Left, EAX\r
@@noPrev_caRight:\r
        LOOP     @@noPrev_caBottom\r
        MOV      EAX, [ESP].TRect.Bottom\r
        SUB      EAX, ESI\r
        MOV      [ESP].TRect.Top, EAX\r
@@noPrev_caBottom:\r
        MOV       EAX, EBP\r
        MOV       EDX, ESP\r
        CALL      TControl.SetBoundsRect\r
        ADD       ESP, 16\r
        MOV       EAX, [EBX].TControl.fParent\r
        //PUSH      EAX\r
        CALL      dword ptr[Global_Align]\r
        //POP       EAX\r
        //CALL      TControl.Update\r
\r
@@e_DoDrag:\r
        POPAD\r
        RET\r
{$ENDIF USE_ASM_DODRAG}\r
\r
@@noWM_MOUSEMOVE:\r
        CMP      word ptr [EDX].TMsg.message, WM_LBUTTONDOWN\r
        JNE      @@noWM_LBUTTONDOWN\r
        MOV      ECX, [EBX].TControl.fParent\r
        TEST     ECX, ECX\r
        JZ       @@noWM_LBUTTONDOWN\r
        //JECXZ    @@noWM_LBUTTONDOWN\r
\r
        MOV      EAX, [ECX].TControl.fChildren\r
        PUSH     EAX\r
        MOV      EDX, EBX\r
        CALL     TList.IndexOf\r
        POP      ECX\r
        MOV      EDX, EBX\r
        TEST     EAX, EAX\r
        JLE      @@noParent1\r
        MOV      ECX, [ECX].TList.fItems\r
        MOV      EDX, [ECX+EAX*4-4]\r
@@noParent1:\r
\r
        MOV      CL, [EBX].TControl.fAlign\r
        MOV      AL, 1\r
        SHL      EAX, CL\r
        {$IFDEF PARANOIA}\r
        DB $A8, chkTop or chkBott\r
        {$ELSE}\r
        TEST AL, chkTop or chkBott // fAlign in [caTop,caBottom] ?\r
        {$ENDIF}\r
        XCHG     EAX, EDX\r
        JZ       @@no_caTop_caBottom\r
        CALL     TControl.GetHeight\r
        JMP      @@caTop_caBottom\r
@@no_caTop_caBottom:\r
        CALL     TControl.GetWidth\r
@@caTop_caBottom:\r
        MOV      [EBX].TControl.fSplitStartSize, EAX\r
        MOV      ECX, [EBX].TControl.fSecondControl\r
        JECXZ    @@noSecondControl1\r
        XCHG     EAX, ECX\r
        PUSH     EAX\r
        CALL     TControl.GetWidth\r
        MOV      [EBX].TControl.fSplitStartPos2.x, EAX\r
        POP      EAX\r
        CALL     TControl.GetHeight\r
        MOV      [EBX].TControl.fSplitStartPos2.y, EAX\r
@@noSecondControl1:\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     SetCapture\r
        OR       [EBX].TControl.fDragging, 1\r
        PUSH     0\r
        PUSH     100\r
        PUSH     $7B\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     SetTimer\r
        LEA      EAX, [EBX].TControl.fSplitStartPos\r
        PUSH     EAX\r
        CALL     GetCursorPos\r
        JMP      @@exit\r
\r
@@noWM_LBUTTONDOWN:\r
        CMP      word ptr [EDX].TMsg.message, WM_LBUTTONUP\r
        JNE      @@noWM_LBUTTONUP\r
        XOR      EDX, EDX\r
\r
        {$IFDEF USE_ASM_DODRAG}\r
        CALL     @@DoDrag\r
        {$ELSE}\r
        MOV      EAX, EBX\r
        CALL     DoDrag\r
        {$ENDIF}\r
\r
        JMP      @@killtimer\r
\r
@@noWM_LBUTTONUP:\r
        CMP      word ptr[EDX].TMsg.message, WM_TIMER\r
        JNE      @@exit\r
        CMP      [EBX].TControl.fDragging, 0\r
        JE       @@exit\r
        PUSH     VK_ESCAPE\r
        CALL     GetAsyncKeyState\r
        TEST     EAX, EAX\r
        JGE      @@exit\r
\r
        MOV      DL, 1\r
\r
        {$IFDEF USE_ASM_DODRAG}\r
        CALL     @@DoDrag\r
        {$ELSE}\r
        MOV      EAX, EBX\r
        CALL     DoDrag\r
        {$ENDIF}\r
\r
@@killtimer:\r
        MOV      [EBX].TControl.fDragging, 0\r
        PUSH     $7B\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     KillTimer\r
        CALL     ReleaseCapture\r
\r
@@exit:\r
        POP      EBX\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var I: Integer;\r
    Prev: PControl;\r
\r
    procedure FinDrag;\r
    begin\r
      KillTimer( Self_.fHandle, $7B );\r
      Self_.fDragging := False;\r
      ReleaseCapture;\r
    end;\r
begin\r
  case Msg.message of\r
  WM_NCHITTEST:\r
    begin\r
        Rslt := DefWindowProc( Self_.fHandle, Msg.message, Msg.wParam, Msg.lParam );\r
        if Rslt > 0 then\r
          Rslt := HTCLIENT;\r
        Result := True;\r
        Exit;\r
    end;\r
  WM_MOUSEMOVE:\r
    begin\r
      Windows.SetCursor( Self_.fCursor );\r
      DoDrag( Self_, False );\r
    end;\r
  WM_LBUTTONDOWN:\r
    begin\r
      if Self_.fParent <> nil then\r
      begin\r
        I := Self_.fParent.fChildren.IndexOf( Self_ );\r
        Prev := Self_;\r
        if I > 0 then\r
          Prev := Self_.FParent.fChildren.fItems[ I - 1 ];\r
        if Self_.fAlign in [ caTop, caBottom ] then\r
          Self_.fSplitStartSize := Prev.Height\r
        else\r
          Self_.fSplitStartSize := Prev.Width;\r
        if Self_.fSecondControl <> nil then\r
          Self_.fSplitStartPos2 :=\r
            MakePoint( Self_.fSecondControl.Width, Self_.fSecondControl.Height );\r
        SetCapture( Self_.fHandle );\r
        Self_.fDragging := True;\r
        SetTimer( Self_.fHandle, $7B, 100, nil );\r
        GetCursorPos( Self_.fSplitStartPos );\r
      end;\r
    end;\r
  WM_LBUTTONUP:\r
    begin\r
      DoDrag( Self_, False );\r
      FinDrag;\r
    end;\r
  WM_TIMER:\r
    if Self_.fDragging and (GetAsyncKeyState( VK_ESCAPE ) < 0) then\r
    begin\r
      DoDrag( Self_, True );\r
      FinDrag;\r
    end;\r
  end;\r
  Result := False;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcSplitter]\r
\r
//[function NewSplitter]\r
function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;\r
begin\r
  Result := NewSplitterEx( AParent, MinSizePrev, MinSizeNext, esLowered );\r
end;\r
//[END NewSplitter]\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewSplitterEx]\r
function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;\r
         EdgeStyle: TEdgeStyle ): PControl;\r
begin\r
  new( Result, CreateSplitter( AParent, MinSizePrev, MinSizeNext, EdgeStyle ) );\r
end;\r
//[END NewSplitterEx]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewSplitterEx]\r
{$IFDEF ASM_VERSION}\r
function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;\r
         EdgeStyle: TEdgeStyle ): PControl;\r
const int_IDC_SIZEWE = integer( IDC_SIZEWE );\r
asm\r
        PUSH     EBX\r
        PUSH     EAX  // AParent\r
        PUSH     ECX  // MinSizePrev\r
        PUSH     EDX  // MinSizeNext\r
        MOV      DL, EdgeStyle\r
        CALL     NewPanel\r
        XCHG     EBX, EAX\r
        POP      [EBX].TControl.fSplitMinSize1\r
        POP      [EBX].TControl.fSplitMinSize2\r
        XOR      EDX, EDX\r
        MOV      DL, 4\r
        MOV      EAX, [EBX].TControl.fBoundsRect.Left\r
        ADD      EAX, EDX\r
        MOV      [EBX].TControl.fBoundsRect.Right, EAX\r
        ADD      EDX, [EBX].TControl.fBoundsRect.Top\r
        MOV      [EBX].TControl.fBoundsRect.Bottom, EDX\r
\r
        POP      ECX  // ECX = AParent\r
        JECXZ    @@noParent2\r
        MOV      EAX, [ECX].TControl.fChildren\r
        MOV      ECX, [EAX].TList.fCount\r
        CMP      ECX, 1\r
        JLE      @@noParent2\r
\r
        MOV      EAX, [EAX].TList.fItems\r
        MOV      EAX, [EAX+ECX*4-8]\r
        MOV      CL, [EAX].TControl.fAlign\r
        PUSH     ECX\r
        MOV      AL, 1\r
        SHL      EAX, CL\r
        {$IFDEF PARANOIA}\r
        DB $A8, chkTop or chkBott\r
        {$ELSE}\r
        TEST     AL, chkTop or chkBott\r
        {$ENDIF}\r
        MOV      EAX, int_IDC_SIZEWE\r
        JZ       @@TopBottom\r
        INC      EAX\r
@@TopBottom:\r
        PUSH     EAX\r
        PUSH     0\r
        CALL     LoadCursor\r
        MOV      [EBX].TControl.fCursor, EAX\r
        POP      EDX\r
        MOV      EAX, EBX\r
        CALL     TControl.SetAlign\r
\r
@@noParent2:\r
        MOV      EAX, EBX\r
        MOV      EDX, offset[WndProcSplitter]\r
        CALL     TControl.AttachProc\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;\r
         EdgeStyle: TEdgeStyle ): PControl;\r
var PrevCtrl: PControl;\r
    Sz0: Integer;\r
begin\r
  Result := NewPanel( AParent, EdgeStyle );\r
  Result.fSplitMinSize1 := MinSizePrev;\r
  Result.fSplitMinSize2 := MinSizeNext;\r
  Sz0 := 4;\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + Sz0;\r
    Bottom := Top + Sz0;\r
  end;\r
  if AParent <> nil then\r
  begin\r
    if AParent.fChildren.fCount > 1 then\r
    begin\r
      PrevCtrl := AParent.fChildren.fItems[ AParent.fChildren.fCount - 2 ];\r
      case PrevCtrl.FAlign of\r
      caLeft, caRight:\r
        begin\r
          Result.fCursor := LoadCursor( 0, IDC_SIZEWE );\r
        end;\r
      caTop, caBottom:\r
        begin\r
          Result.fCursor := LoadCursor( 0, IDC_SIZENS );\r
        end;\r
      end;\r
      Result.Align := PrevCtrl.FAlign;\r
    end;\r
  end;\r
  Result.AttachProc( WndProcSplitter );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewSplitterEx]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== MDI client window control =============//\r
\r
//[procedure DestroyMDIChildren]\r
procedure DestroyMDIChildren( Form: PControl );\r
var MDIClient: PControl;\r
    I: Integer;\r
    Ch: PControl;\r
begin\r
  //Form.fDefWndProc := nil;\r
  MDIClient := Form.fMDIClient;\r
  MDIClient.fMDIDestroying := TRUE;\r
  if MDIClient = nil then Exit;\r
  if MDIClient.fMDIChildren <> nil then\r
  for I := MDIClient.fMDIChildren.Count - 1 downto 0 do\r
  begin\r
    Ch := MDIClient.fMDIChildren.fItems[ I ];\r
    if Ch.fHandle <> 0 then\r
      MDIClient.Perform( WM_MDIDESTROY, Ch.fHandle, 0 );\r
  end;\r
  MDIClient.fMDIChildren.Free;\r
  MDIClient.fMDIChildren := nil;\r
  if Form.fMenu <> 0 then\r
  begin\r
    MDIClient.Perform( WM_MDISETMENU, 0, 0 );\r
    MDIClient.Perform( WM_MDIREFRESHMENU, 0, 0 );\r
    DrawMenuBar( Form.fHandle );\r
    Form.fMenuObj.Free;\r
    Form.fMenuObj := nil;\r
  end;\r
  Form.fMDIClient := nil;\r
  MDIClient.Free;\r
end;\r
\r
//[function ProcMDIAccel]\r
function ProcMDIAccel( Applet: PControl; var Msg: TMsg ): Boolean;\r
var Form: PControl;\r
begin\r
  Result := FALSE;\r
  if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then\r
  begin\r
    Form := Applet.ActiveControl;\r
    if Form <> nil then\r
    begin\r
      if Form.IsMDIChild then\r
        Form := Form.Parent;\r
      Form := Form.ParentForm;\r
      if (Form <> nil) and (Form.MDIClient <> nil) then\r
        Result := TranslateMDISysAccel( Form.MDIClient.fHandle, Msg );\r
    end;\r
  end;\r
end;\r
\r
//[function CallDefFrameProc]\r
function CallDefFrameProc( Wnd: HWnd; Msg: Integer; wParam, lParam: Integer ): Integer;\r
stdcall;\r
var Form: PControl;\r
begin\r
  Form := Pointer( GetProp( Wnd, ID_SELF ) );\r
  if Form <> nil then\r
    Form := Form.ParentForm;\r
  if (Form <> nil) and (Form.fMDIClient <> nil) then\r
    Result := DefFrameProc( Wnd, Form.fMDIClient.fHandle, Msg, wParam, lParam )\r
  else\r
    Result := DefWindowProc( Wnd, Msg, wParam, lParam );\r
end;\r
\r
//[function WndFuncMDIClient]\r
function WndFuncMDIClient( Wnd: HWnd; Msg, wParam, lParam: Integer ): Integer;\r
stdcall;\r
var C: PControl;\r
    M: TMsg;\r
begin\r
  C := Pointer( GetProp( Wnd, ID_SELF ) );\r
  if C <> nil then\r
  begin\r
    M.hwnd := Wnd;\r
    M.message := Msg;\r
    M.wParam := wParam;\r
    M.lParam := lParam;\r
    Result := C.WndProc( M );\r
  end\r
    else\r
    Result := DefWindowProc( Wnd, Msg, wParam, lParam );\r
end;\r
\r
//[function ShowMDIClientEdge]\r
function ShowMDIClientEdge( MDIClient: PControl ): Boolean;\r
var ShowEdge: Boolean;\r
    I: Integer;\r
    Ch: PControl;\r
    ExStyle: Integer;\r
begin\r
  Result := FALSE;\r
  ShowEdge := TRUE;\r
  if MDIClient.fMDIChildren.Count > 0 then\r
    for I := 0 to MDIClient.fMDIChildren.Count-1 do\r
    begin\r
      Ch := MDIClient.fMDIChildren.fItems[ I ];\r
      if IsZoomed( Ch.fHandle ) then\r
      begin\r
        ShowEdge := FALSE;\r
        break;\r
      end;\r
    end;\r
  ExStyle := MDIClient.ExStyle;\r
  if ShowEdge then\r
    if ExStyle and WS_EX_CLIENTEDGE = 0 then\r
      ExStyle := ExStyle or WS_EX_CLIENTEDGE\r
    else\r
      Exit\r
  else if ExStyle and WS_EX_CLIENTEDGE <> 0 then\r
    ExStyle := ExStyle and not WS_EX_CLIENTEDGE\r
  else\r
    Exit;\r
  MDIClient.ExStyle := ExStyle;\r
  Result := TRUE;\r
end;\r
\r
//[function WndProcMDIClient]\r
function WndProcMDIClient( MDIClient: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
{var I: Integer;\r
    Ch: PControl;}\r
begin\r
  if not MDIClient.fMDIDestroying then\r
  case Msg.message of\r
  $3f:\r
      begin\r
        PostMessage( MDIClient.fHandle, CM_MDIClientShowEdge, 0, 0 );\r
      end;\r
  CM_MDIClientShowEdge:\r
      begin\r
        ShowMDIClientEdge( MDIClient );\r
      end;\r
  WM_NCHITTEST: // not necessary though\r
      begin\r
        Rslt := DefWindowProc( MDIClient.fHandle, WM_NCHITTEST, Msg.wParam, Msg.lParam );\r
        if Rslt = HTCLIENT then Rslt := HTTRANSPARENT;\r
      end;\r
  WM_WINDOWPOSCHANGING:\r
      begin\r
        MDIClient.Perform( WM_SETREDRAW, 0, 0 );\r
      end;\r
  WM_WINDOWPOSCHANGED:\r
      begin\r
        Global_Align( MDIClient.Parent );\r
        MDIClient.Invalidate;\r
        MDIClient.Parent.Invalidate;\r
        MDIClient.Perform( WM_SETREDRAW, 1, 0 );\r
        PostMessage( MDIClient.fHandle, CM_INVALIDATE, 0, 0 );\r
      end;\r
  CM_INVALIDATE:\r
      begin\r
        MDIClient.InvalidateNC( TRUE );\r
        MDIClient.InvalidateEx;\r
        {for I := 0 to MDIClient.fMDIChildren.Count-1 do\r
        begin\r
          Ch := MDIClient.fMDIChildren.fItems[ I ];\r
          Ch.InvalidateEx;\r
          Ch.Perform( WM_NCPAINT, 1, 0 );\r
        end;}\r
      end;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
// function added by Thaddy de Koning to fix MDI behaviour\r
//[function WndProcParentNotifyMouseLDown]\r
function WndProcParentNotifyMouseLDown( Sender: PControl; var Msg: TMsg;\r
var Rslt: Integer ): Boolean;\r
begin\r
  Result := FALSE;\r
  if (Sender.IsMDIChild) and (Msg.message = WM_PARENTNOTIFY) and\r
     (LOWORD(msg.wparam)=WM_LBUTTONDOWN) then\r
     BringWindowToTop( Sender.Handle );\r
end;\r
\r
//[function NewMDIClient]\r
function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl;\r
var F: PControl;\r
    CCS: TClientCreateStruct;\r
    PrntWin: HWnd;\r
begin\r
  F := nil;\r
  PrntWin := 0;\r
  if AParent <> nil then\r
  begin\r
    F := AParent.ParentForm;\r
    if F <> nil then\r
    begin\r
      F.Add2AutoFreeEx( TObjectMethod( MakeMethod( F, @ DestroyMDIChildren ) ) );\r
      F.GetWindowHandle; // must be created before MDI client creation\r
      F.fDefWndProc := @CallDefFrameProc;\r
    end;\r
    PrntWin := AParent.GetWindowHandle;\r
  end;\r
  Applet.fExMsgProc := ProcMDIAccel;\r
  Result := _NewControl( AParent, 'MDICLIENT',\r
         WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or\r
         WS_VISIBLE or WS_TABSTOP or MDIS_ALLCHILDSTYLES, TRUE, nil );\r
  {Result.fBoundsRect.Right := Result.fBoundsRect.Left + 300;\r
  Result.fBoundsRect.Bottom := Result.fBoundsRect.Top + 200;}\r
  Result.fMDIChildren := NewList;\r
  Result.fExStyle := WS_EX_CLIENTEDGE;\r
\r
  CCS.hWindowMenu := WindowMenu;\r
  CCS.idFirstChild := $FF00;\r
  Result.fHandle := CreateWindowEx( WS_EX_CLIENTEDGE, 'MDICLIENT', nil,\r
                 WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or\r
                 WS_VISIBLE or WS_TABSTOP,\r
                 //or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX,\r
                 0, 0, 0, 0, PrntWin, 0, hInstance, @ CCS );\r
  Result.fDefWndProc := Pointer( GetWindowLong( Result.fHandle, GWL_WNDPROC ) );\r
  SetWindowLong( Result.fHandle, GWL_WNDPROC, Integer( @WndFuncMDIClient ) );\r
  SetProp( Result.fHandle, ID_SELF, Integer( Result ) );\r
  if F <> nil then\r
    F.fMDIClient := Result;\r
  Result.AttachProc( WndProcMDIClient );\r
  Result.GetWindowHandle;\r
\r
  Applet.AttachProc( WndProcParentNotifyMouseLDown );\r
end;\r
\r
//===================== MDI child window object ==============//\r
//[function MDIChildFunc]\r
function MDIChildFunc( Wnd: HWnd; Msg: DWord; wParam, lParam: Integer ): Integer;\r
stdcall;\r
var C: PControl;\r
    M: TMsg;\r
begin\r
  C := Pointer( GetProp( Wnd, ID_SELF ) );\r
  if C <> nil then\r
  begin\r
    M.hwnd := Wnd;\r
    M.message := Msg;\r
    M.wParam := wParam;\r
    M.lParam := lParam;\r
    Result := C.WndProc( M );\r
  end\r
    else\r
    Result := DefMDIChildProc( Wnd, Msg, wParam, lParam );\r
end;\r
\r
//[function Pass2DefMDIChildProc]\r
function Pass2DefMDIChildProc( Sender_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  Result := FALSE;\r
  if Sender_ = nil then Exit;\r
  if Sender_.Parent = nil then Exit;\r
  if Sender_.Parent.fDestroying then Exit;\r
  if (Msg.message = WM_SYSCOMMAND) or (Msg.message = WM_CHILDACTIVATE) or\r
     (Msg.message = WM_SETFOCUS) or (Msg.message = WM_SIZE) or\r
     (Msg.message = WM_MOVE) or (Msg.message = WM_MENUCHAR) or\r
     (Msg.message = WM_GETMINMAXINFO) {and IsZoomed( Sender_.fHandle ) {and (Msg.hwnd = Sender_.fHandle) { -- doesn't work -- } then\r
  begin\r
    {if Msg.message = WM_GETMINMAXINFO then\r
      Rslt := DefWindowProc( Msg.hwnd, Msg.message, Msg.lParam, Msg.wParam )\r
    else}\r
    Rslt := DefMDIChildProc( Msg.hwnd, Msg.message, Msg.lParam, Msg.wParam );\r
    Result := TRUE;\r
  end;\r
end;\r
\r
//[function WndProcMDIChild]\r
function WndProcMDIChild( MDIChild: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var ClientWnd: HWnd;\r
    MDIClient: PControl;\r
    MDIForm: PControl;\r
begin\r
  Result := FALSE;\r
  MDIClient := MDIChild.Parent;\r
  if MDIClient = nil then Exit;\r
  ClientWnd := MDIClient.fHandle;\r
  if ClientWnd = 0 then Exit;\r
  case Msg.message of\r
  WM_DESTROY:\r
    begin\r
      MDIClient.fMDIChildren.Remove( MDIChild );\r
      MDIForm := MDIClient.ParentForm;\r
      if MDIForm <> nil then\r
      if MDIForm.fHandle <> 0 then\r
        DrawMenuBar( MDIForm.fHandle );\r
      MDIChild.Free;\r
      Result := TRUE;\r
      Exit;\r
    end;\r
  end;\r
  if MDIChild.fNotAvailable then\r
  begin\r
    MDIChild.fNotAvailable := FALSE;\r
    MDIChild.Invalidate;\r
  end;\r
end;\r
\r
//[procedure CreateMDIChildExt]\r
procedure CreateMDIChildExt( Sender: PControl );\r
var F: PControl;\r
begin\r
  F := Sender.Parent;\r
  if F <> nil then\r
    F := F.ParentForm;\r
  if F <> nil then\r
    DrawMenuBar( F.fHandle );\r
end;\r
\r
//[function NewMDIChild]\r
function NewMDIChild( AParent: PControl; const ACaption: String ): PControl;\r
var MDIClient: PControl;\r
begin\r
  Assert( (AParent <> nil) and (AParent.ParentForm <> nil) and\r
          (AParent.ParentForm.fMDIClient <> nil), 'Error creating MDI child' );\r
  MDIClient := AParent.ParentForm.fMDIClient;\r
  Result := NewForm( MDIClient, ACaption );\r
  Result.fIsMDIChild := TRUE;\r
  Result.fMenu := CtlIdCount;\r
  Inc( CtlIdCount );\r
  MDIClient.fMDIChildren.Add( Result );\r
  Result.fExStyle := Result.fExStyle or WS_EX_MDICHILD;\r
  Result.fWndFunc := @ MDIChildFunc;\r
  Result.fDefWndProc := @DefMDIChildProc;\r
  Result.fPass2DefProc := Pass2DefMDIChildProc;\r
  Result.AttachProc( WndProcMDIChild );\r
\r
  Result.SubClassName := 'MDI_chld';\r
  Result.fNotAvailable := TRUE;\r
  Result.fCreateWndExt := CreateMDIChildExt;\r
\r
end;\r
\r
//===================== Gradient panel ========================//\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewGradientPanel]\r
function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;\r
begin\r
  new( Result, CreateGradientPanel( AParent, Color1, Color2 ) );\r
end;\r
//[END NewGradientPanel]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewGradientPanel]\r
{$IFDEF ASM_VERSION}\r
function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;\r
asm\r
        PUSH     ECX\r
        PUSH     EDX\r
        XOR      EDX, EDX\r
        CALL     NewLabel\r
        PUSH     EAX\r
        MOV      EDX, offset[WndProcGradient]\r
        CALL     TControl.AttachProc\r
        POP      EAX\r
        POP      [EAX].TControl.fColor1\r
        POP      [EAX].TControl.fColor2\r
        ADD      [EAX].TControl.fBoundsRect.Right, 40-64\r
        ADD      [EAX].TControl.fBoundsRect.Bottom, 40 - 22\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;\r
begin\r
  Result := NewLabel( AParent, '' );\r
  Result.AttachProc( WndProcGradient );\r
  Result.fColor2 := Color2;\r
  Result.fColor1 := Color1;\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 40;\r
    Bottom := Top + 40;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewGradientPanel]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewGradientPanelEx]\r
function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;\r
                             Style: TGradientStyle; Layout: TGradientLayout ): PControl;\r
begin\r
  new( Result, CreateGradientPanelEx( AParent, Color1, Color2,\r
                             Style, Layout ) );\r
end;\r
//[END NewGradientPanelEx]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewGradientPanelEx]\r
{$IFDEF ASM_VERSION}\r
function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;\r
                             Style: TGradientStyle; Layout: TGradientLayout ): PControl;\r
asm\r
        PUSH     ECX\r
        PUSH     EDX\r
        XOR      EDX, EDX\r
        CALL     NewLabel\r
        PUSH     EAX\r
        MOV      EDX, offset[WndProcGradientEx]\r
        CALL     TControl.AttachProc\r
        POP      EAX\r
        POP      [EAX].TControl.fColor1\r
        POP      [EAX].TControl.fColor2\r
        ADD      [EAX].TControl.fBoundsRect.Right, 40-100\r
        ADD      [EAX].TControl.fBoundsRect.Bottom, 40 - 22\r
        MOV      DL, Style\r
        MOV      [EAX].TControl.fGradientStyle, DL\r
        MOV      DL, Layout\r
        MOV      [EAX].TControl.fGradientLayout, DL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;\r
                             Style: TGradientStyle; Layout: TGradientLayout ): PControl;\r
begin\r
  Result := NewLabel( AParent, '' );\r
  Result.AttachProc( WndProcGradientEx );\r
  Result.fColor2 := Color2;\r
  Result.fColor1 := Color1;\r
  Result.fGradientStyle := Style;\r
  Result.fGradientLayout := Layout;\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 40;\r
    Bottom := Top + 40;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewGradientPanelEx]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Edit box ========================//\r
\r
const Editflags: array [ TEditOption ] of Integer = (\r
                  not (ES_AUTOHSCROLL or WS_HSCROLL),\r
                  not (es_AutoVScroll or WS_VSCROLL),\r
                  es_Lowercase, es_Multiline,\r
                  es_NoHideSel, es_OemConvert, es_Password, es_Readonly,\r
                  es_UpperCase, es_WantReturn, 0, es_Number );\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewEditbox]\r
function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;\r
begin\r
  new( Result, CreateEditbox( AParent, Options ) );\r
end;\r
//[END NewEditbox]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewEditBox]\r
{$IFDEF ASM_VERSION}\r
const EditClass: array[0..4] of Char = ( 'E','D','I','T',#0 );\r
function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;\r
const int_IDC_IBEAM = integer( IDC_IBEAM );\r
const WS_flags = integer( WS_VISIBLE or WS_CHILD or WS_TABSTOP or WS_BORDER );\r
const WS_clear = integer( not(WS_VSCROLL or WS_HSCROLL) );\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX // EBX=AParent\r
        PUSH     EDX\r
        MOV      EAX, ESP\r
        XOR      ECX, ECX\r
        MOV      CL, 11\r
        MOV      EDX, offset [EditFlags]\r
        CALL     MakeFlags\r
        XCHG     ECX, EAX // ECX = Flags\r
        POP      EAX  // Options\r
        PUSH     EAX\r
        {$IFDEF PARANOIA}\r
        DB $A8, 8\r
        {$ELSE}\r
        TEST     AL, 8\r
        {$ENDIF}\r
        JNZ      @@1\r
        AND      ECX, WS_clear\r
@@1:    OR       ECX, WS_flags\r
        PUSH     1\r
        PUSH     offset [EditActions]\r
        MOV      EDX, offset [EditClass]\r
        XCHG     EAX, EBX\r
        CALL     _NewControl\r
        XCHG     EBX, EAX\r
{ //YS\r
        PUSH     int_IDC_IBEAM\r
        PUSH     0\r
        CALL     LoadCursor\r
        MOV      [EBX].TControl.fCursor, EAX\r
}\r
        LEA      ECX, [EBX].TControl.fBoundsRect\r
        MOV      EDX, [ECX].TRect.Left\r
        ADD      EDX, 100\r
        MOV      [ECX].TRect.Right, EDX\r
        MOV      EDX, [ECX].TRect.Top\r
        ADD      EDX, 22\r
        MOV      [ECX].TRect.Bottom, EDX\r
        POP      EAX // Options\r
        {$IFDEF PARANOIA}\r
        DB $A8, 8\r
        {$ELSE}\r
        TEST     AL, 8\r
        {$ENDIF}\r
        MOV      DL, $0D\r
        JZ       @@2\r
        ADD      [ECX].TRect.Right, 100\r
        ADD      [ECX].TRect.Bottom, 200 - 22\r
        MOV      DL, 1\r
        INC      [EBX].TControl.fIgnoreDefault\r
@@2:    //MOV      [EBX].TControl.fColor, clWindow\r
        TEST     AH, 4\r
        JZ       @@3\r
        AND      DL, $FE\r
@@3:    MOV      [EBX].TControl.fLookTabKeys, DL\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;\r
var Flags: Integer;\r
begin\r
  Flags := MakeFlags( @Options, EditFlags );\r
  if not(eoMultiline in Options) then\r
     Flags := Flags and not(WS_HSCROLL or WS_VSCROLL);\r
  Result := _NewControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP\r
                         or WS_BORDER or Flags, True, @EditActions );\r
//  Result.fCursor := LoadCursor( 0, IDC_IBEAM ); {YS}\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 100;\r
    Bottom := Top + 22;\r
    if eoMultiline in Options then\r
    begin\r
       Right := Right + 100;\r
       Bottom := Top + 200;\r
       Result.fIgnoreDefault := TRUE;\r
    end;\r
  end;\r
  Result.fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ];\r
  if eoMultiline in Options then\r
     Result.fLookTabKeys := [ tkTab ];\r
  if eoWantTab in Options then\r
     Result.fLookTabKeys := Result.fLookTabKeys - [ tkTab ];\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewEditBox]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== List box ========================//\r
\r
const ListFlags: array[TListOption] of Integer = (\r
                  LBS_DISABLENOScroll, not LBS_ExtendedSel,\r
                  LBS_MultiColumn or WS_HSCROLL,\r
                  LBS_MultiPLESel,\r
                  LBS_NoIntegralHeight, LBS_NoSel, LBS_Sort, LBS_USETabstops,\r
                  not LBS_HASSTRINGS, LBS_NODATA, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE );\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewListbox]\r
function NewListbox( AParent: PControl; Options: TListOptions ): PControl;\r
begin\r
  new( Result, CreateListbox( AParent, Options ) );\r
end;\r
//[END NewListbox]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewListbox]\r
{$IFDEF ASM_VERSION}\r
const ListBoxClass : array[ 0..7 ] of Char = ( 'L','I','S','T','B','O','X',#0 );\r
function NewListbox( AParent: PControl; Options: TListOptions ): PControl;\r
asm\r
        PUSH     EAX\r
        PUSH     EDX\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[ListFlags]\r
        XOR      ECX, ECX\r
        MOV      CL, 11\r
        CALL     MakeFlags\r
        POP      EDX\r
        OR       EAX, WS_VISIBLE or WS_CHILD or WS_TABSTOP or WS_BORDER or WS_VSCROLL or LBS_NOTIFY\r
        XCHG     ECX, EAX\r
        POP      EAX\r
        PUSH     1\r
        PUSH     offset[ListActions]\r
        MOV      EDX, offset[ListBoxClass]\r
        CALL     _NewControl\r
        ADD      [EAX].TControl.fBoundsRect.Right, 100\r
        ADD      [EAX].TControl.fBoundsRect.Bottom, 200-64\r
        MOV      [EAX].TControl.fColor, clWindow\r
        MOV      [EAX].TControl.fLookTabKeys, 3\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewListbox( AParent: PControl; Options: TListOptions ): PControl;\r
var Flags: Integer;\r
begin\r
  Flags := MakeFlags( @Options, ListFlags );\r
  Result := _NewControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP\r
                         or WS_BORDER or WS_VSCROLL\r
                         or LBS_NOTIFY or Flags, True, @ListActions );\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Right + 100;\r
    Bottom := Top + 200;\r
  end;\r
  Result.fColor := clWindow;\r
  Result.fLookTabKeys := [ tkTab, tkLeftRight ];\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewListbox]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Combo box ========================//\r
\r
//[FUNCTION ComboboxDropDown]\r
{$IFNDEF USE_DROPDOWNCOUNT}\r
{$IFDEF ASM_VERSION}\r
procedure ComboboxDropDown( Sender: PObj );\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, EAX\r
        CALL     TControl.GetItemsCount\r
        CMP      EAX, 1\r
        JGE      @@1\r
        XOR      EAX, EAX\r
        INC      EAX\r
@@1:    CMP      EAX, 8\r
        JLE      @@2\r
        XOR      EAX, EAX\r
        MOV      AL, 8\r
@@2:    XOR      ESI, ESI\r
        PUSH     SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_SHOWWINDOW\r
        PUSH     ESI\r
        PUSH     ESI\r
        PUSH     SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_HIDEWINDOW\r
        PUSH     EAX\r
        MOV      EAX, EBX\r
        CALL     TControl.GetHeight\r
        POP      ECX\r
        INC      ECX\r
        IMUL     ECX\r
        INC      EAX\r
        INC      EAX\r
        PUSH     EAX\r
        MOV      EAX, EBX\r
        CALL     TControl.GetWidth\r
        PUSH     EAX\r
        INC      ESI\r
@@3:    XOR      EDX, EDX\r
        PUSH     EDX\r
        PUSH     EDX\r
        PUSH     EDX\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     SetWindowPos\r
        DEC      ESI\r
        JZ       @@3\r
        MOV      ECX, [EBX].TControl.fOnDropDown.TMethod.Code\r
        JECXZ    @@exit\r
        MOV      EAX, [EBX].TControl.fOnDropDown.TMethod.Data\r
        MOV      EDX, EBX\r
        CALL     ECX\r
@@exit: POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure ComboboxDropDown( Sender: PObj );\r
var\r
  CB: PControl;\r
  IC: Integer;\r
begin\r
  CB := PControl( Sender );\r
  IC := CB.Count;\r
  if IC > 8 then IC := 8;\r
  if IC < 1 then IC := 1;\r
\r
  SetWindowPos( CB.Handle, 0, 0, 0, CB.Width, CB.Height * (IC + 1) + 2,\r
                SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_NOREDRAW +\r
                SWP_HIDEWINDOW);\r
\r
  SetWindowPos( CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE\r
                + SWP_NOZORDER + SWP_NOACTIVATE\r
                + SWP_NOREDRAW + SWP_SHOWWINDOW);\r
\r
  if assigned( CB.fOnDropDown ) then\r
    CB.fOnDropDown( CB );\r
\r
end;\r
{$ELSE newcode}\r
procedure ComboboxDropDown( Sender: PObj );\r
var\r
  CB: PControl;\r
  Count: Integer;\r
  DropDownCount: Integer;\r
  ItemHeight: Integer;\r
begin\r
  CB := PControl(Sender);\r
\r
  Count := CB.Count;\r
  DropDownCount := CB.DropDownCount;\r
  DropDownCount := 8;\r
  if (Count > DropDownCount) then\r
    Count := DropDownCount;\r
  if (Count < 1) then\r
    Count := 1;\r
  ItemHeight := CB.Perform(CB_GETITEMHEIGHT, 0, 0);\r
  SetWindowPos(\r
    CB.Handle, 0, 0, 0, CB.Width, ItemHeight * Count + CB.Height + 2,\r
    SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_HIDEWINDOW);\r
  SetWindowPos(\r
    CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER or\r
    SWP_NOACTIVATE or SWP_NOREDRAW or SWP_SHOWWINDOW);\r
\r
  if Assigned(CB.fOnDropDown) then\r
    CB.fOnDropDown(CB);\r
end;\r
{$ENDIF USE_DROPDOWNCOUNT}\r
{$ENDIF ASM_VERSION}\r
//[END ComboboxDropDown]\r
\r
//[function WndFuncCombo]\r
function WndFuncCombo( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )\r
                                   : Integer; stdcall;\r
var Combo, Form: PControl;\r
    ParentWnd : HWnd;\r
    MsgStruct: TMsg;\r
//********************************************************** Added By M.Gerasimov\r
//*\r
    PrevProc:Pointer;\r
//*\r
//********************************************************** Added By M.Gerasimov\r
begin\r
   Combo := nil;\r
\r
   ParentWnd := GetParent( W );\r
   if ParentWnd <> 0 then\r
     Combo := Pointer( GetProp( ParentWnd, ID_SELF ) );\r
\r
   if Combo <> nil then\r
   begin\r
      MsgStruct.hwnd := Combo.fHandle;\r
      MsgStruct.message := Msg;\r
      MsgStruct.wParam := wParam;\r
      MsgStruct.lParam := lParam;\r
      Form := Combo.ParentForm;\r
      if fGlobalProcKeybd( Combo, MsgStruct, Result ) then Exit;\r
      if W <> Combo.FHandle then\r
      begin\r
        if Assigned( Applet ) and Assigned( Applet.OnMessage ) then\r
          if Applet.OnMessage( MsgStruct, Result ) then Exit;\r
        if (Applet <> Form) and (Form <> nil) then\r
        if Assigned( Form.OnMessage ) then\r
          if Form.OnMessage( MsgStruct, Result ) then Exit;\r
      end;\r
      if //(GetFocus = W) and\r
         (Msg = WM_KEYDOWN) or (Msg = WM_KEYUP) or (Msg = WM_CHAR) then\r
      begin\r
        Result := 0;\r
        if (wParam = VK_TAB) then\r
        begin\r
          case Msg of\r
          WM_KEYDOWN:\r
            if Assigned( Combo.fGotoControl ) and\r
               Combo.fGotoControl( Combo, wParam, FALSE ) then Exit;\r
          else Exit;\r
          end;\r
        end\r
          else\r
        if (Msg = WM_CHAR) and ((wParam = VK_ESCAPE) or (wParam = VK_RETURN)) then\r
        begin\r
          if Combo.Perform( CB_GETDROPPEDSTATE, 0, 0 ) <> 0 then\r
          begin\r
            Combo.Perform( CB_SHOWDROPDOWN, 0, 0 );\r
            if wParam = VK_ESCAPE then\r
              Combo.Perform( CB_SETCURSEL, Combo.fCurIdxAtDrop, 0 );\r
            Combo.fWndProcKeybd( Combo, MsgStruct, Result );\r
            Exit;\r
          end\r
          {$IFDEF ESC_CLOSE_DIALOGS}\r
              //---------------------------------Babenko Alexey--------------------------\r
              else\r
              if (wparam = VK_ESCAPE)  then\r
                if (combo.ParentForm.ExStyle and WS_EX_DLGMODALFRAME) <> 0 then begin\r
                SendMessage(combo.ParentForm.Handle, WM_CLOSE, 0, 0);\r
                exit;\r
              end;\r
              //---------------------------------Babenko Alexey--------------------------\r
          {$ENDIF}\r
        end;\r
        Combo.fWndProcKeybd( Combo, MsgStruct, Result );\r
      end\r
        else\r
      if Msg = WM_SETFOCUS then\r
      begin\r
        if Form <> nil then Form.fCurrentControl := Combo;\r
      end;\r
      MsgStruct.hwnd := W;\r
//********************************************************** Added By M.Gerasimov\r
//*\r
      PrevProc:=Pointer(GetProp( W, ID_PREVPROC ));\r
      if PrevProc <> Nil then\r
       Result := CallWindowProc( PrevProc , W, Msg, wParam, lParam )\r
      else\r
       Result:=0;\r
//*\r
//********************************************************** Added By M.Gerasimov\r
//     Result := CallWindowProc( //Combo.fPrevWndProc\r
//           Pointer( GetProp( W, 'PREV_PROC' ) )\r
//           , W, Msg, wParam, lParam );\r
//**********************************************************\r
   end\r
      else\r
      Result := DefWindowProc( W, Msg, wParam, lParam );\r
end;\r
\r
//[PROCEDURE CreateComboboxWnd]\r
{$IFDEF ASM_VERSION}\r
procedure CreateComboboxWnd( Combo: PControl );\r
//********************************************************** Remarked By M.Gerasimov\r
//const PrevProcStr: PChar = 'PREV_PROC';\r
//********************************************************** Remarked By M.Gerasimov\r
asm\r
        PUSH     EDI\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        PUSH     GW_CHILD\r
        PUSH     [EBX].TControl.fHandle\r
        //XOR      EDI, EDI\r
@@getwindow:\r
        CALL     GetWindow\r
        TEST     EAX, EAX\r
        JZ       @@fin\r
        {TEST     EDI, EDI\r
        XCHG     EDI, EAX\r
        JZ       @@2getnext}\r
        PUSH     offset[WndFuncCombo]\r
        PUSH     GWL_WNDPROC\r
        PUSH     EAX\r
        XCHG     EDI, EAX\r
        CALL     SetWindowLong\r
        PUSH     EAX\r
//********************************************* By M.Gerasimov\r
//      PUSH     [PrevProcStr]\r
//************************************************************\r
        PUSH     offset [ID_PREVPROC]                       //\r
//************************************************************\r
        PUSH     EDI\r
        CALL     SetProp\r
@@2getnext:\r
        PUSH     GW_HWNDNEXT\r
        PUSH     EDI\r
        JMP      @@getwindow\r
@@fin:  POP      EBX\r
        POP      EDI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure CreateComboboxWnd( Combo: PControl );\r
var W : HWND;\r
    PrevProc: DWORD;\r
begin\r
   W := GetWindow( Combo.fHandle, GW_CHILD );\r
   {if W <> 0 then\r
     W := GetWindow( W, GW_HWNDNEXT );}\r
   while W <> 0 do\r
   begin\r
     PrevProc :=\r
       SetWindowLong( W, GWL_WNDPROC, Longint( @WndFuncCombo ) );\r
//********************************************* By M.Gerasimov\r
//   SetProp( W, 'PREV_PROC', PrevProc );\r
//************************************************************\r
     SetProp( W, ID_PREVPROC, PrevProc );                   //\r
//************************************************************\r
     W := GetWindow( W, GW_HWNDNEXT );\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CreateComboboxWnd]\r
\r
//[procedure RemoveChldPrevProc]\r
procedure RemoveChldPrevProc( fHandle: HWnd );\r
var Chld: HWnd;\r
begin\r
  Chld := GetWindow( fHandle, GW_CHILD );\r
  while Chld <> 0 do\r
  begin\r
    if GetProp( Chld, ID_PREVPROC ) <> 0 then\r
      RemoveProp(Chld, ID_PREVPROC);\r
    Chld := GetWindow( Chld, GW_HWNDNEXT );\r
  end;\r
end;\r
\r
//[function WndProcCombo]\r
function WndProcCombo( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  Result := FALSE;\r
  if (Msg.message >= WM_CTLCOLORMSGBOX) and (Msg.message <= WM_CTLCOLORSTATIC) then\r
  begin\r
    Rslt := Sender.Perform( Msg.message + CN_BASE, Msg.wParam, Msg.lParam );\r
    Result := TRUE;\r
  end\r
    else\r
  if //(Msg.message = CN_CTLCOLOREDIT)\r
     (Msg.message >= CN_CTLCOLORMSGBOX) and (Msg.message <= CN_CTLCOLORSTATIC)\r
     {and not AppletTerminated} then\r
  begin\r
    if Sender.fTransparent then\r
    case Msg.message of\r
    CN_CTLCOLORLISTBOX:\r
      begin\r
        SetBkMode( Msg.wParam, Windows.OPAQUE );\r
        SetBkColor(Msg.WParam, Color2RGB( Sender.fColor ) );\r
        Rslt := Global_GetCtlBrushHandle( Sender );\r
        Result := TRUE;\r
      end;\r
//********************************************************** Added By M.Gerasimov\r
//*\r
     WM_DESTROY:\r
       RemoveChldPrevProc( Sender.Handle );\r
//*\r
//********************************************************** Added By M.Gerasimov\r
    else\r
    if not Sender.DblBufTopParent.fDblBufPainting then\r
      Sender.Invalidate;\r
    end;\r
    //Result := FALSE;\r
  end\r
    else\r
  if Msg.message = CM_COMMAND then\r
  begin\r
    case HiWord( Msg.wParam ) of\r
    CBN_DROPDOWN:\r
         begin\r
           Sender.fDropped := True;\r
           Sender.fCurIdxAtDrop := Sender.CurIndex;\r
           Sender.fDropDownProc( Sender );\r
         end;\r
    CBN_CLOSEUP:\r
         begin\r
           Sender.fDropped := False;\r
           if Assigned( Sender.fOnCloseUp ) then Sender.fOnCloseUp( Sender );\r
         end;\r
    CBN_SELCHANGE:\r
         begin\r
           PostMessage( Sender.fHandle, CM_COMMAND, CM_CBN_SELCHANGE shl 16, 0 );\r
         end;\r
    end;\r
  end;\r
end;\r
\r
const ComboFlags: array[ TComboOption ] of Integer = (\r
      CBS_DROPDOWNLIST, not CBS_AUTOHScroll,\r
      CBS_DISABLENOSCROLL, CBS_LowerCase, CBS_NoIntegralHeight,\r
      CBS_OemConvert, CBS_Sort, CBS_UpperCase,\r
      CBS_OWNERDRAWFIXED, CBS_OWNERDRAWVARIABLE, CBS_SIMPLE );\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewCombobox]\r
function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;\r
begin\r
  new( Result, CreateCombobox( AParent, Options ) );\r
end;\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewCombobox]\r
{$IFDEF ASM_VERSION}\r
const ComboboxClass: array[0..8] of Char = ('C','O','M','B','O','B','O','X',#0 );\r
function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;\r
asm\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     EDX\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[ComboFlags]\r
        XOR      ECX, ECX\r
        MOV      CL, 10\r
        CALL     MakeFlags\r
        POP      EDX\r
        XCHG     ECX, EAX\r
        POP      EAX\r
        PUSH     1\r
        PUSH     offset[ComboActions]\r
        MOV      EDX, offset[ComboboxClass]\r
        OR       ECX, WS_VISIBLE or WS_CHILD or WS_VSCROLL or CBS_HASSTRINGS or WS_TABSTOP\r
        TEST     ECX, CBS_SIMPLE\r
        JNZ      @@O\r
        OR       ECX, CBS_DROPDOWN\r
@@O:\r
        CALL     _NewControl\r
        MOV      [EAX].TControl.fCreateWndExt, offset[CreateComboboxWnd]\r
        MOV      [EAX].TControl.fDropDownProc, offset[ComboboxDropDown]\r
        OR       byte ptr [EAX].TControl.fClsStyle, CS_DBLCLKS\r
        ADD      [EAX].TControl.fBoundsRect.Right, 100-64\r
        ADD      [EAX].TControl.fBoundsRect.Bottom, 22-64\r
        //MOV      [EAX].TControl.fColor, clWindow\r
        MOV      CL, 1\r
        POP      EDX\r
        TEST     DL, 1\r
        JZ       @@exit\r
        MOV      CL, 3\r
@@exit:\r
        MOV      [EAX].TControl.fLookTabKeys, CL\r
        PUSH     EAX\r
        MOV      EDX, offset[ WndProcCombo ]\r
        CALL     TControl.AttachProc\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;\r
var Flags: Integer;\r
begin\r
  Flags := MakeFlags( @Options, ComboFlags );\r
  if not LongBool( Flags and CBS_SIMPLE ) then\r
    Flags := Flags or CBS_DROPDOWN;\r
  Result := _NewControl( AParent, 'COMBOBOX',\r
                         WS_VISIBLE\r
                         or WS_CHILD\r
                         or WS_VSCROLL\r
                         or CBS_HASSTRINGS or WS_TABSTOP\r
                         or Flags\r
                         , True, @ComboActions );\r
  //Result.fCannotDoubleBuf := TRUE;\r
  Result.fCreateWndExt := CreateComboboxWnd;\r
  Result.fDropDownProc := ComboboxDropDown;\r
  Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS;\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 100;\r
    Bottom := Top + 22;\r
  end;\r
  Result.fLookTabKeys := [ tkTab ];\r
  if coReadOnly in Options then\r
    Result.fLookTabKeys := [ tkTab, tkLeftRight ];\r
  Result.AttachProc( @ WndProcCombo );\r
  {$IFDEF USE_DROPDOWNCOUNT}\r
  Result.DropDownCount := 8;\r
  {$ENDIF}\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewCombobox]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//[FUNCTION WndProcResiz]\r
{$IFDEF ASM_VERSION}\r
function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm\r
        PUSH     ESI\r
        CMP      word ptr [EDX].TMsg.message, WM_SIZE\r
        JNZ      @@exit\r
\r
        MOV      ESI, [EAX].TControl.fChildren\r
        MOV      ECX, [ESI].TList.fCount\r
        JECXZ    @@exit\r
        MOV      ESI, [ESI].TList.fItems\r
@@loo:  PUSH     ECX\r
        LODSD\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     CM_SIZE\r
        PUSH     EAX\r
        CALL     TControl.Perform\r
        POP      ECX\r
        LOOP     @@loo\r
\r
@@exit: XOR      EAX, EAX\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var I: Integer;\r
    C: PControl;\r
begin\r
  if Msg.message = WM_SIZE then\r
  begin\r
    for I:= 0 to Self_.fChildren.fCount - 1 do\r
    begin\r
      C := Self_.fChildren.fItems[ I ];\r
      C.Perform( CM_SIZE, 0, 0 );\r
    end;\r
  end;\r
  Result := False; // don't stop further processing\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcResiz]\r
\r
//[FUNCTION WndProcParentResize]\r
{$IFDEF ASM_VERSION}\r
function WndProcParentResize( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm\r
        CMP      word ptr [EDX].TMsg.message, CM_SIZE\r
        JNZ      @@exit\r
        PUSH     0\r
        PUSH     0\r
        PUSH     WM_SIZE\r
        PUSH     EAX\r
        CALL     TControl.Perform\r
@@exit: XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  Result := False;\r
  case Msg.message of\r
  CM_SIZE:\r
    begin\r
      Self_.Perform( WM_SIZE, 0, 0 );\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcParentResize]\r
\r
//[procedure InitCommonControlCommonNotify]\r
procedure InitCommonControlCommonNotify( Ctrl: PControl );\r
var AParent: PControl;\r
begin\r
  Ctrl.fIsCommonControl := True;\r
  AParent := Ctrl.Parent;\r
  if AParent <> nil then\r
  begin\r
    Ctrl.AttachProc( WndProcCommonNotify );\r
    AParent.AttachProc( WndProcNotify );\r
  end;\r
end;\r
\r
//[procedure InitCommonControlSizeNotify]\r
procedure InitCommonControlSizeNotify( Ctrl: PControl );\r
var AParent: PControl;\r
begin\r
  AParent := Ctrl.Parent;\r
  if AParent <> nil then\r
  begin\r
    Ctrl.AttachProc( WndProcParentResize );\r
    AParent.AttachProc( WndProcResize );\r
  end;\r
end;\r
\r
//[function _NewCommonControl]\r
function _NewCommonControl( AParent: PControl; ClassName: PChar; Style: DWORD;\r
                            Ctl3D: Boolean; Actions: PCommandActions ): PControl;\r
begin\r
  {*************} DoInitCommonControls( ICC_WIN95_CLASSES );\r
  Result := _NewControl( AParent, ClassName, Style, Ctl3D, Actions );\r
  //InitCommonControlSizeNotify( Result );\r
  InitCommonControlCommonNotify( Result );\r
end;\r
\r
//==================== Progress bar ======================//\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewProgressbar]\r
function NewProgressbar( AParent: PControl ): PControl;\r
begin\r
  new( Result, CreateProgressbar( AParent ) );\r
end;\r
//[END NewProgressbar]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewProgressbar]\r
{$IFDEF ASM_VERSION}\r
function NewProgressbar( AParent: PControl ): PControl;\r
asm\r
        PUSH     1\r
        PUSH     0\r
        MOV      EDX, offset[Progress_class]\r
        MOV      ECX, WS_CHILD or WS_VISIBLE\r
        CALL     _NewCommonControl\r
        LEA      EDX, [EAX].TControl.fBoundsRect\r
        MOV      ECX, [EDX].TRect.Left\r
        ADD      ECX, 300\r
        MOV      [EDX].TRect.Right, ECX\r
        MOV      ECX, [EDX].TRect.Top\r
        ADD      ECX, 20\r
        MOV      [EDX].TRect.Bottom, ECX\r
        XOR      EDX, EDX\r
        MOV      [EAX].TControl.fMenu, EDX\r
        MOV      [EAX].TControl.fTextColor, clHighlight\r
        MOV      [EAX].TControl.fCommandActions.aSetBkColor, PBM_SETBKCOLOR\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewProgressbar( AParent: PControl ): PControl;\r
begin\r
  Result := _NewCommonControl( AParent, PROGRESS_CLASS,\r
            WS_CHILD or WS_VISIBLE, True, nil );\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 300;\r
    Bottom := Top + 20;\r
  end;\r
  Result.fMenu := 0;\r
  Result.fTextColor := clHighlight;\r
  Result.fCommandActions.aSetBkColor := PBM_SETBKCOLOR;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewProgressbar]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewProgressbarEx]\r
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;\r
begin\r
  new( Result, CreateProgressbarEx( AParent, Options ) );\r
end;\r
//[END NewProgressbarEx]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewProgressbarEx]\r
{$IFDEF ASM_VERSION}\r
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;\r
asm\r
        PUSH     EDX\r
        CALL     NewProgressbar\r
        POP      ECX\r
        XOR      EDX, EDX\r
        SHR      ECX, 1\r
        JNC      @@notVert\r
        MOV      DL, 4\r
@@notVert:\r
        SHR      ECX, 1\r
        JNC      @@notSmooth\r
        INC      EDX\r
@@notSmooth:\r
        OR       [EAX].TControl.fStyle, EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;\r
const ProgressBarFlags: array[ TProgressbarOption ] of Integer =\r
      (PBS_VERTICAL, PBS_SMOOTH );\r
begin\r
  Result := NewProgressbar( AParent );\r
  Result.fStyle := Result.fStyle or DWORD( MakeFlags( @Options, ProgressBarFlags ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewProgressbarEx]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== List view ========================//\r
\r
//[FUNCTION WndProcNotify]\r
{$IFDEF ASM_VERSION}\r
function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm\r
        CMP      word ptr [EDX].TMsg.message, WM_NOTIFY\r
        JNE      @@ret_false\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     offset[ID_SELF]\r
        MOV      ECX, [EDX].TMsg.lParam\r
        PUSH     [ECX].TNMHdr.hwndFrom\r
        CALL     GetProp\r
        POP      EDX\r
        TEST     EAX, EAX\r
        JZ       @@ret_false_ECX\r
        MOV      ECX, [EAX].TControl.fHandle\r
        MOV      [EDX].TMsg.hwnd, ECX\r
        POP      ECX\r
        JMP      TControl.EnumDynHandlers\r
@@ret_false_ECX:\r
        POP      ECX\r
@@ret_false:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var NMhdr: PNMHdr;\r
    Child: PControl;\r
begin\r
  Result := False;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NMhdr := Pointer( Msg.lParam );\r
    Child := Pointer( GetProp( NMhdr.hwndFrom, ID_SELF ) );\r
    if Child <> nil then\r
    begin\r
      {if Child = Self_ then\r
      begin\r
        Rslt := Self_.CallDefWndProc( Msg );\r
        Result := TRUE;\r
      end\r
        else}\r
      begin\r
        Msg.hwnd := Child.fHandle;\r
        Result := EnumDynHandlers( Child, Msg, Rslt );\r
      end;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcNotify]\r
\r
//[FUNCTION WndProcCommonNotify]\r
{$IFDEF ASM_VERSION}\r
function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm\r
        CMP      word ptr [EDX].TMsg.message, WM_NOTIFY\r
        JNE      @@ret_false\r
        PUSH     EBX\r
        MOV      EBX, [EDX].TMsg.lParam\r
        MOV      EDX, [EBX].TNMHdr.code\r
\r
@@chk_nm_click:\r
        XOR      ECX, ECX\r
        CMP      EDX, NM_CLICK\r
        JZ       @@click\r
        CMP      EDX, NM_RCLICK\r
        JNE      @@chk_killfocus\r
        INC      ECX\r
@@click:\r
        MOV      [EAX].TControl.fRightClick, CL\r
\r
        MOV      ECX, [EAX].TControl.fOnClick.TMethod.Code\r
        JECXZ    @@fin_false\r
        MOV      EDX, [EAX].TControl.fOnClick.TMethod.Data\r
        JMP      @@fin_event\r
\r
@@fin_false:\r
        POP      EBX\r
@@ret_false:\r
        XOR      EAX, EAX\r
        RET\r
\r
@@chk_killfocus:\r
        CMP      EDX, NM_KILLFOCUS\r
        JNE      @@chk_setfocus\r
        MOV      ECX, [EAX].TControl.fOnLeave.TMethod.Code\r
        JECXZ    @@fin_false\r
        MOV      EDX, [EAX].TControl.fOnLeave.TMethod.Data\r
        JMP      @@fin_event\r
@@chk_setfocus:\r
        CMP      EDX, NM_RETURN\r
        JE       @@set_focus\r
        CMP      EDX, NM_SETFOCUS\r
        JNE      @@fin_false\r
\r
@@set_focus:\r
        MOV      ECX, [EAX].TControl.fOnEnter.TMethod.Code\r
        JECXZ    @@fin_false\r
        MOV      EDX, [EAX].TControl.fOnEnter.TMethod.Data\r
\r
@@fin_event:\r
        XCHG     EAX, EDX\r
        CALL     ECX\r
        POP      EBX\r
        MOV      AL, 1\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var NMhdr: PNMHdr;\r
begin\r
  Result := False;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NMHdr := Pointer( Msg.lParam );\r
    case NMHdr.code of\r
      NM_RCLICK,\r
      NM_CLICK:  if assigned( Self_.fOnClick ) then\r
                 begin\r
                    Self_.fRightClick := NMHdr.code=NM_RCLICK;\r
                    Self_.fOnClick( Self_ );\r
                    Result := TRUE;\r
                 end;\r
      NM_KILLFOCUS: if assigned( Self_.fOnLeave ) then\r
                    Self_.fOnLeave( Self_ );\r
      NM_RETURN,\r
      NM_SETFOCUS: if assigned( Self_.fOnEnter ) then\r
                    Self_.fOnEnter( Self_ );\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcCommonNotify]\r
\r
const ListViewStyles: array[ TListViewStyle ] of DWORD = ( LVS_ICON, LVS_SMALLICON,\r
                      LVS_LIST, LVS_REPORT, LVS_REPORT or LVS_NOCOLUMNHEADER );\r
      ListViewFlags: array[ TListViewOption ] of Integer = ( LVS_ALIGNLEFT, LVS_AUTOARRANGE,\r
                      $400 {LVS_BUTTON}, LVS_EDITLABELS, LVS_NOLABELWRAP,\r
                      LVS_NOSCROLL, LVS_NOSORTHEADER,\r
                      not LVS_SHOWSELALWAYS, not LVS_SINGLESEL, LVS_SORTASCENDING,\r
                      LVS_SORTDESCENDING, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,\r
                      LVS_OWNERDATA, LVS_OWNERDRAWFIXED );\r
\r
      ListViewExFlags: array[ TListViewOption ] of Integer = ( 0, 0,\r
                      0, 0, 0, 0, 0, 0, 0, 0, 0, LVS_EX_GRIDLINES,\r
                      LVS_EX_SUBITEMIMAGES, LVS_EX_CHECKBOXES, LVS_EX_TRACKSELECT,\r
                      LVS_EX_HEADERDRAGDROP, LVS_EX_FULLROWSELECT, LVS_EX_ONECLICKACTIVATE,\r
                      LVS_EX_TWOCLICKACTIVATE, LVS_EX_FLATSB, LVS_EX_REGIONAL,\r
                      LVS_EX_INFOTIP, LVS_EX_UNDERLINEHOT, LVS_EX_MULTIWORKAREAS, 0, 0 );\r
\r
\r
//[FUNCTION ApplyImageLists2Control]\r
{$IFDEF ASM_VERSION}\r
procedure ApplyImageLists2Control( Sender: PControl );\r
asm\r
        PUSHAD\r
        XCHG     ESI, EAX\r
        MOVZX    ECX, [ESI].TControl.fCommandActions.aSetImgList\r
        JECXZ    @@fin\r
        MOV      EBP, ECX\r
        XOR      EBX, EBX\r
        MOV      BL, 32\r
        XOR      EDI, EDI\r
@@loo:\r
        MOV      EAX, ESI\r
        MOV      EDX, EBX\r
        CALL     TControl.GetImgListIdx\r
        TEST     EAX, EAX\r
        JZ       @@nx\r
        CALL     TImageList.GetHandle\r
        PUSH     EAX\r
        PUSH     EDI\r
        PUSH     EBP\r
        PUSH     ESI\r
        CALL     TControl.Perform\r
@@nx:\r
        INC      EDI\r
        SHR      EBX, 1\r
        JZ       @@fin\r
        CMP      BL, 16\r
        JGE      @@loo\r
        XOR      EBX, EBX\r
        JMP      @@loo\r
@@fin:\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure ApplyImageLists2Control( Sender: PControl );\r
var IL: PImageList;\r
begin\r
  if Sender.fCommandActions.aSetImgList = 0 then Exit;\r
  IL := Sender.ImageListNormal;\r
  if IL <> nil then\r
    Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_NORMAL, IL.Handle );\r
  IL := Sender.ImageListSmall;\r
  if IL <> nil then\r
    Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_SMALL, IL.Handle );\r
  IL := Sender.ImageListState;\r
  if IL <> nil then\r
    Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_STATE, IL.Handle );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END ApplyImageLists2Control]\r
\r
//[FUNCTION ApplyImageLists2ListView]\r
{$IFDEF ASM_VERSION}\r
procedure ApplyImageLists2ListView( Sender: PControl );\r
asm\r
        PUSHAD\r
\r
        XCHG     ESI, EAX\r
        PUSH     dword ptr [ESI].TControl.fLVOptions\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[ListViewFlags]\r
        XOR      ECX, ECX\r
        MOV      CL, 25\r
        CALL     MakeFlags\r
        POP      ECX\r
        PUSH     ECX\r
\r
        MOV      EDX, [ESI].TControl.fStyle\r
        //AND      DH, 3\r
        AND      DX, not $403F\r
        OR       EDX, EAX\r
\r
        MOVZX    EAX, [ESI].TControl.fLVStyle\r
        OR       EDX, [EAX*4 + offset ListViewStyles]\r
\r
        MOV      EAX, ESI\r
        CALL     TControl.SetStyle\r
\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[ListViewExFlags]\r
        XOR      ECX, ECX\r
        MOV      CL, 23\r
        CALL     MakeFlags\r
        POP      EDX\r
        PUSH     EAX\r
        PUSH     $3FFF\r
        PUSH     LVM_SETEXTENDEDLISTVIEWSTYLE\r
        PUSH     ESI\r
        CALL     TControl.Perform\r
\r
        POPAD\r
        CALL     ApplyImageLists2Control\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure ApplyImageLists2ListView( Sender: PControl );\r
var Flags: DWORD;\r
begin\r
  Flags := MakeFlags( @Sender.fLVOptions, ListViewFlags );\r
  Sender.Style := Sender.Style and not $403F\r
                  or Flags or ListViewStyles[ Sender.fLVStyle ];\r
  Flags := MakeFlags( @Sender.fLVOptions, ListViewExFlags );\r
  Sender.Perform( LVM_SETEXTENDEDLISTVIEWSTYLE, $3FFF, Flags );\r
  ApplyImageLists2Control( Sender );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END ApplyImageLists2ListView]\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewListView]\r
function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;\r
                      ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;\r
begin\r
  new( Result, CreateListView( AParent, Style, Options, ImageListSmall,\r
               ImageListNormal, ImageListState ) );\r
end;\r
//[END NewListView]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewListView]\r
{$IFDEF ASM_VERSION}\r
function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;\r
                      ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;\r
asm\r
        PUSH     EDX\r
        PUSH     ECX\r
        MOVZX    EDX, DL\r
        MOV      ECX, [EDX*4 + offset ListViewStyles]\r
        OR       ECX, LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP\r
        MOV      EDX, offset[WC_LISTVIEW]\r
        PUSH     1\r
        PUSH     offset[ListViewActions]\r
        CALL     _NewCommonControl\r
\r
        MOV      EDX, ESP\r
        PUSH     EAX\r
        XCHG     EAX, EDX\r
        MOV      EDX, offset ListViewFlags\r
        XOR      ECX, ECX\r
        MOV      CL, 25\r
        CALL     MakeFlags\r
        XCHG     EDX, EAX\r
        POP      EAX\r
        MOV      ECX, [EAX].TControl.fStyle\r
        AND      ECX, not LVS_TYPESTYLEMASK\r
        OR       EDX, ECX\r
        MOV      [EAX].TControl.fStyle, EDX\r
\r
        POP      [EAX].TControl.fLVOptions\r
        POP      EDX\r
        MOV      [EAX].TControl.fLVStyle, DL\r
        MOV      [EAX].TControl.fCreateWndExt, offset[ApplyImageLists2ListView]\r
        ADD      [EAX].TControl.fBoundsRect.Right, 200-64\r
        ADD      [EAX].TControl.fBoundsRect.Bottom, 150-64\r
        MOV      ECX, [ImageListState]\r
        XOR      EDX, EDX\r
        PUSHAD\r
        CALL     TControl.SetImgListIdx\r
        POPAD\r
        MOV      ECX, [ImageListSmall]\r
        MOV      DL, 16\r
        PUSHAD\r
        CALL     TControl.SetImgListIdx\r
        POPAD\r
        MOV      ECX, [ImageListNormal]\r
        ADD      EDX, EDX\r
        PUSH     EAX\r
        CALL     TControl.SetImgListIdx\r
        POP      EAX\r
        MOV      [EAX].TControl.fLVTextBkColor, clWindow\r
        XOR      EDX, EDX\r
        //MOV      [EAX].TControl.fMargin, EDX\r
        INC      EDX\r
        MOV      [EAX].TControl.fLookTabKeys, DL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;\r
                      ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;\r
begin\r
  Result := _NewCommonControl( AParent, WC_LISTVIEW, ListViewStyles[ Style ] or\r
                               LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP or WS_CLIPCHILDREN,\r
                               True, @ListViewActions );\r
\r
  Result.fLVOptions := Options;\r
  Result.fLVStyle := Style;\r
  Result.fStyle := Result.fStyle and not LVS_TYPESTYLEMASK\r
                  or DWORD( MakeFlags( @Options, ListViewFlags ) );\r
  Result.fCreateWndExt := ApplyImageLists2ListView;\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 200;\r
    Bottom := Top + 150;\r
  end;\r
  Result.ImageListSmall := ImageListSmall;\r
  Result.ImageListNormal := ImageListNormal;\r
  Result.ImageListState := ImageListState;\r
  Result.fLVTextBkColor := clWindow;\r
  Result.fLookTabKeys := [ tkTab ];\r
  //Result.fMargin := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewListView]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//=====================  Tree view  ========================//\r
\r
//[FUNCTION WndProcTreeView]\r
{$IFDEF ASM_VERSION}\r
function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm     //cmd    //opd\r
        CMP      word ptr [EDX].TMsg.message, WM_NOTIFY\r
        JNZ      @@ret_false\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EDX, [EDX].TMsg.lParam\r
        LEA      EAX, [EBX].TControl.fOnTVBeginDrag\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, NM_RCLICK\r
        JNE      @@chk_TVN_BEGINDRAG\r
        PUSH     ECX\r
        PUSH     ECX\r
        PUSH     ESP\r
        CALL     GetCursorPos\r
        MOV      EAX, EBX\r
        MOV      EDX, ESP\r
        MOV      ECX, EDX\r
        CALL     TControl.Screen2Client\r
        POP      EAX\r
        AND      EAX, $FFFF\r
        POP      EDX\r
        SHL      EDX, 16\r
        OR       EAX, EDX\r
        PUSH     EAX\r
        CALL     GetShiftState\r
        PUSH     EAX\r
        PUSH     WM_RBUTTONUP\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     PostMessage\r
        JMP      @@2fin_false1\r
\r
@@chk_TVN_BEGINDRAG:\r
        {$IFDEF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINDRAGW\r
        JZ       @@event_drag\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINRDRAGW\r
        JZ       @@event_drag\r
        {$ENDIF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINDRAG\r
        JZ       @@event_drag\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINRDRAG\r
        JNZ      @@chk_BEGINLABELEDIT\r
@@event_drag:\r
        MOV      EDX, [EDX].TNMTreeView.itemNew.hItem\r
@@event_call:\r
        MOV      ECX, [EAX].TMethod.Code\r
        JECXZ    @@2fin_false1\r
        MOV      EAX, [EAX].TMethod.Data\r
        XCHG     EBX, ECX\r
        XCHG     EDX, ECX\r
        CALL     EBX\r
@@2fin_false1:   JMP      @@fin_false\r
@@chk_BEGINLABELEDIT:\r
        LEA      EAX, [EBX].TControl.fOnTVBeginEdit\r
        {$IFDEF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINLABELEDITW\r
        JZ       @@beginlabeledit\r
        {$ENDIF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINLABELEDIT\r
        JNZ      @@chk_ITEMEXPANDED //@@chk_DELETEITEM\r
@@beginlabeledit:\r
\r
        CMP      [EBX].TControl.fDragging, 0\r
        JZ       @@allow_LABELEDIT\r
        XOR      EAX, EAX\r
        INC      EAX\r
        MOV      [ECX], EAX\r
        JMP      @@ret_true\r
\r
@@allow_LABELEDIT:\r
        PUSH     ECX // @Rslt\r
\r
        MOV      ECX, [EAX].TMethod.Code\r
        JECXZ    @@2fin_false1\r
        PUSH     EBX\r
        XCHG     EBX, ECX\r
        MOV      EDX, [EDX].TTVDispInfo.item.hItem\r
        XCHG     EDX, ECX\r
        MOV      EAX, [EAX].TMethod.Data\r
        CALL     EBX\r
        TEST     AL, AL\r
        SETZ     AL        // Rslt := not event result;\r
        POP      EBX\r
        JZ       @@ret_EAX\r
        INC      [EBX].TControl.fEditing\r
        JMP      @@ret_EAX\r
\r
@@call_EBX:\r
        CALL     EBX\r
@@2fin_false:\r
        JMP      @@fin_false\r
@@chk_ITEMEXPANDED:\r
        LEA      EAX, [EBX].TControl.fOnTVExpanded\r
        {$IFDEF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDEDW\r
        JZ       @@itemexpanded\r
        {$ENDIF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDED\r
        JNZ      @@chk_SELCHANGING\r
@@itemexpanded:\r
        MOV      ECX, [EAX].TMethod.Code\r
        JECXZ    @@2fin_false\r
        CMP      [EDX].TNMTreeView.action, TVE_EXPAND\r
        PUSH     ECX\r
        SETZ     CL\r
        XCHG     ECX, [ESP]\r
        JMP      @@event_drag\r
@@chk_SELCHANGING:\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_SELCHANGING\r
        JNE      @@chk_ITEMEXPANDING\r
        XCHG     EAX, ECX\r
        MOV      ECX, [EBX].TControl.fOnTVSelChanging.TMethod.Code\r
@@2fin_false2:\r
        JECXZ    @@2fin_false\r
        PUSH     EAX  //@Rslt\r
        PUSH     [EDX].TNMTreeView.itemNew.hItem\r
        XCHG     ECX, EBX //EBX=OnTVSelChanging.Code ECX=Sender\r
        XCHG     ECX, EDX //EDX=Sender ECX=Msg\r
        MOV      ECX, [ECX].TNMTreeView.itemOld.hItem\r
        MOV      EAX, [EDX].TControl.fOnTVSelChanging.TMethod.Data\r
        JMP      @@111\r
\r
@@chk_ITEMEXPANDING:\r
        {$IFDEF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDINGW\r
        JZ       @@itemexpanding\r
        {$ENDIF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDING\r
        JNE      @@chk_ENDLABELEDIT\r
@@itemexpanding:\r
        XCHG     EAX, ECX\r
        MOV      ECX, [EBX].TControl.fOnTVExpanding.TMethod.Code\r
        JECXZ    @@2fin_false2\r
        PUSH     EAX // @Rslt\r
        CMP      [EDX].TNMTreeView.action, TVE_EXPAND\r
        PUSH     ECX\r
        SETZ     CL\r
        XCHG     ECX, [ESP]\r
        XCHG     ECX, EBX  //EBX=OnTVExpanding.Code ECX=Seneder\r
        XCHG     EDX, ECX  //ECX=Msg EDX=Sender\r
        MOV      ECX, [ECX].TNMTreeView.itemNew.hItem //ECX=Item\r
        MOV      EAX, [EDX].TControl.fOnTVExpanding.TMethod.Data //EAX=object\r
@@111:\r
        CALL     EBX\r
        TEST     EAX, EAX\r
        SETZ     AL        // Rslt := not event result;\r
@@ret_EAX:\r
        POP      EDX //EDX=@Rslt\r
        MOVZX    EAX, AL\r
        NEG      EAX\r
        MOV      [EDX], EAX\r
@@ret_true:\r
        MOV      AL, 1\r
        POP      EBX\r
        RET\r
@@chk_ENDLABELEDIT:\r
        {$IFDEF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_ENDLABELEDITW\r
        JZ       @@endlabeledit\r
        {$ENDIF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_ENDLABELEDIT\r
        JNZ      @@chk_SELCHANGED\r
@@endlabeledit:\r
        MOV      [EBX].TControl.fEditing, 0\r
        XCHG     EAX, ECX\r
        MOV      ECX, [EBX].TControl.fOnTVEndEdit.TMethod.Code\r
        JECXZ    @@ret_1\r
        PUSH     EAX\r
        PUSH     EBX\r
        PUSH     0\r
\r
        XCHG     EDX, EBX\r
        MOV      EAX, [EBX].TTVDispInfo.item.pszText\r
        PUSH     EDX\r
        PUSH     ECX\r
        XCHG     EAX, EDX\r
        {$IFDEF UNICODE_CTRLS}\r
        CMP      [EBX].TNMTreeView.hdr.code, TVN_ENDLABELEDITW\r
        JNZ      @@endlabeleditA\r
        CALL     TControl.TVGetItemTextW\r
        JMP      @@NewTxt_ready\r
@@endlabeleditA:\r
        {$ENDIF UNICODE_CTRLS}\r
        TEST     EDX, EDX\r
        JNZ      @@prepare_NewTxt\r
        // NewTxt := [EDX].TControl.TVItemText[ hItem ]\r
        LEA      ECX, [ESP + 8]\r
        MOV      EDX, [EBX].TTVDispInfo.item.hItem\r
        CALL     TControl.TVGetItemText\r
        JMP      @@NewTxt_ready\r
@@prepare_NewTxt:\r
        LEA      EAX, [ESP+8]\r
        CALL     System.@LStrFromPChar\r
@@NewTxt_ready:\r
        POP      ECX\r
        POP      EDX\r
        POP      EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        MOV      EAX, [EDX].TControl.fOnTVEndEdit.TMethod.Data\r
        MOV      EBX, [EBX].TTVDispInfo.item.hItem\r
        XCHG     ECX, EBX\r
        CALL     EBX\r
        XCHG     EBX, EAX\r
        CALL     RemoveStr\r
        XCHG     EAX, EBX\r
        POP      EBX\r
        JMP      @@ret_EAX\r
@@ret_1:\r
        INC      ECX\r
        MOV      [EAX], ECX\r
        JMP      @@ret_true\r
\r
@@chk_SELCHANGED:\r
        {$IFDEF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_SELCHANGEDW\r
        JZ       @@selchanged\r
        {$ENDIF UNICODE_CTRLS}\r
        CMP      word ptr [EDX].TNMTreeView.hdr.code, TVN_SELCHANGED\r
        JNZ      @@fin_false\r
@@selchanged:\r
        XCHG     EAX, EBX\r
        CALL     TControl.DoSelChange\r
\r
@@fin_false:\r
        POP      EBX\r
@@ret_false:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var NM: PNMTreeView;\r
    DI: PTVDispInfo;\r
    P: TPoint;\r
    S: String;\r
begin\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NM := Pointer( Msg.lParam );\r
    case NM.hdr.code of\r
      NM_RCLICK:\r
        begin\r
          GetCursorPos( P );\r
          P := Self_.Screen2Client( P );\r
          PostMessage( Self_.fHandle, WM_RBUTTONUP, MK_RBUTTON or GetShiftState,\r
                       (P.x and $FFFF) or (P.y shl 16) );\r
        end;\r
\r
      {$IFDEF UNICODE_CTRLS}\r
               TVN_BEGINDRAGW, TVN_BEGINRDRAGW,\r
      {$ENDIF} TVN_BEGINDRAG, TVN_BEGINRDRAG:\r
        if Assigned( Self_.fOnTVBeginDrag ) then\r
          Self_.fOnTVBeginDrag( Self_, NM.itemNew.hItem );\r
      TVN_BEGINLABELEDIT {$IFDEF UNICODE_CTRLS}, TVN_BEGINLABELEDITW{$ENDIF}:\r
      begin\r
        if Self_.fDragging then\r
        begin\r
          Rslt := 1; // do not allow edit while dragging\r
          Result := TRUE;\r
          Exit;\r
        end;\r
        DI := Pointer( NM );\r
        if Assigned( Self_.fOnTVBeginEdit ) then\r
        begin\r
          Rslt := Integer( not Self_.fOnTVBeginEdit( Self_, DI.item.hItem ) );\r
          if Rslt = 0 then\r
            Self_.fEditing := TRUE;\r
          Result := TRUE;\r
          Exit;\r
        end;\r
      end;\r
      TVN_ENDLABELEDIT {$IFDEF UNICODE_CTRLS}, TVN_ENDLABELEDITW {$ENDIF}:\r
      begin\r
        DI := Pointer( NM );\r
        if Assigned( Self_.fOnTVEndEdit ) then\r
        begin\r
          S := DI.item.pszText;\r
          if DI.item.pszText = nil then\r
          begin\r
            {$IFDEF UNICODE_CTRLS}\r
            if NM.hdr.code = TVN_ENDLABELEDITW then\r
              S := Self_.TVItemTextW[ DI.item.hItem ]\r
            else\r
            {$ENDIF UNICODE_CTRLS}\r
              S := Self_.TVItemText[ DI.item.hItem ];\r
          end;\r
          if Self_.fOnTVEndEdit( Self_, DI.item.hItem, S )\r
            then Rslt := 1\r
            else Rslt := 0;\r
        end\r
        else\r
          Rslt := 1;\r
        Self_.fEditing := FALSE;\r
        Result := True;\r
        Exit;\r
      end;\r
      TVN_ITEMEXPANDING {$IFDEF UNICODE_CTRLS}, TVN_ITEMEXPANDINGW {$ENDIF}:\r
      begin\r
        if Assigned( Self_.fOnTVExpanding ) then\r
        begin\r
          Rslt := Integer( not Self_.fOnTVExpanding( Self_, NM.itemNew.hItem,\r
                               NM.action = TVE_EXPAND ) );\r
          Result := TRUE;\r
          Exit;\r
        end;\r
      end;\r
      TVN_ITEMEXPANDED {$IFDEF UNICODE_CTRLS}, TVN_ITEMEXPANDEDW {$ENDIF}:\r
        if Assigned( Self_.fOnTVExpanded ) then\r
          Self_.fOnTVExpanded( Self_, NM.itemNew.hItem, NM.action=TVE_EXPAND );\r
      {TVN_DELETEITEM:\r
        if Assigned( Self_.fOnTVDelete ) then\r
          Self_.fOnTVDelete( Self_, NM.itemOld.hItem );}\r
      //------------------ by Sergey Shisminzev:\r
      TVN_SELCHANGING {$IFDEF UNICODE_CTRLS}, TVN_SELCHANGINGW {$ENDIF}:\r
        begin\r
          if Assigned( Self_.fOnTVSelChanging ) then\r
          begin\r
            Rslt := Integer( not Self_.fOnTVSelChanging( Self_, NM.itemOld.hItem, NM.itemNew.hItem ) );\r
            Result := TRUE;\r
            Exit;\r
          end;\r
        end;\r
      //----------------------------------------\r
      TVN_SELCHANGED {$IFDEF UNICODE_CTRLS}, TVN_SELCHANGEDW {$ENDIF}:\r
        Self_.DoSelChange;\r
    end;\r
  end;\r
  Result := False;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcTreeView]\r
\r
//[function ProcTVDeleteItem]\r
function ProcTVDeleteItem( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var NM: PNMTreeView;\r
begin\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NM := Pointer( Msg.lParam );\r
    case NM.hdr.code of\r
    TVN_DELETEITEM:\r
        if Assigned( Self_.fOnTVDelete ) then\r
          Self_.fOnTVDelete( Self_, NM.itemOld.hItem );\r
    end;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[procedure ClearTreeView]\r
procedure ClearTreeView( TV: PControl );\r
begin\r
  TV.TVDelete( TVI_ROOT );\r
end;\r
\r
const\r
  TreeViewFlags: array[ TTreeViewOption ] of Integer = ( not TVS_HASLINES, TVS_LINESATROOT,\r
                 not TVS_HASBUTTONS, TVS_EDITLABELS, not TVS_SHOWSELALWAYS,\r
                  not TVS_DISABLEDRAGDROP, TVS_NOTOOLTIPS, TVS_CHECKBOXES,\r
                  TVS_TRACKSELECT, TVS_SINGLEEXPAND, TVS_INFOTIP,\r
                  TVS_FULLROWSELECT, TVS_NOSCROLL, TVS_NONEVENHEIGHT );\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewTreeView]\r
function NewTreeView( AParent: PControl; Options: TTreeViewOptions;\r
                      ImgListNormal, ImgListState: PImageList ): PControl;\r
begin\r
  new( Result, CreateTreeView( AParent, Options, ImgListNormal, ImgListState ) );\r
end;\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewTreeView]\r
{$IFDEF ASM_VERSION}\r
function NewTreeView( AParent: PControl; Options: TTreeViewOptions;\r
                      ImgListNormal, ImgListState: PImageList ): PControl;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        PUSH     ECX\r
        PUSH     EAX\r
        PUSH     EDX\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[TreeViewFlags]\r
        XOR      ECX, ECX\r
        MOV      CL, 13\r
        CALL     MakeFlags\r
        POP      EDX\r
        OR       EAX, WS_VISIBLE or WS_CHILD or WS_TABSTOP\r
        XCHG     ECX, EAX\r
        POP      EAX\r
        MOV      EDX, offset[WC_TREEVIEW]\r
        PUSH     1\r
        PUSH     offset[TreeViewActions]\r
        CALL     _NewCommonControl\r
        MOV      EBX, EAX\r
        MOV      [EBX].TControl.fCreateWndExt, offset[ApplyImageLists2Control]\r
        MOV      [EBX].TControl.fColor, clWindow\r
        MOV      EDX, offset[WndProcTreeView]\r
        CALL     TControl.AttachProc\r
        ADD      [EBX].TControl.fBoundsRect.Right, 150-64\r
        ADD      [EBX].TControl.fBoundsRect.Bottom, 200-64\r
        MOV      EAX, EBX\r
        XOR      EDX, EDX\r
        MOV      DL, 32\r
        POP      ECX // ImageListNormal\r
        CALL     TControl.SetImgListIdx\r
        MOV      EAX, EBX\r
        XOR      EDX, EDX\r
        MOV      ECX, [ImgListState]\r
        CALL     TControl.SetImgListIdx\r
        MOV      byte ptr [EBX].TControl.fLookTabKeys, 1\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewTreeView( AParent: PControl; Options: TTreeViewOptions;\r
                      ImgListNormal, ImgListState: PImageList ): PControl;\r
var Flags: Integer;\r
begin\r
  Flags := MakeFlags( @Options, TreeViewFlags );\r
  Result := _NewCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or\r
            WS_CHILD or WS_TABSTOP, True, @TreeViewActions );\r
  Result.fCreateWndExt := ApplyImageLists2Control;\r
  Result.fColor := clWindow;\r
  Result.AttachProc( WndProcTreeView );\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 150;\r
    Bottom := Top + 200;\r
  end;\r
  Result.ImageListNormal := ImgListNormal;\r
  Result.ImageListState := ImgListState;\r
  //Result.fLVTextBkColor := clWindow;\r
  Result.fLookTabKeys := [ tkTab ];\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewTreeView]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Tab Control ========================//\r
\r
//[FUNCTION WndProcTabControl]\r
{$IFDEF ASM_VERSION}\r
function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm     //cmd    //opd\r
        PUSH     EBP\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        MOV      EBX, EAX\r
        CMP      word ptr [EDX].TMsg.message, WM_NOTIFY\r
        JNZ      @@chk_WM_SIZE\r
        MOV      EDX, [EDX].TMsg.lParam\r
        CMP      word ptr [EDX].TNMHdr.code, TCN_SELCHANGE\r
        JNZ      @@ret_false\r
\r
        CALL     TControl.GetCurIndex\r
        XCHG     EDI, EAX\r
        CMP      EDI, [EBX].TControl.fCurIndex\r
        PUSHFD   // WasActive = ZF\r
\r
        MOV      [EBX].TControl.FCurIndex, EDI\r
\r
        MOV      EAX, EBX\r
        CALL     TControl.GetItemsCount\r
        XCHG     ESI, EAX // ESI := Self_.Count\r
\r
@@loo:  DEC      ESI\r
        JS       @@e_loo\r
        MOV      EDX, ESI\r
        MOV      EAX, EBX\r
        CALL     TControl.GetPages\r
\r
        CMP      ESI, EDI\r
        PUSH     EAX\r
        SETZ     DL\r
        CALL     TControl.SetVisible\r
        POP      EAX\r
        CMP      ESI, EDI\r
        JNE      @@nx_loo\r
        CALL     TControl.BringToFront\r
@@nx_loo:\r
        JMP      @@loo\r
@@e_loo:\r
        MOV      EAX, EBX\r
        CALL     TControl.ParentForm\r
        TEST     EAX, EAX\r
        JZ       @@1\r
        MOV      ECX, [EAX].TControl.fCurrentControl\r
        JECXZ    @@1\r
        MOV      EAX, EBX\r
        MOV      DL, 1\r
        CALL     TControl.SetFocused\r
        MOV      EAX, EBX\r
        CALL     TControl.Invalidate\r
        TEST     byte ptr [EBX].TControl.fStyle+1, $10\r
        JNZ      @@1\r
        MOV      EAX, EBX\r
        XOR      EDX, EDX\r
        MOV      DL, VK_TAB\r
        CALL     TControl.GotoControl\r
@@1:\r
        POPFD\r
        JZ       @@ret_false\r
\r
        MOV      ECX, [EBX].TControl.fOnSelChange.TMethod.Code\r
        JECXZ    @@ret_false\r
        MOV      EDX, EBX\r
        MOV      EAX, [EBX].TControl.fOnSelChange.TMethod.Data\r
        CALL     ECX\r
        JMP      @@ret_false\r
@@chk_WM_SIZE:\r
        CMP      word ptr [EDX].TMsg.message, WM_SIZE\r
        JNE      @@ret_false\r
        ADD      ESP, -16\r
        PUSH     ESP\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     Windows.GetClientRect\r
        PUSH     ESP\r
        PUSH     0\r
        PUSH     TCM_ADJUSTRECT\r
        PUSH     EBX\r
        CALL     TControl.Perform\r
        MOV      EAX, EBX\r
        CALL     TControl.GetItemsCount\r
        XCHG     ESI, EAX\r
@@loo2:\r
        DEC      ESI\r
        JS       @@e_loo2\r
        MOV      EDX, ESI\r
        MOV      EAX, EBX\r
        CALL     TControl.GetPages\r
        MOV      EDX, ESP\r
        CALL     TControl.SetBoundsRect\r
        JMP      @@loo2\r
@@e_loo2:\r
        ADD      ESP, 16\r
@@ret_false:\r
        XOR      EAX, EAX\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
        POP      EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Hdr: PNMHdr;\r
    Page: PControl;\r
    I, A: Integer;\r
    R: TRect;\r
    Form: PControl;\r
    WasActive: Boolean;\r
begin\r
  case Msg.message of\r
    WM_NOTIFY:\r
      begin\r
        Hdr := Pointer( Msg.lParam );\r
        case Hdr.code of\r
        TCN_SELCHANGE:\r
          begin\r
            A := Self_.Perform( TCM_GETCURSEL, 0, 0 );\r
            WasActive := Self_.fCurIndex = A;\r
            Self_.fCurIndex := A;\r
            for I := 0 to Self_.Count - 1 do\r
            begin\r
              Page := Self_.Pages[ I ];\r
              Page.Visible := A = I;\r
              if A = I then\r
                Page.BringToFront;\r
            end;\r
            Form := Self_.ParentForm;\r
            if Form <> nil then\r
            begin\r
              if Form.fCurrentControl <> nil then\r
              begin\r
                Self_.Focused := True;\r
                Self_.Invalidate;\r
                if not Longbool( Self_.fStyle and TCS_FOCUSONBUTTONDOWN ) then\r
                  Self_.GotoControl( VK_TAB );\r
              end;\r
            end;\r
            if not WasActive then\r
            if Assigned( Self_.fOnSelChange ) then\r
              Self_.fOnSelChange( Self_ );\r
            //Result := True;\r
          end;\r
        end;\r
      end;\r
    WM_SIZE:\r
      begin\r
        GetClientRect( Self_.fHandle, R );\r
        Self_.Perform( TCM_ADJUSTRECT, 0, Integer( @R ) );\r
        for I := 0 to Self_.Count - 1 do\r
        begin\r
          Page := Self_.Pages[ I ];\r
          Page.BoundsRect := R;\r
        end;\r
      end;\r
  end;\r
  Result := False;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcTabControl]\r
\r
const TabControlFlags: array[ TTabControlOption ] of Integer = ( TCS_BUTTONS,\r
           TCS_FIXEDWIDTH, not TCS_FOCUSNEVER,\r
           TCS_FIXEDWIDTH or TCS_FORCEICONLEFT, TCS_FIXEDWIDTH or TCS_FORCELABELLEFT,\r
           TCS_MULTILINE, TCS_MULTISELECT, TCS_RIGHTJUSTIFY, TCS_SCROLLOPPOSITE,\r
           TCS_BOTTOM, TCS_VERTICAL, TCS_FLATBUTTONS, TCS_HOTTRACK, 0, TCS_OWNERDRAWFIXED );\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewTabControl]\r
function NewTabControl( AParent: PControl; Tabs: array of String; Options: TTabControlOptions;\r
         ImgList: PImageList; ImgList1stIdx: Integer ): PControl;\r
begin\r
  new( Result, CreateTabControl( AParent, Tabs, Options, ImgList, ImgList1stIdx ) );\r
end;\r
//[END NewTabControl]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewTabControl]\r
{$IFDEF ASM_VERSION}\r
function NewTabControl( AParent: PControl; Tabs: array of String; Options: TTabControlOptions;\r
         ImgList: PImageList; ImgList1stIdx: Integer ): PControl;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        XCHG     EBX, EAX\r
        PUSH     EDX\r
        PUSH     ECX\r
        LEA      EAX, [Options]\r
        MOV      EDX, offset[TabControlFlags]\r
        XOR      ECX, ECX\r
        MOV      CL, 13\r
        CALL     MakeFlags\r
        TEST     byte ptr [Options], 4\r
        JZ       @@0\r
        OR       EAX, WS_TABSTOP or TCS_FOCUSONBUTTONDOWN\r
@@0:    OR       EAX, WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE\r
        XCHG     ECX, EAX\r
        XCHG     EAX, EBX\r
        MOV      EDX, offset[WC_TABCONTROL]\r
        PUSH     1\r
        PUSH     offset[TabControlActions]\r
        CALL     _NewCommonControl\r
        MOV      EBX, EAX\r
        TEST     [Options], 2 shl (tcoBorder - 1)\r
        JNZ      @@borderfixed\r
        AND      [EBX].TControl.fExStyle, not WS_EX_CLIENTEDGE\r
@@borderfixed:\r
        MOV      EDX, offset[WndProcTabControl]\r
        CALL     TControl.AttachProc\r
        ADD      [EBX].TControl.fBoundsRect.Right, 100-64\r
        ADD      [EBX].TControl.fBoundsRect.Bottom, 100-64\r
        MOV      ECX, [ImgList]\r
        JECXZ    @@2\r
        XCHG     EAX, ECX\r
        CALL     TImageList.GetHandle\r
        PUSH     EAX\r
        PUSH     0\r
        PUSH     TCM_SETIMAGELIST\r
        PUSH     EBX\r
        CALL     TControl.Perform\r
@@2:\r
        POP      EDI // EDI = High(Tabs)\r
        POP      ESI // ESI = Tabs\r
        XOR      EDX, EDX // EBP := 0 (=I)\r
        MOV      EAX, [ImgList1stIdx] //(=II)\r
@@loop:\r
        CMP      EDX, EDI\r
        JG       @@e_loop\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     EAX\r
        LODSD\r
        XCHG     ECX, EAX\r
        MOV      EAX, EBX\r
        CALL     TControl.TC_Insert\r
        POP      EDX\r
        POP      EAX\r
        INC      EAX\r
        INC      EDX\r
        JMP      @@loop\r
@@e_loop:\r
        MOV      byte ptr [EBX].TControl.fLookTabKeys, 1\r
        XCHG     EAX, EBX\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewTabControl( AParent: PControl; Tabs: array of String; Options: TTabControlOptions;\r
         ImgList: PImageList; ImgList1stIdx: Integer ): PControl;\r
var I, II : Integer;\r
    Flags: Integer;\r
begin\r
  Flags := MakeFlags( @Options, TabControlFlags );\r
  if tcoFocusTabs in Options then\r
    Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN);\r
  Result := _NewCommonControl( AParent, WC_TABCONTROL,\r
            Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE), True,\r
            @TabControlActions );\r
  //***\r
  if not( tcoBorder in Options ) then\r
  begin\r
    Result.fExStyle := Result.fExStyle and not WS_EX_CLIENTEDGE;\r
  end;\r
  Result.AttachProc( WndProcTabControl );\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Left + 100;\r
    Bottom := Top + 100;\r
  end;\r
  if ImgList <> nil then\r
    Result.Perform( TCM_SETIMAGELIST, 0, ImgList.Handle );\r
  II := ImgList1stIdx;\r
  for I := 0 to High( Tabs ) do\r
  begin\r
    Result.TC_Insert( I, Tabs[ I ], II );\r
    Inc( II );\r
  end;\r
  Result.fLookTabKeys := [ tkTab ];\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewTabControl]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//===================== Tool bar ========================//\r
\r
//[FUNCTION WndProcToolbarCtr]\r
{$IFDEF ASM_noVERSION} //TTN_NEEDTEXTW\r
function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
asm\r
        CMP      word ptr [EDX].TMsg.message, WM_WINDOWPOSCHANGED\r
        JNE      @@chk_CM_COMMAND\r
        MOV      dword ptr [ECX], 0 // Rslt := 0\r
        MOV      ECX, [EAX].TControl.fOnResize.TMethod.Code\r
        JECXZ    @@ret_true\r
        XCHG     EDX, EAX           // Sender := Self_\r
        MOV      EAX, [EDX].TControl.fOnResize.TMethod.Data\r
        CALL     ECX                // Self_.fOnResize\r
@@ret_true:\r
        MOV      AL, 1              // Result := TRUE\r
        RET\r
@@chk_CM_COMMAND:\r
        CMP      word ptr [EDX].TMsg.message, CM_COMMAND\r
        JNE      @@chk_WM_NOTIFY\r
        MOVZX    ECX, word ptr [EDX].TMsg.wParam\r
        MOV      [EAX].TControl.fCurItem, ECX\r
        PUSH     EAX\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     TB_COMMANDTOINDEX\r
        PUSH     EAX\r
        CALL     TControl.Perform\r
        PUSH     EAX\r
\r
        PUSH     VK_RETURN\r
        CALL     GetKeyState\r
        TEST     EAX, EAX\r
        SETL     DL\r
        POP      ECX\r
        POP      EAX\r
        MOV      [EAX].TControl.fCurIndex, ECX\r
        MOV      [EAX].TControl.fRightClick, DL\r
@@ret_false:\r
        XOR      EAX, EAX\r
        RET\r
\r
@@chk_WM_NOTIFY:\r
        CMP      word ptr [EDX].TMsg.message, WM_NOTIFY\r
        JNE      @@ret_false\r
        MOV      EDX, [EDX].TMsg.lParam\r
        MOV      ECX, [EDX].TTooltipText.hdr.code\r
        CMP      ECX, TTN_NEEDTEXT\r
        JNE      @@chk_NM_RCLICK\r
        PUSH     EAX\r
        PUSH     EDX\r
        MOV      EDX, [EDX].TTooltipText.hdr.idFrom\r
        MOV      ECX, [EAX].TControl.fTBttCmd\r
        OR       EAX, -1\r
        JECXZ    @@idxReady\r
        XCHG     EAX, ECX\r
        CALL     TList.IndexOf\r
@@idxReady: // EAX = -1 or index of button tooltip\r
        TEST     EAX, EAX\r
        POP      EDX\r
        LEA      EDX, [EDX].TTooltipText.szText\r
        MOV      byte ptr [EDX], 0\r
        POP      ECX\r
        JL       @@ret_true\r
        MOV      ECX, [ECX].TControl.fTBttTxt\r
        MOV      ECX, [ECX].TStrList.fList\r
        MOV      ECX, [ECX].TList.fItems\r
        MOV      EAX, [ECX+EAX*4]\r
        XCHG     EAX, EDX\r
        XOR      ECX, ECX\r
        MOV      CL, 79\r
        CALL     StrLCopy\r
        JMP      @@ret_true\r
@@chk_NM_RCLICK:\r
        CMP      ECX, NM_RCLICK\r
        JNE      @@chk_NM_CLICK\r
        OR       [EAX].TControl.fRightClick, 1\r
        MOV      ECX, [EDX].TNMMouse.dwItemSpec\r
        MOV      [EAX].TControl.fCurItem, -1\r
        PUSH     EAX\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     TB_COMMANDTOINDEX\r
        PUSH     EAX\r
        CALL     TControl.Perform\r
        POP      EDX\r
        MOV      [EDX].TControl.fCurIndex, EAX\r
        XOR      EAX, EAX\r
        RET\r
@@chk_NM_CLICK:\r
        CMP      ECX, NM_CLICK\r
        JNE      @@chk_TBN_DROPDOWN\r
        MOV      [EAX].TControl.fRightClick, 0\r
        OR       [EAX].TControl.fCurItem, -1\r
        OR       [EAX].TControl.fCurIndex, -1\r
        CMP      [EDX].TTBNotify.iItem, -1\r
        SETNZ    AL\r
        RET\r
@@chk_TBN_DROPDOWN:\r
        CMP      ECX, TBN_DROPDOWN\r
        JNE      @@ret_false\r
        MOV      EDX, [EDX].TTBNotify.iItem\r
        MOV      [EAX].TControl.fCurItem, EDX\r
        PUSH     EAX\r
        CALL     TControl.TBItem2Index\r
        POP      EDX\r
        MOV      [EDX].TControl.fCurIndex, EAX\r
        MOV      ECX, [EDX].TControl.fOnDropDown.TMethod.Code\r
        JECXZ    @@ret_z\r
        MOV      EAX, [EDX].TControl.fOnDropDown.TMethod.Data\r
        CALL     ECX\r
@@ret_z:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
var lpttt: PTooltipText;\r
    idBtn, Idx: Integer;\r
var Notify: PTBNotify;\r
    Mouse: PNMMouse;\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
var Wstr: WideString;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
begin\r
  Result := False;\r
  if Msg.message = WM_WINDOWPOSCHANGED then\r
  begin\r
    if Assigned( Self_.fOnResize ) then\r
      Self_.fOnResize( Self_ );\r
    Result := TRUE;\r
    Rslt := 0;\r
  end\r
  else if Msg.message = CM_COMMAND then\r
  begin\r
    Self_.fCurItem := Loword( Msg.wParam );\r
    Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Loword( Msg.wParam ), 0 );\r
    Self_.fRightClick := GetKeyState( VK_RBUTTON ) < 0;\r
  end\r
  else if Msg.message = WM_NOTIFY then\r
  begin\r
    lpttt := Pointer( Msg.lParam );\r
    Notify := Pointer( Msg.lParam );\r
    case lpttt.hdr.code of\r
    TTN_NEEDTEXT:\r
        begin\r
          Result := True;\r
          idBtn := lpttt.hdr.idFrom;\r
          Idx := -1;\r
          if Self_.fTBttCmd <> nil then\r
            Idx := Self_.fTBttCmd.IndexOf( Pointer( idBtn ) );\r
          lpttt.szText[ 0 ] := #0;\r
          if Idx >= 0 then\r
            StrLCopy( lpttt.szText, Self_.fTBttTxt.fList.fItems[ Idx ], 79 );\r
          Exit;\r
        end;\r
      // for Windows XP\r
      {$IFNDEF _FPC}\r
      {$IFNDEF _D2}\r
      TTN_NEEDTEXTW:\r
          begin\r
            Result := True;\r
            idBtn := lpttt.hdr.idFrom;\r
            Idx := -1;\r
            if Self_.fTBttCmd <> nil then\r
              Idx := Self_.fTBttCmd.IndexOf( Pointer( idBtn ) );\r
            FillChar( lpttt.szText[ 0 ], 160, 0 );\r
            if Idx >= 0 then\r
            begin\r
              WStr := Self_.fTBttTxt.Items[ Idx ];\r
              if WStr <> '' then\r
                Move( Wstr[ 1 ], lpttt.szText, Min( 158, (Length( WStr ) + 1) * 2 ) );\r
            end;\r
            Exit;\r
          end;\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    NM_RCLICK:\r
        begin\r
          Mouse := Pointer( Msg.lParam );\r
          Self_.fCurItem := Mouse.dwItemSpec;\r
          Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Mouse.dwItemSpec, 0 );\r
          Self_.fRightClick := GetKeyState( VK_RBUTTON ) < 0;\r
          Self_.fRightClick := True;\r
        end;\r
    NM_CLICK:\r
        begin\r
          Self_.fCurItem := -1; // return CurItem = -1\r
          Self_.fCurIndex := -1;\r
          Self_.fRightClick := False;\r
          Result := Notify.iItem <> -1;\r
                   // do not handle - if it will be handled in WM_COMMAND\r
          Exit;\r
        end;\r
    TBN_DROPDOWN:\r
        begin\r
          Self_.fCurItem := Notify.iItem;\r
          Self_.fCurIndex := Self_.TBItem2Index( Self_.fCurItem );\r
          if assigned( Self_.fOnDropDown ) then\r
            Self_.fOnDropDown( Self_ );\r
        end;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcToolbarCtr]\r
\r
const ToolbarAligns: array[ TControlAlign ] of DWORD =\r
      ( 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,\r
        CCS_TOP );\r
      ToolbarOptions: array[ TToolbarOption ] of Integer = ( TBSTYLE_LIST, not TBSTYLE_LIST,\r
                     TBSTYLE_FLAT, TBSTYLE_TRANSPARENT, TBSTYLE_WRAPABLE, CCS_NODIVIDER, 0 );\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewToolbar]\r
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;\r
                     Bitmap: HBitmap; Buttons: array of PChar;\r
                     BtnImgIdxArray: array of Integer ) : PControl;\r
begin\r
  new( Result, CreateToolbar( AParent, Align, Options, Bitmap, Buttons, BtnImgIdxArray ) );\r
end;\r
//[END NewToolbar]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewToolbar]\r
{$IFDEF ASM_!VERSION}\r
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;\r
                     Bitmap: HBitmap; Buttons: array of PChar;\r
                     BtnImgIdxArray: array of Integer ) : PControl;\r
const szTBButton = Sizeof( TTBButton );\r
      Option3DBorder = 1 shl Ord( tbo3DBorder );\r
asm\r
        MOVZX    EDX, DL\r
        PUSH     EDX // Align\r
        PUSH     EAX // AParent\r
\r
        XOR      EAX, EAX\r
        TEST     CL, Option3DBorder\r
        SETNZ    AL\r
        PUSH     EAX\r
\r
        PUSH     ECX // Options\r
\r
        MOV      AL, ICC_BAR_CLASSES\r
        CALL     DoInitCommonControls\r
\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[ToolbarOptions]\r
        XOR      ECX, ECX\r
        MOV      CL, 5\r
        CALL     MakeFlags\r
        POP      EDX\r
\r
        PUSH     0\r
        XCHG     ECX, EAX // ECX = MakeFlags(...)\r
        MOV      EAX, [ESP+8] // EAX = AParent\r
        MOV      EDX, [ESP+12] // EDX = Align\r
        OR       ECX, [EDX*4+offset ToolbarAligns]\r
        OR       ECX, WS_CHILD or WS_VISIBLE or TBSTYLE_TOOLTIPS\r
        MOV      EDX, offset[ TOOLBARCLASSNAME ]\r
        CALL     _NewCommonControl\r
        MOV      [EAX].TControl.fCommandActions.aClear, offset[ClearToolbar]\r
        MOV      [EAX].TControl.fCommandActions.aGetCount, TB_BUTTONCOUNT\r
        INC      [EAX].TControl.fIsButton\r
        POP      EDX // pop AParent\r
        POP      EDX // EDX = Align\r
        PUSH     EDX\r
        TEST     EDX, EDX\r
        JE       @@zero_bounds\r
        ADD      [EAX].TControl.fBoundsRect.Bottom, 26-64\r
        ADD      [EAX].TControl.fBoundsRect.Right, 1000-64\r
        JMP      @@bounds_ready\r
@@zero_bounds:\r
        MOV      [EAX].TControl.fBoundsRect.Left, EDX\r
        MOV      [EAX].TControl.fBoundsRect.Top, EDX\r
        MOV      [EAX].TControl.fBoundsRect.Right, EDX\r
        MOV      [EAX].TControl.fBoundsRect.Bottom, EDX\r
@@bounds_ready:\r
        PUSH     EBX\r
        PUSH     ESI\r
        XCHG     EBX, EAX\r
        MOV      ESI, offset[TControl.Perform]\r
        PUSH     0\r
        PUSH     0\r
        PUSH     TB_GETEXTENDEDSTYLE\r
        PUSH     EBX\r
        CALL     ESI\r
        OR       EAX, TBSTYLE_EX_DRAWDDARROWS\r
        PUSH     EAX\r
        PUSH     0\r
        PUSH     TB_SETEXTENDEDSTYLE\r
        PUSH     EBX\r
        CALL     ESI\r
        MOV      EDX, offset[WndProcToolbarCtrl]\r
        MOV      EAX, EBX\r
        CALL     TControl.AttachProc\r
        MOV      EDX, offset[WndProcDoEraseBkgnd]\r
        MOV      EAX, EBX\r
        CALL     TControl.AttachProc\r
        PUSH     0\r
        PUSH     szTBButton\r
        PUSH     TB_BUTTONSTRUCTSIZE\r
        PUSH     EBX\r
        CALL     ESI\r
        PUSH     0\r
        PUSH     [EBX].TControl.fMargin\r
        PUSH     TB_SETINDENT\r
        PUSH     EBX\r
        CALL     ESI\r
        MOV      EAX, [ESP+8] // Align\r
        {$IFDEF PARANOIA}\r
        DB $2C,  1\r
        {$ELSE}\r
        SUB AL, 1\r
        {$ENDIF}\r
        JL       @@bounds_correct\r
        JE       @@corr_right\r
        {$IFDEF PARANOIA}\r
        DB $2C,  2\r
        {$ELSE}\r
        SUB AL, 2\r
        {$ENDIF}\r
        JNE      @@corr_bottom\r
@@corr_right:\r
        MOV      EDX, [EBX].TControl.fBoundsRect.Left\r
        ADD      EDX, 24\r
        MOV      [EBX].TControl.fBoundsRect.Right, EDX\r
        JMP      @@bounds_correct\r
@@corr_bottom:\r
        MOV      EDX, [EBX].TControl.fBoundsRect.Top\r
        ADD      EDX, 22\r
        MOV      [EBX].TControl.fBoundsrect.Bottom, EDX\r
@@bounds_correct:\r
        MOV      EDX, [Bitmap]\r
        TEST     EDX, EDX\r
        JZ       @@bitmap_added\r
        MOV      EAX, EBX\r
        CALL     TControl.TBAddBitmap\r
@@bitmap_added:\r
\r
        PUSH     dword ptr [BtnImgIdxArray]\r
        PUSH     dword ptr [BtnImgIdxArray-4]\r
        MOV      ECX, [Buttons-4]\r
        MOV      EDX, [Buttons]\r
        MOV      EAX, EBX\r
        CALL     TControl.TBAddButtons\r
\r
        PUSH     0\r
        PUSH     0\r
        PUSH     WM_SIZE\r
        PUSH     EBX\r
        CALL     ESI\r
\r
        XCHG     EAX, EBX\r
        POP      ESI\r
        POP      EBX\r
        ///POP      EDX  ///!!! next command is MOV ESP,EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;\r
                     Bitmap: HBitmap; Buttons: array of PChar;\r
                     BtnImgIdxArray: array of Integer ) : PControl;\r
var Flags: DWORD;\r
begin\r
  if not( tboTextBottom in Options ) then\r
    Options := Options + [ tboTextRight ];\r
  if tboTextRight in Options then\r
    Options := Options - [ tboTextBottom ];\r
  Flags := MakeFlags( @Options, ToolbarOptions );\r
  DoInitCommonControls( ICC_BAR_CLASSES );\r
  Result := _NewCommonControl( AParent, TOOLBARCLASSNAME,\r
         (ToolbarAligns[ Align ] or WS_CHILD or WS_VISIBLE or TBSTYLE_TOOLTIPS or Flags),\r
         //(not (Align in [caNone])) and not (tboNoDivider in Options),  nil );\r
         tbo3DBorder in Options,  nil );\r
  Result.fCommandActions.aClear := ClearToolbar;\r
  Result.fCommandActions.aGetCount := TB_BUTTONCOUNT;\r
  Result.fIsButton := TRUE;\r
  with Result.fBoundsRect do\r
  begin\r
    if Align in [ caNone ] then\r
    begin\r
      Bottom := Top + 26;\r
      Right := Left + 1000;\r
    end\r
       else\r
    begin\r
      Left := 0; Right := 0;\r
      Top := 0; Bottom := 0;\r
    end;\r
  end;\r
  Result.AttachProc( WndProcToolbarCtrl );\r
  Result.AttachProc( WndProcDoEraseBkgnd );\r
  Result.Perform(TB_SETEXTENDEDSTYLE, 0, Result.Perform(TB_GETEXTENDEDSTYLE, 0, 0) or\r
      TBSTYLE_EX_DRAWDDARROWS);\r
\r
  Result.Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 );\r
  Result.Perform( TB_SETINDENT, Result.fMargin, 0 );\r
  with Result.fBoundsRect do\r
  begin\r
    if Align in [ caLeft, caRight ] then\r
      Right := Left + 24\r
    else if not (Align in [caNone]) then\r
      Bottom := Top + 22;\r
  end;\r
  if Bitmap <> 0 then\r
    Result.TBAddBitmap( Bitmap );\r
  Result.TBAddButtons( Buttons, BtnImgIdxArray );\r
  Result.Perform( WM_SIZE, 0, 0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewToolbar]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//================== DateTimePicker =====================//\r
\r
function WndProcDateTimePickerNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var NMhdr: PNMHdr;\r
    D: TDateTime;\r
    AllowChg: Boolean;\r
    NMDTString: PNMDateTimeString;\r
begin\r
  Result := False;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NMHdr := Pointer( Msg.lParam );\r
    CASE NMHdr.code OF\r
    DTN_DROPDOWN: if Assigned( Self_.fOnDropDown ) then\r
                     Self_.fOnDropDown( Self_ );\r
    DTN_CLOSEUP: if Assigned( Self_.fOnCloseUp ) then\r
                   Self_.fOnCloseUp( Self_ );\r
    DTN_DATETIMECHANGE:\r
      if Assigned( Self_.fOnChange ) then\r
        Self_.fOnChange( Self_ );\r
    {DTN_FORMAT:\r
      Rslt := 0;}\r
    DTN_USERSTRING:\r
      if Assigned( Self_.fOnDTPUserString ) then\r
      begin\r
        NMDTString := Pointer( NMHdr );\r
        D := 0.0;\r
        AllowChg := TRUE;\r
        Self_.fOnDTPUserString( Self_, NMDTString.pszUserString, D, AllowChg );\r
        NMDTString.dwFlags := Integer( not AllowChg );\r
      end;\r
    END;\r
  end;\r
end;\r
\r
const\r
  //( dtpoTime, dtpoDateLong, dtpoUpDown, dtpoRightAlign,\r
  //  dtpoShowNone, dtpoParseInput )\r
\r
  DateTimePickerOptions: array[ TDateTimePickerOption ] of Integer = (\r
    DTS_TIMEFORMAT, DTS_LONGDATEFORMAT, DTS_UPDOWN, DTS_RIGHTALIGN,\r
    DTS_SHOWNONE, DTS_APPCANPARSE );\r
\r
function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions )\r
         : PControl;\r
var Flags: DWORD;\r
const\r
  CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS or\r
           CS_VREDRAW or CS_HREDRAW;\r
begin\r
  DoInitCommonControls( ICC_DATE_CLASSES );\r
  Flags := MakeFlags( @Options, DateTimePickerOptions );\r
  Result := _NewCommonControl( AParent, DATETIMEPICK_CLASS,\r
         (WS_CHILD or WS_VISIBLE or WS_TABSTOP or Flags), TRUE,  nil );\r
  //Result.ClsStyle := Result.ClsStyle and not CS_OFF;\r
  Result.SetSize( 110, 24 );\r
  Result.AttachProc( WndProcDateTimePickerNotify );\r
end;\r
\r
procedure TControl.SetDateTime(Value: TDateTime);\r
var ST: TSystemTime;\r
begin\r
  DateTime2SystemTime( Value, ST );\r
  Perform( DTM_SETSYSTEMTIME, Integer( IsNAN( Value ) ) , Integer( @ ST ) );\r
end;\r
\r
function TControl.GetDateTime: TDateTime;\r
var ST: TSystemTime;\r
begin\r
  if Perform( DTM_GETSYSTEMTIME, 0, Integer( @ ST ) ) = GDT_VALID then\r
    SystemTime2DateTime( ST, Result )\r
  else\r
    Result := NAN;\r
end;\r
\r
function TControl.GetDate: TDateTime;\r
begin\r
  Result := DateTime;\r
  if not IsNAN( Result ) then\r
    Result := Trunc( DateTime );\r
end;\r
\r
function TControl.GetTime: TDateTime;\r
begin\r
  Result := DateTime;\r
  if not IsNAN( Result ) then\r
    Result := Frac( Result );\r
end;\r
\r
procedure TControl.SetDate(const Value: TDateTime);\r
begin\r
  if IsNAN( Value ) then\r
    DateTime := Value\r
  else\r
  if not IsNAN( DateTime ) then\r
    DateTime := Trunc( Value ) + Frac( DateTime )\r
  else\r
    DateTime := Trunc( Value );\r
end;\r
\r
procedure TControl.SetTime(const Value: TDateTime);\r
begin\r
  if IsNAN( Value ) then\r
    DateTime := Value\r
  else\r
  if not IsNAN( DateTime ) then\r
    DateTime := Trunc( DateTime ) + Frac( Value )\r
  else\r
    DateTime := 1.0 + Frac( Value );\r
end;\r
\r
function TControl.GetDateTimeRange: TDateTimeRange;\r
var ST_R: array[ 0..1 ] of TSystemTime;\r
begin\r
  Perform( DTM_GETRANGE, 0, Integer( @ ST_R[ 0 ] ) );\r
  SystemTime2DateTime( ST_R[ 0 ], Result[ 0 ] );\r
  SystemTime2DateTime( ST_R[ 1 ], Result[ 1 ] );\r
end;\r
\r
procedure TControl.SetDateTimeRange(Value: TDateTimeRange);\r
var ST_R: array[ 0..1 ] of TSystemTime;\r
begin\r
  DateTime2SystemTime( Value[ 0 ], ST_R[ 0 ] );\r
  DateTime2SystemTime( Value[ 1 ], ST_R[ 1 ] );\r
  Perform( DTM_SETRANGE,\r
           Integer( IsNAN( Value[ 0 ] ) ) or\r
           (Integer( IsNAN( Value[ 1 ] ) ) shl 1),\r
           Integer( @ ST_R[ 0 ] ) );\r
end;\r
\r
function TControl.GetDateTimePickerColor( Index: TDateTimePickerColor): TColor;\r
begin\r
  Result := Perform( DTM_GETMCCOLOR, Integer( Index ), 0 );\r
end;\r
\r
procedure TControl.SetDateTimePickerColor(\r
  Index: TDateTimePickerColor; Value: TColor);\r
begin\r
  Perform( DTM_SETMCCOLOR, Integer( Index ), Color2RGB( Value ) );\r
end;\r
\r
procedure TControl.SetDateTimeFormat(const Value: String);\r
begin\r
  Perform( DTM_SETFORMAT, 0, Integer( PChar( Value ) ) );\r
end;\r
\r
function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange;\r
begin\r
  Result[ 0 ] := D1;\r
  Result[ 1 ] := D2;\r
end;\r
\r
\r
//===================== RichEdit ========================//\r
\r
type PENLink = ^TENLink;\r
     TENLink = packed record\r
       hdr: TNMHDR;\r
       msg: DWORD;\r
       wParam: Integer;\r
       lParam: Integer;\r
       chrg: TCHARRANGE;\r
     end;\r
  TEXTRANGEA = packed record\r
    chrg: TCharRange;\r
    lpstrText: PAnsiChar;\r
  end;\r
\r
//[FUNCTION WndProc_RE_LinkNotify]\r
{$IFDEF ASM_VERSION}\r
function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm\r
        CMP      word ptr [EDX].TMsg.message, WM_NOTIFY\r
        JNE      @@ret_false\r
        MOV      EDX, [EDX].TMsg.lParam\r
        CMP      [EDX].TNMHdr.code, EN_LINK\r
        JNE      @@ret_false\r
        PUSH     EBX\r
        PUSH     EDX\r
        XCHG     EBX, EAX\r
        XOR      EAX, EAX\r
        MOV      [ECX], EAX\r
        ADD      ESP, -1020\r
        PUSH     EAX\r
        PUSH     ESP\r
        PUSH     [EDX].TENLink.chrg.cpMax\r
        PUSH     [EDX].TENLink.chrg.cpMin\r
        PUSH     ESP\r
        PUSH     0\r
        PUSH     EM_GETTEXTRANGE\r
        PUSH     EBX\r
        CALL     TControl.Perform\r
        ADD      ESP, 12\r
        MOV      EDX, ESP\r
        LEA      EAX, [EBX].TControl.fREUrl\r
        CALL     System.@LStrFromPChar\r
        ADD      ESP, 1024\r
        POP      EDX\r
        MOV      ECX, [EDX].TENLink.msg\r
        LEA      EAX, [EBX].TControl.fOnREOverURL\r
        CMP      ECX, WM_MOUSEMOVE\r
        JE       @@Url_event\r
        LEA      EAX, [EBX].TControl.fOnREUrlClick\r
        CMP      ECX, WM_LBUTTONDOWN\r
        JE       @@Url_Event\r
        CMP      ECX, WM_RBUTTONDOWN\r
        JNE      @@after_Url_event\r
@@Url_event:\r
        MOV      ECX, [EAX].TMethod.Code\r
        JECXZ    @@after_Url_event\r
        MOV      EDX, EBX\r
        MOV      EAX, [EAX].TMethod.Data\r
        CALL     ECX\r
@@after_Url_event:\r
        POP      EBX\r
        MOV      AL, 1\r
        RET\r
@@ret_false:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Link: PENLink;\r
    Range: TextRangeA;\r
    Buffer: array[ 0..1023 ] of Char;\r
begin\r
  Result := False;\r
  if (Msg.message = WM_NOTIFY) and (PNMHdr( Msg.lParam ).code = EN_LINK) then\r
  begin\r
    Link := Pointer( Msg.lParam );\r
    Range.chrg := Link.chrg;\r
    Range.lpstrText := @Buffer[ 0 ]; //Pchar( @Buffer[ 0 ] );\r
    Buffer[ 0 ] := #0;\r
    Self_.Perform( EM_GETTEXTRANGE, 0, Integer( @Range ) );\r
    Self_.fREUrl := Buffer;\r
    case Link.msg of\r
    WM_MOUSEMOVE:\r
      if assigned( Self_.fOnREOverURL ) then\r
        Self_.fOnREOverURL( Self_ );\r
    WM_LBUTTONDOWN, WM_RBUTTONDOWN:\r
      if assigned( Self_.fOnREUrlClick ) then\r
        Self_.fOnREUrlClick( Self_ );\r
    end;\r
    Rslt := 0;\r
    Result := TRUE;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProc_RE_LinkNotify]\r
\r
var Global_DisableParentCursor: Boolean;\r
\r
//[FUNCTION WndProcRichEditNotify]\r
{$IFDEF ASM_noVERSION}\r
function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
const int_IDC_ARROW = integer( IDC_ARROW );\r
asm\r
        CMP      word ptr [EDX].TMsg.message, WM_NOTIFY\r
        JNE      @@ret_false                           {YS}\r
//        JNE      @@chk_WM_SETCURSOR                  {YS}\r
        MOV      EDX, [EDX].TMsg.lParam\r
        CMP      [EDX].TNMHdr.code, EN_SELCHANGE\r
        JNE      @@ret_false\r
        //PUSH     EAX\r
        CALL     TControl.DoSelChange\r
        //POP      EAX\r
        {CMP      [EAX].TControl.fTransparent, 0\r
        JZ       @@ret_false\r
        CALL     TControl.Invalidate}\r
@@ret_false:\r
        XOR      EAX, EAX\r
        RET\r
{ //YS\r
@@chk_WM_SETCURSOR:\r
        CMP      word ptr [EDX].TMsg.message, WM_SETCURSOR\r
        JNE      @@ret_false\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        PUSH     ECX\r
        PUSH     EDX\r
        INC      [Global_DisableParentCursor]\r
        CALL     TControl.CallDefWndProc\r
        DEC      [Global_DisableParentCursor]\r
        POP      EDX\r
        MOVZX    EDX, word ptr [EDX].TMsg.lParam\r
        POP      ECX\r
        MOV      [ECX], EAX\r
        TEST     EAX, EAX\r
        MOV      EAX, [EBX].TControl.fCursor\r
        POP      EBX\r
        JNZ      @@ret_true\r
        INC      dword ptr [ECX]\r
        CMP      EDX, HTCLIENT\r
        JE       @@set_cursor\r
        CMP      EDX, HTVSCROLL\r
        JE       @@set_arrow_cursor\r
        CMP      EDX, HTHSCROLL\r
        JNE      @@ret_false\r
@@set_arrow_cursor:\r
        PUSH     int_IDC_ARROW\r
        PUSH     0\r
        CALL     LoadCursor\r
@@set_cursor:\r
        PUSH     EAX\r
        CALL     Windows.SetCursor\r
@@ret_true:\r
        MOV      AL, 1\r
}\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var NMhdr: PNMHdr;\r
//    TestCode: Integer;\r
    {FR: TFormatRange;\r
    I: Integer;\r
    R: TRect;\r
    LogX, LogY: Integer;}\r
begin\r
  Result := False;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NMHdr := Pointer( Msg.lParam );\r
    case NMHdr.code of\r
    EN_SELCHANGE:\r
      begin\r
        Self_.DoSelChange;\r
        if Self_.fTransparent then\r
          Self_.Invalidate;\r
      end;\r
    end;\r
  end\r
{ // YS\r
     else\r
  if Msg.message = WM_SETCURSOR then\r
  begin\r
    Result := True;\r
    TestCode := LoWord( Msg.lParam );\r
    Global_DisableParentCursor := True;\r
    Rslt := Self_.CallDefWndProc( Msg );\r
    Global_DisableParentCursor := False;\r
    if Rslt = 0 then\r
    begin\r
      Rslt := 1;\r
      case TestCode of\r
      HTVSCROLL, HTHSCROLL: Windows.SetCursor( LoadCursor( 0, IDC_ARROW ) );\r
      HTCLIENT: Windows.SetCursor( Self_.fCursor );\r
      else Result := False;\r
      end;\r
    end;\r
  end;\r
}\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcRichEditNotify]\r
\r
var FRichEditModule: Integer;\r
    RichEditClass: PChar = 'RichEdit20A';\r
    RichEditLib: PChar = 'RICHED32.DLL';\r
\r
const RichEditLibnames: array[ 0..2 ] of PChar =\r
      ( 'RICHED20.DLL', 'RICHED32.DLL', 'RICHED.DLL' );\r
const RichEditflags: array [ TEditOption ] of Integer = (\r
                  not (es_AutoHScroll or WS_HSCROLL),\r
                  not (es_AutoVScroll or WS_VSCROLL),\r
                  0 {es_Lowercase - not supported},\r
                  0 {es_Multiline - RichEdit always multiline},\r
                  es_NoHideSel,\r
                  0 {es_OemConvert - not suppoted},\r
                  0 {es_Password - not supported},\r
                  es_Readonly,\r
                  0 {es_UpperCase - not supported},\r
                  es_WantReturn, 0, es_Number );\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewRichEdit1]\r
function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;\r
begin\r
  new( Result, CreateRichEdit1( AParent, Options ) );\r
end;\r
//[END NewRichEdit1]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewRichEdit1]\r
{$IFDEF ASM_VERSION}\r
const RichEditClass10: array[0..8] of Char = ('R','i','c','h','E','d','i','t',#0);\r
function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;\r
asm\r
        PUSH     EDX\r
\r
        MOV      ECX, [FRichEditModule]\r
        INC      ECX\r
        LOOP     @@loaded\r
        PUSHAD\r
        MOV      BL, 3\r
        LEA      ESI, [RichEditLibNames]\r
@@loo:\r
        LODSD\r
        PUSH     EAX\r
        CALL     LoadLibrary\r
        CMP      EAX, HINSTANCE_ERROR\r
        JG       @@break\r
        MOV      [RichEditClass], offset[RichEditClass10]\r
        DEC      BL\r
        JNZ      @@loo\r
        JMP      @@fault\r
@@break:\r
        MOV      [FRichEditModule], EAX\r
@@fault:\r
        POPAD\r
@@loaded:\r
        PUSH     EAX\r
        PUSH     EDX\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[RichEditFlags]\r
        XOR      ECX, ECX\r
        MOV      CL, 10\r
        CALL     MakeFlags\r
        XCHG     ECX, EAX\r
        POP      EDX\r
        POP      EAX\r
        PUSH     1\r
        PUSH     offset[RichEditActions]\r
        MOV      EDX, [RichEditClass]\r
        OR       ECX, WS_VISIBLE or WS_CHILD or WS_TABSTOP or WS_BORDER or ES_MULTILINE\r
        CALL     _NewCommonControl\r
        INC      [EAX].TControl.fIgnoreDefault\r
        POP      EDX\r
        TEST     DH, 4 // is eoWantTab in Options ?\r
        SETZ     DL\r
        MOV      [EAX].TControl.fLookTabKeys, DL\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        MOV      EDX, offset[WndProcRichEditNotify]\r
        CALL     TControl.AttachProc\r
        MOV      [EBX].TControl.fDoubleBuffered, 0\r
        INC      [EBX].TControl.fCannotDoubleBuf\r
        ADD      [EBX].TControl.fBoundsRect.Right, 100-64\r
        ADD      [EBX].TControl.fBoundsRect.Bottom, 200-64\r
        PUSH     ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or ENM_PROTECTED or $04000000\r
        PUSH     0\r
        PUSH     EM_SETEVENTMASK\r
        PUSH     EBX\r
        CALL     TControl.Perform\r
        MOV      EAX, clWindow\r
        MOV      [EBX].TControl.fColor, EAX\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        PUSH     0\r
        PUSH     EM_SETBKGNDCOLOR\r
        PUSH     EBX\r
        CALL     TControl.Perform\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;\r
var Flags, I: Integer;\r
begin\r
  if FRichEditModule = 0 then\r
  begin\r
    for I := 0 to 2 do\r
    begin\r
      FRichEditModule := LoadLibrary( RichEditLibnames[ I ] );\r
      if FRichEditModule > HINSTANCE_ERROR then break;\r
      RichEditClass := 'RichEdit';\r
    end;\r
    if FRichEditModule <= HINSTANCE_ERROR then\r
      FRichEditModule := 0;\r
  end;\r
  Flags := MakeFlags( @Options, RichEditFlags );\r
  Result := _NewCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD\r
                         or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags,\r
                         True, @RichEditActions );\r
  Result.fIgnoreDefault := TRUE;\r
  Result.fLookTabKeys := [ tkTab ];\r
  if eoWantTab in Options then\r
     Result.fLookTabKeys := [ ];\r
\r
  Result.AttachProc( WndProcRichEditNotify );\r
  Result.fDoubleBuffered := False;\r
  Result.fCannotDoubleBuf := True;\r
  with Result.fBoundsRect do\r
  begin\r
    Right := Right + 100;\r
    Bottom := Top + 200;\r
  end;\r
  Result.Perform( EM_SETEVENTMASK, 0,\r
    ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or\r
    ENM_PROTECTED or $04000000 {ENM_LINK} or ENM_KEYEVENTS {or ENM_MOUSEEVENTS} );\r
  Result.fColor := clWindow;\r
  Result.Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(Result.fColor));\r
  //Result.Perform( WM_SIZE, 0, 0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewRichEdit1]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//[API OleInitialize]\r
function OleInitialize(pwReserved: Pointer): HResult; stdcall;\r
  external 'ole32.dll' name 'OleInitialize';\r
procedure OleUninitialize; stdcall;\r
  external 'ole32.dll' name 'OleUninitialize';\r
\r
//[FUNCTION OleInit]\r
{$IFDEF ASM_VERSION}\r
function OleInit: Boolean;\r
asm\r
        MOV      ECX, [OleInitCount]\r
        INC      ECX\r
        LOOP     @@init1\r
        PUSH     ECX\r
        CALL     OleInitialize\r
        TEST     EAX, EAX\r
        MOV      AL, 0\r
        JNZ      @@exit\r
@@init1:\r
        INC      [OleInitCount]\r
        MOV      AL, 1\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function OleInit: Boolean;\r
begin\r
  if OleInitCount = 0 then\r
  begin\r
    Result := False;\r
    if OleInitialize( nil ) <> 0 then Exit;\r
  end;\r
  Inc( OleInitCount );\r
  Result := True;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END OleInit]\r
\r
//[PROCEDURE OleUnInit]\r
{$IFDEF ASM_VERSION}\r
procedure OleUnInit;\r
asm\r
        MOV      ECX, [OleInitCount]\r
        JECXZ    @@exit\r
        DEC      [OleInitCount]\r
        JNZ      @@exit\r
        CALL     OleUninitialize\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure OleUnInit;\r
begin\r
  if OleInitCount > 0 then\r
  begin\r
    Dec( OleInitCount );\r
    if OleInitCount = 0 then\r
      OleUninitialize;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END OleUnInit]\r
\r
//[API SysAllocStringLen]\r
function SysAllocStringLen;\r
         external 'oleaut32.dll' name 'SysAllocStringLen';\r
procedure SysFreeString( psz: PWideChar ); stdcall;\r
         external 'oleaut32.dll' name 'SysFreeString';\r
\r
{-}\r
//[function StringToOleStr]\r
function StringToOleStr(const Source: string): PWideChar;\r
var\r
  SourceLen, ResultLen: Integer;\r
  Buffer: array[0..1023] of WideChar;\r
begin\r
  SourceLen := Length(Source);\r
  if Length(Source) < SizeOf(Buffer) div 2 then\r
    Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,\r
      PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))\r
  else\r
  begin\r
    ResultLen := MultiByteToWideChar(0, 0,\r
      Pointer(Source), SourceLen, nil, 0);\r
    Result := SysAllocStringLen(nil, ResultLen);\r
    MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,\r
      Result, ResultLen);\r
  end;\r
end;\r
{+}\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewRichEdit]\r
function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;\r
begin\r
  new( Result, CreateRichEdit( AParent, Options ) );\r
end;\r
//[END NewRichEdit]\r
{$ELSE not_USE_CONSTRUCTORS}\r
\r
//[FUNCTION NewRichEdit]\r
{$IFDEF ASM_VERSION}\r
const RichEdit20A: array[0..11] of Char = ('R','i','c','h','E','d','i','t','2','0','A',#0 );\r
      RichEd20_DLL: array[ 0..12] of Char = ('R','I','C','H','E','D','2','0','.','D','L','L',#0 );\r
function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;\r
const deltaChr = 24; // sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat );\r
      deltaPar = sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat );\r
asm\r
        PUSHAD\r
        CALL     OleInit\r
        TEST     EAX, EAX\r
        POPAD\r
        JZ       @@new1\r
        PUSH     [RichEditClass]\r
        MOV      [RichEditClass], offset[RichEdit20A]\r
        PUSH     [RichEditLib]\r
        MOV      [RichEditLib], offset[RichEd20_DLL]\r
        CALL     NewRichEdit1\r
        POP      [RichEditLib]\r
        POP      [RichEditClass]\r
        MOV      byte ptr [EAX].TControl.fCharFmtDeltaSz, deltaChr\r
        MOV      byte ptr [EAX].TControl.fParaFmtDeltaSz, deltaPar\r
        RET\r
@@new1: CALL     NewRichEdit1\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;\r
var OldRichEditClass, OldRichEditLib: PChar;\r
begin\r
  if OleInit then\r
  begin\r
    OldRichEditClass := RichEditClass;\r
    RichEditClass := 'RichEdit20A';\r
    OldRichEditLib := RichEditLib;\r
    RichEditLib := 'RICHED20.DLL';\r
    Result := NewRichEdit1( AParent, Options );\r
    Result.fCharFmtDeltaSz := 24; //sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat );\r
                           // sizeof( TCharFormat2 ) is calculated incorrectly\r
    Result.fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat );\r
    RichEditClass := OldRichEditClass;\r
    RichEditLib := OldRichEditLib;\r
  end\r
     else\r
    Result := NewRichEdit1( AParent, Options );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewRichEdit]\r
\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
//=====================================================================//\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ TControl }\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.Init]\r
procedure TControl.Init;\r
const\r
  IniStyle = WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or\r
            WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or\r
            WS_BORDER or WS_THICKFRAME;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CALL     TObj.Init\r
        MOV      EDX, offset WndProcDummy\r
        MOV      [EBX].fOnDynHandlers, EDX\r
        MOV      [EBX].fWndProcKeybd, EDX\r
        MOV      [EBX].fWndProcResizeFlicks, EDX\r
        MOV      [EBX].fPass2DefProc, EDX\r
//****        MOV      [EBX].fDefWndProc, offset DefWindowProc\r
        MOV      [EBX].fWndFunc, offset WndFunc\r
        MOV      EDX, offset ClearText\r
        MOV      [EBX].fCommandActions.aClear, EDX\r
        INC      dword ptr [EBX].fWindowed\r
        MOV      EDX, offset DummyObjProc\r
        MOV      [EBX].fControlClick, EDX\r
        MOV      EDX, clBtnFace\r
        MOV      [EBX].fColor, EDX\r
        MOV      DL, clWindowText and $FF\r
        MOV      [EBX].fTextColor, EDX\r
        MOV      byte ptr [EBX].fMargin, 2\r
        INC      dword ptr [EBX].fCtl3D\r
        INC      dword ptr [EBX].fCtl3Dchild\r
        DEC      byte ptr [EBX].fAlphaBlend\r
        CALL     NewList\r
        MOV      [EBX].fChildren, EAX\r
        MOV      byte ptr[EBX].fClsStyle, CS_OWNDC\r
        MOV      [EBX].fStyle, IniStyle\r
        INC      dword ptr[EBX].fExStyle+2\r
        INC      dword ptr[EBX].fVisible\r
        INC      dword ptr[EBX].fEnabled\r
        CALL     NewList\r
        MOV      [EBX].fDynHandlers, EAX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.Init;\r
begin\r
  inherited;\r
  fOnDynHandlers := WndProcDummy;\r
  fWndProcKeybd := WndProcDummy;\r
  fWndProcResizeFlicks := WndProcDummy;\r
  fPass2DefProc := WndProcDummy;\r
//****  fDefWndProc := @DefWindowProc;\r
  fWndFunc := @ WndFunc;\r
  fCommandActions.aClear := ClearText;\r
  fWindowed := True;\r
  fControlClick := DummyObjProc;\r
  fColor := clBtnFace;\r
  fTextColor := clWindowText;\r
  fMargin := 2;\r
  fCtl3D := True;\r
  fCtl3Dchild := True;\r
  fAlphaBlend := 255;\r
  fChildren := NewList;\r
  fClsStyle := CS_OWNDC;\r
  fStyle := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or\r
            WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or\r
            WS_BORDER or WS_THICKFRAME;\r
  fExStyle := WS_EX_CONTROLPARENT;\r
  fVisible := True;\r
  fEnabled := True;\r
  fDynHandlers := NewList;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[PROCEDURE CallTControlInit]\r
procedure CallTControlInit( Ctl: PControl );\r
begin\r
  Ctl.Init;\r
end;\r
//[END CallTControlInit]\r
\r
//[procedure TControl.InitParented]\r
procedure TControl.InitParented( AParent: PControl );\r
const IStyle = WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or\r
            WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or\r
            WS_BORDER or WS_THICKFRAME;\r
      IExStyle = WS_EX_CONTROLPARENT;\r
      IClsStyle = CS_OWNDC;\r
      int_IDC_ARROW = integer( IDC_ARROW );\r
asm\r
        PUSH      EAX\r
        PUSH      EDX\r
        CALL      CallTControlInit\r
        POP       EDX\r
        POP       EAX\r
        TEST      EDX, EDX\r
        JZ        @@0\r
        MOV       ECX, [EDX].fColor\r
        MOV       [EAX].fColor, ECX\r
@@0:\r
        CALL      SetParent\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.InitParented( AParent: PControl );\r
begin\r
  Init;\r
  if AParent <> nil then\r
     fColor := AParent.fColor;\r
  Parent := AParent;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TControl.Destroy]\r
destructor TControl.Destroy;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CALL     TControl.ParentForm\r
        TEST     EAX, EAX\r
        JZ       @@cur_ctl_removed\r
        CMP      [EAX].TControl.fCurrentControl, EBX\r
        JNE      @@cur_ctl_removed\r
        XOR      EDX, EDX\r
        MOV      [EAX].TControl.fCurrentControl, EDX\r
@@cur_ctl_removed:\r
\r
        MOV      ECX, [EBX].fHandle\r
        JECXZ    @@wndhidden\r
        PUSH     SW_HIDE\r
        PUSH     ECX\r
        CALL     ShowWindow\r
@@wndhidden:\r
\r
        MOV      EAX, EBX\r
        CALL     Final\r
        MOV      EAX, EBX\r
        CALL     DestroyChildren\r
\r
        XOR      ECX, ECX\r
        CMP      [EBX].fDestroying, CL\r
        JNZ      @@destroyed\r
\r
        XCHG     CL, [EBX].fCtlClsNameChg\r
        JECXZ    @@skip_free_clsname\r
        MOV      EAX, [EBX].fControlClassName\r
        CALL     System.@FreeMem\r
@@skip_free_clsname:\r
\r
        INC      [EBX].fDestroying\r
        MOV      EAX, [EBX].fFont\r
        CALL     TObj.Free\r
        MOV      EAX, [EBX].fBrush\r
        CALL     TObj.Free\r
        MOV      EAX, [EBX].fCanvas\r
        CALL     TObj.Free\r
\r
        XOR      ECX, ECX\r
\r
        MOV      [EBX].fFont, ECX        // +YS\r
        MOV      [EBX].fBrush, ECX       // +YS\r
        MOV      [EBX].fCanvas, ECX      // +YS\r
\r
        XCHG     ECX, [EBX].fCustomData\r
        JECXZ    @@custfree\r
        XCHG     EAX, ECX\r
        CALL     System.@FreeMem\r
@@custfree:\r
        MOV      EAX, [EBX].fCustomObj\r
        CALL     TObj.Free\r
\r
        MOV      EAX, [EBX].fHandle\r
        TEST     EAX, EAX\r
        JZ       @@free_fields\r
\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EBX].fAccelTable\r
        JECXZ    @@accelTable_destroyed\r
        PUSH     ECX\r
        CALL     DestroyAcceleratorTable\r
@@accelTable_destroyed:\r
        MOV      EAX, [EBX].fMenuObj\r
        CALL     TObj.Free\r
@@destroy_img_list:\r
        MOV      EAX, [EBX].fImageList\r
        TEST     EAX, EAX\r
        JZ       @@img_list_destroyed\r
        CALL     TObj.Free\r
        JMP      @@destroy_img_list\r
@@img_list_destroyed:\r
\r
        PUSH     [EBX].fHandle\r
        CALL     IsWindow\r
        TEST     EAX, EAX\r
        JZ       @@destroy2\r
\r
        PUSH     EAX\r
        PUSH     1\r
        PUSH     WM_SETICON\r
        PUSH     [EBX].fHandle\r
        CALL     SendMessage\r
        TEST     EAX, EAX\r
        JZ       @@icoremoved\r
        CMP      [EBX].fIconShared, 0\r
        JNZ      @@icoremoved\r
        PUSH     EAX\r
        CALL     DestroyIcon\r
@@icoremoved:\r
//********************************************************** Remarked By M.Gerasimov\r
//      PUSH     offset[ID_SELF]\r
//      PUSH     [EBX].fHandle\r
//      CALL     RemoveProp\r
//********************************************************** Remarked By M.Gerasimov\r
        CMP      [EBX].fNCDestroyed, 0\r
        JNZ      @@destroy2\r
        PUSH     [EBX].fHandle\r
        CALL     DestroyWindow\r
@@destroy2:\r
        XOR      EAX, EAX\r
        MOV      [EBX].fHandle, EAX\r
\r
@@free_fields:\r
        MOV      EAX, [EBX].fCaption\r
        TEST     EAX, EAX\r
        JZ       @@caption_freed\r
        CALL     System.@FreeMem\r
@@caption_freed:\r
        MOV      EAX, [EBX].fStatusTxt\r
        TEST     EAX, EAX\r
        JZ       @@statusTxt_freed\r
        CALL     System.@FreeMem\r
@@statusTxt_freed:\r
        MOV      ECX, [EBX].fParent\r
        JECXZ    @@removed_from_parent\r
        CMP      [ECX].fCurrentControl, EBX\r
        JNE      @@removefromParent\r
        XOR      EAX, EAX\r
        MOV      [ECX].fCurrentControl, EAX\r
@@removefromParent:\r
        MOV      EAX, [ECX].fChildren\r
        //PUSH     EAX\r
        MOV      EDX, EBX\r
        {CALL     TList.IndexOf\r
        TEST     EAX, EAX\r
        POP      EDX\r
        JL       @@removed_from_parent\r
        XCHG     EAX, EDX\r
        CALL     TList.Delete}\r
        CALL     TList.Remove\r
@@removed_from_parent:\r
        MOV      ECX, [EBX].fTmpBrush\r
        JECXZ    @@tmpBrush_deleted\r
        PUSH     ECX\r
        CALL     DeleteObject\r
@@tmpBrush_deleted:\r
\r
        PUSH     EBX\r
        PUSH     [EBX].fChildren\r
        PUSH     [EBX].fTBttCmd\r
        PUSH     [EBX].fTBttTxt\r
        PUSH     [EBX].fTmpFont\r
        PUSH     [EBX].fDynHandlers\r
        MOV      BL, 5\r
@@freeloo:\r
        POP      EAX\r
        CALL     TObj.Free\r
        DEC      BL\r
        JNZ      @@freeloo\r
        POP      EBX\r
        LEA      EAX, [EBX].fREUrl\r
        CALL     System.@LStrClr\r
        XCHG     EAX, EBX\r
        CALL     TObj.Destroy\r
@@destroyed:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TControl.Destroy;\r
var I: Integer;\r
    F: PControl;\r
    Ico: HIcon;\r
begin\r
   {$IFDEF USE_MHTOOLTIP}\r
   {$DEFINE destroy}\r
   {$I KOLMHToolTip}\r
   {$UNDEF destroy}\r
   {$ENDIF USE_MHTOOLTIP}\r
   F := ParentForm; // or Applet - for form ???\r
   if F <> nil then\r
   if F.FCurrentControl = @Self then\r
      F.FCurrentControl := nil;\r
\r
   if FHandle <> 0 then\r
      ShowWindow( fHandle, SW_HIDE );\r
\r
   Final;\r
   DestroyChildren;\r
\r
   if not fDestroying then\r
   begin\r
     fDestroying := True;\r
\r
      if fCtlClsNameChg then\r
      begin\r
        FreeMem( fControlClassName );\r
        fCtlClsNameChg := FALSE;\r
      end;\r
\r
     fFont.Free;\r
     fFont := nil;\r
     fBrush.Free;\r
     fBrush := nil;\r
     fCanvas.Free;\r
     fCanvas := nil;\r
\r
     if fCustomData <> nil then\r
       FreeMem( fCustomData );\r
     fCustomData := nil;\r
     fCustomObj.Free;\r
     fCustomObj := nil;\r
\r
     if fHandle <> 0 then\r
     begin\r
{$IFNDEF NEW_MENU_ACCELL}\r
       if fAccelTable <> 0 then\r
       begin\r
         DestroyAcceleratorTable( fAccelTable );\r
         fAccelTable := 0;\r
       end;\r
{$ENDIF}\r
       fMenuObj.Free;\r
       while fImageList <> nil do\r
         fImageList.Free;\r
       I := fHandle;\r
       if IsWindow( I ) then\r
       begin\r
         Ico := SendMessage( I, WM_SETICON, 1, 0 );\r
         if Ico <> 0 then\r
         if not fIconShared then\r
           DestroyIcon( Ico );\r
//********************************************************** Remarked By M.Gerasimov\r
//       RemoveProp( I, ID_SELF );\r
//********************************************************** Remarked By M.Gerasimov\r
         if not fNCDestroyed then\r
         begin\r
           {$IFDEF DEBUG_ENDSESSION}\r
           if EndSession_Initiated then\r
             LogFileOutput( GetStartDir + 'es_debug.txt',\r
                            'DESTROYING HWND:' + Int2Str( I ) );\r
           {$ENDIF}\r
           DestroyWindow( I );\r
         end;\r
       end\r
       {$IFDEF TEST_CLOSE}\r
         else\r
         asm\r
           int 3\r
         end;\r
       {$ENDIF}\r
       ;\r
       fHandle := 0;\r
     end;\r
\r
     if fTmpBrush <> 0 then\r
        DeleteObject( fTmpBrush );\r
     fTmpBrush := 0;\r
\r
     if FCaption <> nil then\r
        FreeMem( FCaption );\r
     if fStatusTxt <> nil then\r
        FreeMem( fStatusTxt );\r
\r
     if fParent <> nil then\r
     begin\r
        {I := fParent.fChildren.IndexOf( @Self );\r
        if I >= 0 then\r
           fParent.fChildren.Delete( I );}\r
        fParent.fChildren.Remove( @Self );\r
        if fParent.fCurrentControl = @Self then\r
          fParent.fCurrentControl := nil;\r
     end;\r
\r
     fChildren.Free;\r
     fTBttCmd.Free;\r
     fTBttTxt.Free;\r
     fTmpFont.Free;\r
     fDynHandlers.Free;\r
     fREUrl := '';\r
     inherited;\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
   {$IFDEF USE_MHTOOLTIP}\r
   {$DEFINE code}\r
   {$I KOLMHToolTip}\r
   {$UNDEF code}\r
   {$ENDIF}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetEnabled]\r
procedure TControl.SetEnabled( Value: Boolean );\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        MOVZX    EDX, DL\r
        PUSH     EDX\r
        CALL     GetEnabled\r
        POP      EDX\r
        CMP      AL, DL\r
        JZ       @@exit\r
        MOV      [EBX].fEnabled, DL\r
        TEST     EDX, EDX\r
        JNZ      @@andnot\r
        OR       byte ptr [EBX].fStyle + 3, 8\r
        JMP      @@1\r
@@andnot:\r
        AND      byte ptr [EBX].fStyle + 3, $F7\r
@@1:\r
        MOV      ECX, [EBX].fHandle\r
        JECXZ    @@exit\r
\r
        PUSH     EDX\r
        PUSH     ECX\r
        CALL     EnableWindow\r
\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetEnabled( Value: Boolean );\r
begin\r
   if GetEnabled = Value then Exit;\r
   fEnabled := Value;\r
   if Value then\r
      fStyle := fStyle and not WS_DISABLED\r
   else\r
      fStyle := fStyle or WS_DISABLED;\r
   if fHandle <> 0 then\r
      EnableWindow( fHandle, fEnabled );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetParentWindow]\r
function TControl.GetParentWindow: HWnd;\r
asm\r
        MOV       EAX, [EAX].fParent\r
        TEST      EAX, EAX\r
        {\r
        JZ        @@exit\r
\r
        CALL      TControl.GetWindowHandle\r
@@exit: --- replaced with following (6 bytes instead of 7):\r
        }\r
        JNZ       TControl.GetWindowHandle\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetParentWindow: HWnd;\r
begin\r
   Result := 0;\r
   if fParent = nil then Exit;\r
   Result := fParent.GetWindowHandle;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
function TControl.GetWindowHandle: HWnd;\r
asm\r
         MOV      ECX, [EAX].fHandle\r
         JECXZ    @@1\r
         XCHG     EAX, ECX\r
         RET\r
@@1:\r
         CMP      [EAX].fCreateVisible, 0\r
         JNZ      @@2\r
\r
         PUSH     EAX\r
         XOR      EDX, EDX\r
         CALL     TControl.Set_Visible\r
         POP      EAX\r
         PUSH     EAX\r
         //CALL     TControl.CreateWindow\r
         CALL     CallTControlCreateWindow\r
         { This is a call to Pascal piece of code, which\r
           calls virtual method TControl.CreateWindow }\r
         POP      EAX\r
\r
         INC      [EAX].fCreateHidden\r
         JMP      @@0\r
\r
@@2:     PUSH     EAX\r
         //CALL     TControl.CreateWindow\r
         CALL     CallTControlCreateWindow\r
         POP      EAX\r
@@0:\r
         MOV      EAX, [EAX].fHandle\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetWindowHandle: HWnd;\r
begin\r
   if fHandle = 0 then\r
   begin\r
     if not fCreateVisible then\r
     begin\r
       Set_Visible( False );\r
       CreateWindow; //virtual!!!\r
       fCreateHidden := True;\r
     end\r
        else\r
     CreateWindow; //virtual!!!\r
   end;\r
   Result := fHandle;\r
end;\r
{$ENDIF ASM_VERSION}\r
{-}\r
\r
{$IFDEF _D7orHigher}\r
// may be it was a good idea to replace CreateWindowEx,\r
// but Inprise forget about stdcall... In result, asm-version became broken.\r
//[API CreateWindowEx]\r
function CreateWindowEx(dwExStyle: DWORD; lpClassName: PChar;\r
  lpWindowName: PChar; dwStyle: DWORD; X, Y, nWidth, nHeight: Integer;\r
  hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: Pointer): HWND;\r
  stdcall; external user32 name 'CreateWindowExA';\r
{$ENDIF}\r
\r
{+}\r
{$IFDEF ASM_VERSION}\r
//[function TControl.CreateWindow]\r
function TControl.CreateWindow: Boolean;\r
const\r
  CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;\r
  CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;\r
  szWndClass = sizeof( TWndClass );\r
  int_IDC_ARROW = integer( IDC_ARROW );\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      ECX, [EBX].fParent\r
        JECXZ    @@chk_handle\r
        XCHG     EAX, ECX\r
        CALL     GetWindowHandle\r
        TEST     EAX, EAX\r
        JZ       @@ret_false\r
@@chk_handle:\r
        MOV      ECX, [EBX].fHandle\r
        JECXZ    @@prepare_Params\r
        MOV      DL, 0\r
        MOV      EAX, EBX\r
        CMP      [EBX].fCreateHidden, DL\r
        JZ       @@create_children\r
        CALL     CreateChildWindows\r
        MOV      EAX, EBX\r
        MOV      DL, 1\r
        CALL     Set_Visible\r
        MOV      [EBX].fCreateHidden, 0\r
        JMP      @@ret_true\r
@@create_children:\r
        CALL     CreateChildWindows\r
@@ret_true:\r
        MOV      AL, 1\r
        POP      EBX\r
        RET\r
@@prepare_params:\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
\r
        PUSH     ECX        // Params.WindowClass.lpszClassName := nil\r
        PUSH     ECX        // Params.WindowClass.lpszMenuName := nil\r
        PUSH     ECX        // Params.WindowClass.hbrBackground := 0\r
        PUSH     int_IDC_ARROW\r
        PUSH     ECX\r
        CALL     LoadCursor\r
        PUSH     EAX        // Params.WindowClass.hCursor := LoadCursor( 0, IDC_ARROW )\r
        XOR      ECX, ECX\r
        PUSH     ECX        // Params.WindowClass.hIcon := 0\r
        PUSH     [hInstance]// Params.WindowClass.hInstance := hInstance\r
        PUSH     ECX        // Params.WindowClass.cbWndExtra := 0\r
        PUSH     ECX        // Params.WindowClass.cbClsExtra := 0\r
        //PUSH     offset DefWindowProc // Params.WindowClass.lpfnWndProc := @DefWindowProc\r
        PUSH     [EBX].fDefWndProc     // Params.WindowClass.lpfnWndProc := fDefWndProc\r
        PUSH     [EBX].fClsStyle       // Params.WindowClass.style := fStyle\r
        ADD      ESP, -64\r
        PUSH     ECX\r
        MOV      EAX, EBX\r
        MOV      EDX, ESP\r
        CALL     get_ClassName\r
        POP      EDX\r
        MOV      EAX, ESP\r
        PUSH     EDX\r
        //CALL     StrPCopy    // StrPCopy( Params.WinClsNamBuf, ClassName )\r
        CALL     StrCopy\r
        CALL     RemoveStr\r
        PUSH     0           // Params.Param := nil\r
        PUSH     [hInstance] // Params.Inst := fInstance\r
        PUSH     [EBX].fMenu // Params.Menu := fMenu\r
        MOV      DL, 1\r
        MOV      EAX, EBX\r
        CALL     GetParentWnd\r
        PUSH     EAX         // Params.WndParent := GetParentWnd( True )\r
\r
        MOV      ECX, CW_USEDEFAULT\r
        MOV      EAX, [EBX].fBoundsRect.Bottom\r
        MOV      EDX, [EBX].fBoundsRect.Top\r
        SUB      EAX, EDX\r
        JNZ      @@1\r
        MOV      EAX, ECX\r
@@1:    PUSH     EAX         // Params.Height := Height | CW_UseDefault\r
        MOV      EAX, [EBX].fBoundsRect.Right\r
        SUB      EAX, [EBX].fBoundsRect.Left\r
        {$IFDEF USE_CMOV}\r
        CMOVZ    EAX, ECX\r
        {$ELSE}\r
        JNZ      @@2\r
        MOV      EAX, ECX\r
@@2:    {$ENDIF}\r
\r
        PUSH     EAX         // Params.Width := Width | CW_UseDefault\r
        MOV      EAX, [EBX].fBoundsRect.Left\r
        CMP      [EBX].fIsControl, CL\r
        JNZ      @@3\r
        TEST     byte ptr [EBX].fChangedPosSz, 3\r
        JNZ      @@3\r
        MOV      EDX, ECX\r
        XCHG     EAX, ECX\r
@@3:    PUSH     EDX         // Params.Y := Top | CW_UseDefault\r
        PUSH     EAX         // Params.X := Left | CW_UseDefault\r
        PUSH     [EBX].fStyle    // Params.Style := fStyle\r
        PUSH     [EBX].fCaption  // Params.Caption := fCaption\r
        LEA      EAX, [ESP+40]\r
        PUSH     EAX         // Params.WinClassName := @Params.WinClsNamBuf\r
        PUSH     [EBX].fExStyle  // Params.ExStyle := fExStyle\r
\r
        MOV      ECX, [EBX].fControlClassName\r
        JECXZ    @@registerClass\r
        LEA      EAX, [ESP].TCreateWndParams.WindowClass\r
        PUSH     EAX           // @Params.WindowClass\r
        PUSH     ECX           // fControlClassName\r
        PUSH     [hInstance]   // hInstance\r
        CALL     GetClassInfo\r
        MOV      EAX, [ESP].TCreateWndParams.Inst\r
        MOV      [ESP].TCreateWndParams.WindowClass.hInstance, EAX\r
        AND      [ESP].TCreateWndParams.WindowClass.style, not CS_OFF\r
@@registerClass:\r
        CMP      [EBX].fDefWndProc, 0\r
        JNE      @@fDefWndProc_ready\r
        MOV      EAX, [ESP].TCreateWndParams.WindowClass.lpfnWndProc\r
        MOV      [EBX].fDefWndProc, EAX\r
@@fDefWndProc_ready:\r
        MOV      ECX, [ESP].TCreateWndParams.WndParent\r
        INC      ECX\r
        LOOP     @@registerClass1\r
        TEST     byte ptr [ESP].TCreateWndParams.Style+3, $40\r
        XCHG     EAX, ECX\r
        JNZ      @@fin\r
@@registerClass1:\r
        MOV      EAX, [ESP].TCreateWndParams.WinClassName\r
        MOV      EDX, [ESP].TCreateWndParams.WindowClass.hInstance\r
        ADD      ESP, -szWndClass\r
        PUSH     ESP\r
        PUSH     EAX\r
        PUSH     EDX\r
        CALL     GetClassInfo\r
        ADD      ESP, szWndClass\r
        TEST     EAX, EAX\r
        JNZ      @@registered\r
        MOV      EAX, [ESP].TCreateWndParams.WinClassName\r
        MOV      [ESP].TCreateWndParams.WindowClass.lpszClassName, EAX\r
        MOV      [ESP].TCreateWndParams.WindowClass.lpfnWndProc, offset WndFunc\r
        LEA      EAX, [ESP].TCreateWndParams.WindowClass\r
        PUSH     EAX\r
        CALL     RegisterClass\r
        TEST     EAX, EAX\r
        JZ       @@fin\r
@@registered:\r
        MOV      [CreatingWindow], EBX\r
        CALL     CreateWindowEx\r
        MOV      [EBX].fHandle, EAX\r
        TEST     EAX, EAX\r
        JZ       @@fin\r
        PUSH     EAX\r
        PUSH     offset ID_SELF\r
        PUSH     EAX\r
\r
   //SendMessage(fHandle,WM_UPDATEUISTATE,UIS_CLEAR or (UISF_HIDEFOCUS shl 16),0);\r
        PUSH     0\r
        PUSH     $10002 //UIS_CLEAR or (UISF_HIDEFOCUS shl 16)\r
        PUSH     $0128  //WM_UPDATEUISTATE\r
        PUSH     EAX\r
        CALL     SendMessage\r
\r
        CALL     GetProp\r
        XCHG     ECX, EAX\r
        POP      EAX\r
        INC      ECX\r
        LOOP     @@propSet\r
        MOV      [CreatingWindow], ECX\r
        PUSH     EBX\r
        PUSH     offset ID_SELF\r
        PUSH     EAX\r
        CALL     SetProp\r
@@propSet:\r
        CMP      [EBX].fIsControl, 0\r
        JNZ      @@iconSet\r
        MOV      EAX, EBX\r
        CALL     GetIcon\r
        PUSH     EAX\r
        PUSH     1\r
        PUSH     WM_SETICON\r
        PUSH     EBX\r
        CALL     Perform\r
@@iconSet:\r
        MOV      ECX, [EBX].fCreateWndExt\r
        JECXZ    @@dblbufcreate\r
        MOV      EAX, EBX\r
        CALL     ECX\r
@@dblbufcreate:\r
        MOV      EAX, EBX\r
        CALL     Dword Ptr [ Global_DblBufCreateWnd ]\r
@@applyfont:\r
        MOV      EAX, EBX\r
        CALL     ApplyFont2Wnd\r
        MOV      EAX, EBX\r
        CALL     ApplyFont2Wnd\r
        XCHG     EAX, EBX\r
        CALL     CreateChildWindows\r
        MOV      AL, 1\r
@@fin:\r
        MOV      ESP, EBP\r
        POP      EBP\r
@@ret_false:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.CreateWindow: Boolean;\r
const\r
  CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;\r
  CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;\r
var TempClass: TWndClass;\r
    Params: TCreateWndParams;\r
    ClassRegistered: Boolean;\r
    {$IFDEF _FPC}\r
    SClassName: String;\r
    {$ENDIF ASM_VERSION}\r
begin\r
   {$IFDEF DEBUG_CREATEWINDOW}\r
   LogFileOutput( GetStartDir + 'Session.log', 'TControl.CreateWindow, ' +\r
                  ' Self = ' + Int2Str( Integer( @ Self ) ) +\r
                  ' Caption = ' + fCaption +\r
                  ' fChildren = ' + Int2Hex( Integer( fChildren ), 4 ) +\r
                  ' ChildCount = ' + Int2Str( ChildCount ) );\r
   {$ENDIF DEBUG_CREATEWINDOW}\r
   Result := False;\r
   if fParent <> nil then\r
     if fParent.GetWindowHandle = 0 then\r
       Exit;\r
   if fHandle <> 0 then\r
   begin\r
     if fCreateHidden then\r
     begin\r
       CreateChildWindows;\r
       Set_Visible( True );\r
       fCreateHidden := False;\r
     end\r
        else\r
     begin\r
       CreateChildWindows;\r
     end;\r
     Result := True;\r
     Exit;\r
   end;\r
\r
   FillChar( Params, Sizeof( Params ), 0 );\r
   Params.Caption := PChar( FCaption );\r
   Params.Style := FStyle;\r
   if not fEnabled then\r
      Params.Style := Params.Style or WS_DISABLED;\r
   Params.ExStyle := FExStyle;\r
   Params.WindowClass.style := FClsStyle;\r
   {Params.WindowClass.lpfnWndProc := @ DefWindowProc;\r
   if fDefWndProc <> nil then} //+-+\r
     Params.WindowClass.lpfnWndProc := FDefWndProc;\r
   Params.WindowClass.hCursor := LoadCursor( 0, IDC_ARROW );\r
   Params.WindowClass.hInstance := hInstance;\r
   Params.Inst := hInstance;\r
   {$IFDEF _FPC}\r
   SClassName := SubClassName;\r
   StrCopy( Params.WinClsNamBuf, @ SClassName[ 1 ] );\r
   {$ELSE}\r
   StrCopy( Params.WinClsNamBuf, @ SubClassName[ 1 ] );\r
   {$ENDIF}\r
   Params.WinClassName := @Params.WinClsNamBuf[ 0 ];\r
   Params.WndParent := GetParentWnd( True );\r
   Params.Menu := fMenu;\r
   Params.X := fBoundsRect.Left;\r
   Params.Y := fBoundsRect.Top;\r
   Params.Width := fBoundsRect.Right - fBoundsRect.Left;\r
   if Params.Width = 0 then\r
     Params.Width := CW_UseDefault;\r
   Params.Height := fBoundsRect.Bottom - fBoundsRect.Top;\r
   if Params.Height = 0 then\r
     Params.Height := CW_UseDefault;\r
   if not fIsControl then\r
   begin\r
     if not LongBool( fChangedPosSz and 3 ) then\r
     begin\r
       Params.X := CW_UseDefault;\r
       Params.Y := CW_UseDefault;\r
     end;\r
   end;\r
\r
    if fControlClassName <> nil then\r
    begin // SUBCLASSING WINDOW\r
      GetClassInfo( Params.WindowClass.hInstance, fControlClassName,\r
                    Params.WindowClass);\r
      Params.WindowClass.hInstance := Params.Inst;\r
      Params.WindowClass.style := Params.WindowClass.style\r
                               and not CS_OFF or CS_ON;\r
    end;\r
\r
   if FDefWndProc = nil then //+\r
   {$IFDEF F_P}\r
      Move( Params.WindowClass.lpfnWndProc, FDefWndProc, Sizeof( Pointer ) );\r
   {$ELSE}\r
      FDefWndProc := Params.WindowClass.lpfnWndProc;\r
   {$ENDIF}\r
   if (Params.WndParent = 0) and (Params.Style and WS_CHILD <> 0) then Exit;\r
   ClassRegistered := GetClassInfo( Params.WindowClass.hInstance,\r
                      Params.WinClassName, TempClass );\r
   if not ClassRegistered then\r
   begin\r
      Params.WindowClass.lpszClassName := Params.WinClassName;\r
      Params.WindowClass.lpfnWndProc := fWndFunc;\r
      if RegisterClass( Params.WindowClass ) = 0 then Exit;\r
   end;\r
   {$IFDEF DEBUG_CREATEWINDOW}\r
   LogFileOutput( GetStartDir + 'Session.log',\r
                  ' ExStyle=' + Int2Hex( Params.ExStyle, 4 ) +\r
                  ' WinClassName=' + Params.WinClassName +\r
                  ' Caption=' + Params.Caption +\r
                  ' Style=' + Int2Hex( Params.Style, 4 ) +\r
                  ' X=' + Int2Str( Params.X ) +\r
                  ' Y=' + Int2Str( Params.Y ) +\r
                  ' Width=' + Int2Str( Params.Width ) +\r
                  ' Height=' + Int2Str( Params.Height ) +\r
                  ' WndParent=' + Int2Str( Params.WndParent ) +\r
                  ' Menu=' + Int2Str( Params.Menu ) +\r
                  ' hInstance=' + Int2Str( Params.WindowClass.hInstance ) +\r
                  ' Param=' + Int2Str( Integer( Params.Param ) )\r
                   );\r
   {$ENDIF}\r
   CreatingWindow := @Self;\r
   fHandle := CreateWindowEx( Params.ExStyle, Params.WinClassName,\r
                              Params.Caption, Params.Style, Params.X, Params.Y,\r
                              Params.Width, Params.Height, Params.WndParent,\r
                              Params.Menu, Params.WindowClass.hInstance,\r
                              Params.Param );\r
   if fHandle = 0 then Exit;\r
   SendMessage( fHandle, $0128 {WM_UPDATEUISTATE},\r
                2 {UIS_CLEAR} or (1 {UISF_HIDEFOCUS} shl 16),0);\r
   if GetProp(FHandle,ID_SELF) = 0 then\r
   begin\r
      CreatingWindow := nil;\r
      SetProp(FHandle, ID_SELF, THandle(@Self));\r
   end;\r
   //***\r
   if not fIsControl then\r
     SendMessage( fHandle, WM_SETICON, 1 {ICON_BIG}, GetIcon );\r
   if Assigned( FCreateWndExt ) then\r
      FCreateWndExt( @Self );\r
   Global_DblBufCreateWnd( @ Self );\r
   ApplyFont2Wnd;\r
   ApplyFont2Wnd;\r
\r
   CreateChildWindows;\r
   Result := True;\r
end;\r
{$ENDIF}\r
\r
//-\r
//[procedure TControl.CreateSubclass]\r
procedure TControl.CreateSubclass(var Params: TCreateParams;\r
  ControlClassName: PChar);\r
const\r
  CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;\r
  CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;\r
var\r
  SaveInstance: THandle;\r
begin\r
  if fControlClassName <> nil then\r
    with Params do\r
    begin\r
      SaveInstance := WindowClass.hInstance;\r
      if not GetClassInfo(HInstance, fControlClassName, WindowClass) and\r
        not GetClassInfo(0, fControlClassName, WindowClass)\r
        //and not GetClassInfo(HInstance {MainInstance}, fControlClassName, WindowClass)\r
      then\r
        GetClassInfo(WindowClass.hInstance, fControlClassName, WindowClass);\r
      WindowClass.hInstance := SaveInstance;\r
      WindowClass.style := WindowClass.style and not CS_OFF or CS_ON;\r
    end;\r
end;\r
\r
//[FUNCTION WndProcMous]\r
{$IFDEF ASM_VERSION}\r
function WndProcMouse(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
asm\r
         PUSH      EBX\r
         PUSH      ESI\r
         XCHG      EBX, EAX\r
\r
         XOR       ECX, ECX // Rslt not used. ECX <= Result = 0\r
         MOV       EAX, [EDX].TMsg.message\r
         SUB       AH, WM_MOUSEFIRST shr 8\r
         CMP       EAX, $20A - WM_MOUSEFIRST //WM_MOUSELAST - WM_MOUSEFIRST\r
         JA        @@exit\r
\r
         PUSH      dword ptr [EDX].TMsg.lParam // prepare X, Y\r
\r
         PUSHAD\r
\r
           PUSH      VK_MENU\r
           CALL      GetKeyState\r
           ADD       EAX, EAX\r
         POPAD\r
         XCHG        EAX, EDX\r
           MOV       EAX, [EAX].TMsg.wParam\r
\r
           JNC       @@noset_MKALT\r
           {$IFDEF PARANOIA}\r
           DB $0C, MK_ALT\r
           {$ELSE}\r
           OR        AL, MK_ALT\r
           {$ENDIF}\r
@@noset_MKALT:\r
\r
         PUSH      EAX             // prepare Shift\r
\r
         LEA       ESI, [EBX].TControl.fOnMouseDown\r
         CALL      dword ptr [EDX*4 + @@jump_table]\r
\r
@@call_evnt:\r
         PUSH      ECX             // prepare Button, StopHandling\r
         MOV       ECX, ESP        // ECX = @MouseData\r
\r
         CMP       word ptr [ESI].TMethod.Code+2, 0\r
         JZ        @@after_call\r
\r
         MOV       EDX, EBX        // EDX = Self_\r
         MOV       EAX, [ESI].TMethod.Data      // EAX = Target_\r
         CALL      dword ptr [ESI].TMethod.Code\r
\r
@@after_call:\r
         POP       ECX\r
         POP       EDX\r
         POP       EDX\r
         MOV       CL, CH           // Result := StopHandling\r
\r
@@exit:\r
         XCHG      EAX, ECX\r
         POP       ESI\r
         POP       EBX\r
         RET\r
\r
@@jump_table:\r
         DD Offset[@@MMove],Offset[@@LDown],Offset[@@LUp],Offset[@@LDblClk]\r
         DD Offset[@@RDown],Offset[@@RUp],Offset[@@RDblClk]\r
         DD Offset[@@MDown],Offset[@@MUp],Offset[@@MDblClk],Offset[@@MWheel]\r
\r
@@MDown: INC       ECX\r
@@RDown: INC       ECX\r
@@LDown: INC       ECX\r
         //LEA       ESI, [EBX].TControl.fOnMouseDown\r
         RET\r
\r
@@MUp:   INC       ECX\r
@@RUp:   INC       ECX\r
@@LUp:   INC       ECX\r
         //LEA       ESI, [EBX].TControl.fOnMouseUp\r
         LODSD\r
         LODSD\r
         RET\r
\r
@@MMove: LEA       ESI, [EBX].TControl.fOnMouseMove\r
         //ADD       ESI, 16\r
         RET\r
\r
@@MDblClk: INC     ECX\r
@@RDblClk: INC     ECX\r
@@LDblClk: INC     ECX\r
         LEA       ESI, [EBX].TControl.fOnMouseDblClk\r
         //ADD       ESI, 24\r
         RET\r
\r
@@MWheel:LEA       ESI, [EBX].TControl.fOnMouseWheel\r
         //ADD       ESI, 32\r
         //RET\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcMouse(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
var MouseData: TMouseEventData;\r
begin\r
  Result := False;\r
  if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= $20A {WM_MOUSELAST}) and\r
     (Msg.hwnd = Self_.fHandle) then\r
  with MouseData do\r
  begin\r
    Shift := Msg.wParam;\r
    if GetKeyState( VK_MENU ) < 0 then\r
       Shift := Shift or MK_ALT;\r
    X := LoWord( Msg.lParam );\r
    Y := HiWord( Msg.lParam );\r
    Button := mbNone;\r
    StopHandling := FALSE;\r
    Rslt := 0; // needed ?\r
    case Msg.message of\r
    WM_LBUTTONDOWN:\r
      if Assigned( Self_.OnMouseDown ) then\r
      begin\r
         Button := mbLeft;\r
         Self_.OnMouseDown( Self_, MouseData );\r
      end;\r
    WM_RBUTTONDOWN:\r
      if Assigned( Self_.OnMouseDown ) then\r
      begin\r
         Button := mbRight;\r
         Self_.OnMouseDown( Self_, MouseData );\r
      end;\r
    WM_MBUTTONDOWN:\r
      if Assigned( Self_.OnMouseDown ) then\r
      begin\r
         Button := mbMiddle;\r
         Self_.OnMouseDown( Self_, MouseData );\r
      end;\r
    WM_LBUTTONUP:\r
      if Assigned( Self_.OnMouseUp ) then\r
      begin\r
         Button := mbLeft;\r
         Self_.OnMouseUp( Self_, MouseData );\r
      end;\r
    WM_RBUTTONUP:\r
      if Assigned( Self_.OnMouseUp ) then\r
      begin\r
         Button := mbRight;\r
         Self_.OnMouseUp( Self_, MouseData );\r
      end;\r
    WM_MBUTTONUP:\r
      if Assigned( Self_.OnMouseUp ) then\r
      begin\r
         Button := mbMiddle;\r
         Self_.OnMouseUp( Self_, MouseData );\r
      end;\r
    WM_MOUSEMOVE:\r
      if Assigned( Self_.OnMouseMove ) then\r
         Self_.OnMouseMove( Self_, MouseData );\r
    WM_LBUTTONDBLCLK:\r
      if Assigned( Self_.OnMouseDblClk ) then\r
      begin\r
         Button := mbLeft;\r
         Self_.OnMouseDblClk( Self_, MouseData );\r
      end;\r
    WM_RBUTTONDBLCLK:\r
      if Assigned( Self_.OnMouseDblClk ) then\r
      begin\r
         Button := mbRight;\r
         Self_.OnMouseDblClk( Self_, MouseData );\r
      end;\r
    WM_MBUTTONDBLCLK:\r
      if Assigned( Self_.OnMouseDblClk ) then\r
      begin\r
         Button := mbMiddle;\r
         Self_.OnMouseDblClk( Self_, MouseData );\r
      end;\r
    $020A {WM_MOUSEWHEEL}:\r
      if Assigned( Self_.OnMouseWheel ) then\r
         Self_.OnMouseWheel( Self_, MouseData );\r
    else\r
      Exit; //Result := False;\r
    end;\r
    Result := StopHandling;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcMous]\r
\r
//[FUNCTION WndProcKeybd]\r
{$IFDEF ASM_VERSION}\r
function WndProcKeybd( Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
asm\r
        PUSH     EBX\r
        MOV      ECX, [EDX].TMsg.message\r
        SUB      CX, $100\r
        CMP      ECX, 5\r
        JA       @@fin_false\r
        XCHG     EBX, EAX   // EBX = @Self\r
        XCHG     EAX, ECX   // EAX = message - WM_KEYFIRST\r
        LEA      ECX, [EBX].TControl.fOnKeyUp\r
        JZ       @@event\r
        {$IFDEF PARANOIA}\r
        DB $34, 1\r
        {$ELSE}\r
        XOR      AL, 1\r
        {$ENDIF}\r
        JZ       @@event\r
        LEA      ECX, [EBX].TControl.fOnKeyDown\r
        {$IFDEF PARANOIA}\r
        DB $34, 1\r
        {$ELSE}\r
        XOR      AL, 1\r
        {$ENDIF}\r
        JZ       @@event\r
        {$IFDEF PARANOIA}\r
        DB $34, 4\r
        {$ELSE}\r
        XOR      AL, 4\r
        {$ENDIF}\r
        JZ       @@event\r
        LEA      ECX, [EBX].TControl.fOnChar\r
        {$IFDEF PARANOIA}\r
        DB $34, 6\r
        {$ELSE}\r
        XOR      AL, 2 xor 4\r
        {$ENDIF}\r
        JZ       @@event\r
        {$IFDEF PARANOIA}\r
        DB $34, 4\r
        {$ELSE}\r
        XOR      AL, 6 xor 2\r
        {$ENDIF}\r
        JNZ      @@fin_false\r
@@event:\r
        CMP      word ptr [ECX].TMethod.Code+2, 0\r
        JZ       @@fin_false\r
        PUSH     EDX\r
        PUSH     ECX\r
        LEA      ECX, [EDX].TMsg.wParam\r
        PUSH     ECX\r
        CALL     GetShiftState\r
        POP      ECX         // @wParam\r
        XCHG     EAX, [ESP]  // ShiftState; EAX=@event\r
        MOV      EDX, EBX    // @Self\r
        MOV      EBX, [EAX].TMethod.Code\r
        MOV      EAX, [EAX].TMethod.Data\r
        CALL     EBX\r
\r
        POP      EDX\r
        MOV      ECX, [EDX].TMsg.wParam\r
        JECXZ    @@fin_true\r
\r
@@fin_false:\r
        XOR      EAX, EAX\r
        POP      EBX\r
        RET\r
\r
@@fin_true:\r
        MOV      AL, 1\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcKeybd(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
var C : Char;\r
begin\r
  Result := True;\r
  case Msg.message of\r
    WM_KEYDOWN, WM_SYSKEYDOWN:\r
      if assigned( Self_.fOnKeyDown ) then\r
         Self_.fOnKeyDown( Self_, Msg.wParam, GetShiftState );\r
    WM_KEYUP, WM_SYSKEYUP:\r
      if assigned( Self_.fOnKeyUp ) then\r
         Self_.fOnKeyUp( Self_, Msg.wParam, GetShiftState );\r
    WM_CHAR, WM_SYSCHAR:\r
      if assigned( Self_.fOnChar ) then\r
      begin\r
         C := Char( Msg.wParam );\r
         Self_.fOnChar( Self_, C, GetShiftState );\r
         Msg.wParam := Integer( C );\r
      end;\r
    else begin\r
           Result := False;\r
           Exit;\r
         end;\r
  end;\r
  if Msg.wParam <> 0 then\r
    Result := False;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcKeybd]\r
\r
//[function WndProcDummy]\r
function WndProcDummy(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
begin\r
  Result := False;\r
end;\r
\r
//[procedure ExcludeCtlsWhichCannotDblBuf]\r
procedure ExcludeCtlsWhichCannotDblBuf( Sender, ParentCtl: PControl; DC: HDC );\r
var I: Integer;\r
    C: PControl;\r
    R, R1: TRect;\r
begin\r
  for I := 0 to ParentCtl.fChildren.Count-1 do\r
  begin\r
    C := ParentCtl.fChildren.Items[ I ];\r
    if C.fCannotDoubleBuf then\r
    begin\r
      GetWindowRect( Sender.fHandle, R );\r
      GetWindowRect( C.fHandle, R1 );\r
      OffsetRect( R1, -R.Left, -R.Top );\r
      ExcludeClipRect(DC, R1.Left, R1.Top, R1.Right, R1.Bottom);\r
    end\r
      else\r
      ExcludeCtlsWhichCannotDblBuf( Sender, C, DC );\r
  end;\r
end;\r
\r
//[procedure DoReleaseDblBufBmp]\r
procedure DoReleaseDblBufBmp( Sender: PControl );\r
begin\r
  if Sender.fDblBufBmp <> 0 then\r
    DeleteObject( Sender.fDblBufBmp );\r
end;\r
\r
//[procedure DoDrawChildrenDblBuffered]\r
procedure DoDrawChildrenDblBuffered( DC: HDC; WndParent: HWnd; const RectParent: TRect;\r
          W: HWnd );\r
var R, CR: TRect;\r
    Save: Integer;\r
    P, P0: TPoint;\r
begin\r
  while W <> 0 do\r
  begin\r
    if IsWindowVisible( W ) then\r
    begin\r
      Save := SaveDC( DC );\r
      GetWindowRect( W, R );\r
      GetWindowOrgEx( DC, P );\r
      SetWindowOrgEx( DC, P.x - ( R.Left - RectParent.Left ), P.y - ( R.Top - RectParent.Top ), nil );\r
      IntersectClipRect( DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top );\r
      SendMessage( W, WM_PRINT, DC, PRF_NONCLIENT );\r
      GetClientRect( W, CR );\r
      P0.x := 0; P0.y := 0;\r
      ClientToScreen( W, P0 );\r
      OffsetRect( CR, P0.x, P0.y );\r
      SetWindowOrgEx( DC, P.x - (CR.Left - RectParent.Left), P.y - (CR.Top - RectParent.Top), nil );\r
      IntersectClipRect( DC, 0, 0, CR.Right - CR.Left, CR.Bottom - CR.Top );\r
      SendMessage( W, WM_ERASEBKGND, DC, 0 );\r
      SendMessage( W, WM_PAINT, DC, 0 );\r
      DoDrawChildrenDblBuffered( DC, W, CR, GetWindow( W, GW_CHILD ) );\r
      RestoreDC( DC, Save );\r
    end;\r
    W := GetWindow( W, GW_HWNDNEXT );\r
  end;\r
end;\r
\r
//[procedure DoDrawDblBuffered]\r
procedure DoDrawDblBuffered( Sender: PControl );\r
var R: TRect;\r
    DC0, DC1, DC2: HDC;\r
    OldBmp: HBitmap;\r
    R2: TRect;\r
    P1, P2: TPoint;\r
    ClientOnly: Boolean;\r
    OldPaintDC: HDC;\r
{$IFDEF DEBUGDBLBUFF}\r
Tmp: PBitmap;\r
{$ENDIF}\r
begin\r
  if not GetUpdateRect( Sender.fHandle, R, FALSE ) then\r
    Exit; // nothing to paint\r
\r
  Sender.fDblBufPainting := TRUE;\r
\r
  ClientOnly := Sender.fIsForm {and (WinVer < wvNT)};\r
  if ClientOnly then\r
    GetClientRect( Sender.fHandle, R )\r
  else\r
  begin\r
    GetWindowRect( Sender.fHandle, R );\r
    OffsetRect( R, -R.Left, -R.Top );\r
  end;\r
\r
  DC0 := GetDC( Sender.fHandle );\r
  DC1 := CreateCompatibleDC( DC0 );\r
  if Sender.fDblBufBmp = 0 then\r
    Sender.Add2AutoFreeEx( TObjectMethod( MakeMethod( Sender, @ DoReleaseDblBufBmp ) ) );\r
  if (Sender.fDblBufW < R.Right) or (Sender.fDblBufH < R.Bottom) or\r
     (Sender.fDblBufW > R.Right + 32) or (Sender.fDblBufH > R.Bottom + 32) then\r
    if Sender.fDblBufBmp <> 0 then\r
    begin\r
      DeleteObject( Sender.fDblBufBmp );\r
      Sender.fDblBufBmp := 0;\r
    end;\r
  if Sender.fDblBufBmp = 0 then\r
  begin\r
    Sender.fDblBufBmp := CreateCompatibleBitmap( DC0, R.Right, R.Bottom );\r
    Sender.fDblBufW := R.Right;\r
    Sender.fDblBufH := R.Bottom;\r
  end;\r
  OldBmp := SelectObject( DC1,  Sender.fDblBufBmp );\r
\r
  OldPaintDC := Sender.fPaintDC;\r
  Sender.fPaintDC := DC1;\r
  if ClientOnly then\r
  begin\r
    GetClientRect( Sender.fHandle, R2 );\r
    P2.x := 0; P2.y := 0;\r
    ClientToScreen( Sender.fHandle, P2 );\r
    OffsetRect( R2, P2.x, P2.y );\r
    SendMessage( Sender.fHandle, WM_ERASEBKGND, DC1, 0 );\r
    SendMessage( Sender.fHandle, WM_PAINT, DC1, 0 );\r
    DoDrawChildrenDblBuffered( DC1, Sender.fHandle, R2,\r
                               GetWindow( Sender.fHandle, GW_CHILD ) );\r
  end\r
    else\r
  begin\r
    {Sender.Perform( WM_PRINT, DC1,\r
      PRF_CLIENT or PRF_NONCLIENT or PRF_ERASEBKGND or PRF_CHILDREN );}\r
    GetWindowRect( Sender.fHandle, R2 );\r
    DoDrawChildrenDblBuffered( DC1, Sender.fHandle, R2, Sender.fHandle );\r
  end;\r
  //Sender.fPaintDC := DC1;\r
\r
  DC2 := GetWindowDC( Sender.fHandle );\r
\r
  ExcludeCtlsWhichCannotDblBuf( Sender, Sender, DC2 );\r
\r
  P1.x := 0; P1.y := 0;\r
  if ClientOnly then\r
  begin\r
    GetWindowRect( Sender.fHandle, R2 );\r
    ClientToScreen( Sender.fHandle, P1 );\r
    P1.x := P1.x - R2.Left;\r
    P1.y := P1.y - R2.Top;\r
    GetClientRect( Sender.fHandle, R );\r
  end;\r
  BitBlt( DC2, P1.x, P1.y, R.Right, R.Bottom, DC1, 0, 0, SRCCOPY );\r
\r
{$IFDEF DEBUGDBLBUFF}\r
Tmp := NewDIBBitmap( R.Right, R.Bottom, pf16bit );\r
BitBlt( Tmp.Canvas.Handle, 0, 0, R.Right, R.Bottom, DC1, 0, 0, SRCCopy );\r
Tmp.SaveToFile( 'c:\tmp.bmp' );\r
Tmp.Free;\r
{$ENDIF}\r
\r
  ReleaseDC( Sender.fHandle, DC2 );\r
\r
  SelectObject( DC1, OldBmp );\r
  DeleteDC( DC1 );\r
  ReleaseDC( Sender.fHandle, DC0 );\r
\r
  Sender.fPaintDC := OldPaintDC;\r
  ValidateRect( Sender.fHandle, nil );\r
\r
  Sender.fDblBufPainting := FALSE;\r
end;\r
\r
//[function WndProcBufferedDraw]\r
function WndProcBufferedDraw( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Self_DblBufTopParent: PControl;\r
begin\r
  Result := False;\r
  //if AppletTerminated then Exit;\r
  case Msg.message of\r
  WM_ERASEBKGND:\r
    begin\r
      if Self_.fCannotDoubleBuf then Exit;\r
      if Self_.DblBufTopParent <> nil then\r
        // if the Control is not DoubleBuffered, and none of its Parent controls are\r
        // DoubleBuffered, than ignore this call in Global_OnBufferedDraw, and work\r
        // as usual.\r
      begin // Call made in WndProcBufferedDraw of the top DoubleBuffered\r
            // Parent control, while processing WM_PAINT\r
        if Self_.fTransparent\r
             // Handle opaque control as usual.\r
             // For transparent (child) controls, do nothing at all\r
             // in responce to WM_ERASEBKGND (just tell to the system, that\r
             // the operation completed).\r
        OR\r
             // If DoubleBuffered control or control's DoubleBuffered parent\r
             // is not painting now through buffer, just ignore the message\r
           not Self_.DblBufTopParent.fDblBufPainting\r
           then\r
        begin\r
          if Self_.fParent <> nil then\r
          begin\r
            Rslt := 1;\r
            Result := TRUE;\r
            Exit;\r
          end;\r
        end;\r
      end;\r
    end;\r
  WM_PAINT:\r
    begin\r
      if Self_.fCannotDoubleBuf then Exit;\r
      Self_DblBufTopParent := Self_.DblBufTopParent;\r
      if Self_DblBufTopParent = nil then\r
        // if the Control is not DoubleBuffered, and none of its Parent controls are\r
        // DoubleBuffered, than ignore this call in Global_OnBufferedDraw, and work\r
        // as usual.\r
        Exit;\r
      if Self_DblBufTopParent <> Self_ then\r
        // if one of the Parent controls is DoubleBuffered, than ignore this call\r
        // in Global_OnBufferedDraw, and work as usual (actually this allows to\r
        // paint children of the DoubleBuffered Parent control to be painted on\r
        // its buffer).\r
      begin\r
        if (not Self_DblBufTopParent.fDblBufPainting) or\r
           (Self_DblBufTopParent.fPaintDC = 0) then\r
        begin // Usual call. Ignore it.\r
          ValidateRect( Self_.fHandle, nil );\r
          //RedrawWindow( Self_.fHandle, nil, 0, RDW_VALIDATE ); experiment\r
          if not Self_DblBufTopParent.fDblBufPainting then\r
          begin\r
            Self_.DblBufTopParent.Invalidate;\r
            //RedrawWindow( Self_DblBufTopParent.fHandle, nil, 0, RDW_INVALIDATE ); exp.\r
            //RedrawWindow( Self_DblBufTopParent.fHandle, nil, 0, RDW_UPDATENOW );  exp.\r
          end;\r
          Rslt := 0;\r
          Result := True;\r
        end;\r
        Exit; // Call from DoDrawDblBuffered of the top doublebuffered Parent\r
      end;\r
      if Msg.wParam <> 0 then Exit;\r
      DoDrawDblBuffered( Self_ );\r
      Rslt := 0;\r
      Result := True;\r
    end;\r
  WM_NCPAINT:\r
    begin\r
      if Self_.fIsForm {and (WinVer < wvNT)} then Exit;\r
      if Self_.CannotDoubleBuf then Exit;\r
      Self_DblBufTopParent := Self_.DblBufTopParent;\r
      if Self_DblBufTopParent = nil then\r
        // if the Control is not DoubleBuffered, and none of its Parent controls are\r
        // DoubleBuffered, than ignore this call in Global_OnBufferedDraw, and work\r
        // as usual.\r
        Exit;\r
      //if Self_.DblBufTopParent <> Self_ then\r
        // if one of the Parent controls is DoubleBuffered, than ignore this call\r
        // in Global_OnBufferedDraw, and work as usual (actually this allows to\r
        // paint children of the DoubleBuffered Parent control to be painted on\r
        // its buffer).\r
      begin\r
        if not Self_DblBufTopParent.fDblBufPainting\r
        then\r
        begin // Usual call. Ignore it.\r
          //ValidateRect( Self_.fHandle, nil );\r
          Rslt := 0;\r
          Result := True;\r
        end;\r
      end;\r
    end;\r
  WM_SETTEXT:\r
    begin\r
      if Self_.DblBufTopParent = nil then Exit;\r
      if not Self_.fIsStaticControl then Exit;\r
      ShowWindow( Self_.fHandle, SW_HIDE );\r
      Rslt := DefWindowProc( Self_.fHandle, WM_SETTEXT, Msg.wParam, Msg.lParam );\r
      ShowWindow( Self_.fHandle, SW_SHOWNA );\r
      UpdateWindow( Self_.fHandle ); // necessary!!!\r
      Result := True;\r
    end;\r
  WM_HSCROLL, WM_VSCROLL, WM_WINDOWPOSCHANGED:\r
    begin\r
      if Self_.DblBufTopParent = nil then Exit;\r
      Self_.Invalidate;\r
    end;\r
  WM_COMMAND:\r
    case HiWord( Msg.wParam ) of\r
    LBN_SELCHANGE {, CBN_SELCHANGE }:\r
      begin\r
        if Self_.DblBufTopParent = nil then Exit;\r
        Self_.Invalidate;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
const\r
  MM_MCINOTIFY        = $3B9;\r
\r
{$IFDEF ASM_VERSION}\r
\r
{$DEFINE ASM_LOCAL}\r
{$IFDEF NEW_MODAL}\r
  {$UNDEF ASM_LOCAL}\r
{$ENDIF}\r
\r
{$ELSE}\r
\r
{$IFDEF ASM_LOCAL}\r
  {$UNDEF ASM_LOCAL}\r
{$ENDIF}\r
\r
{$ENDIF}\r
\r
{$IFDEF ASM_LOCAL}\r
//[function TControl.WndProc]\r
function TControl.WndProc( var Msg: TMsg ): Integer;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        XCHG     ESI, EAX\r
        MOV      EDI, EDX\r
        XOR      EAX, EAX\r
        CMP      EAX, [EDX].TMsg.hWnd\r
        JNE      @@1\r
        CMP      EAX, [ESI].TControl.fHandle\r
        JNE      @@1\r
        MOV      EAX, [EDX].TMsg.hWnd\r
        MOV      [ESI].TControl.fHandle, EAX\r
@@1:\r
        PUSH     0\r
        MOV      ECX, ESP\r
        MOV      EAX, ESI\r
        CALL     dword ptr [Global_OnBufferedDraw]\r
        TEST     AL, AL\r
        POP      EAX\r
        JNZ      @@pass2defproc\r
\r
        CMP      [AppletRunning], 0\r
        JZ       @@dyn2\r
        MOV      ECX, [Applet]\r
        JECXZ    @@dyn2\r
        CMP      ECX, ESI\r
        JE       @@dyn2\r
\r
        CALL     @@onmess\r
\r
@@dyn2: MOV      ECX, ESI\r
        CALL     @@onmess\r
\r
        MOV      EBX, [ESI].TControl.fOnDynHandlers\r
        MOV      EAX, ESI\r
        CALL     @@callonmes\r
\r
@@flicksproc:\r
        MOV      EAX, ESI\r
        MOV      EDX, EDI\r
        PUSH     0\r
        MOV      ECX, ESP\r
        CALL     dword ptr [ESI].TControl.fWndProcResizeFlicks\r
        TEST     AL, AL\r
        POP      EAX\r
        JNZ      @@pass2defproc\r
\r
        MOVZX    EAX, word ptr [EDI].TMsg.message\r
\r
        //CMP      word ptr [EDI].TMsg.message, WM_CLOSE\r
        CMP      AX, WM_CLOSE\r
//********************************************************** Changed By M.Gerasimov\r
//      JNE      @@chk_WM_NCDESTROY\r
        JNE      @@chk_WM_DESTROY\r
//********************************************************** Changed By M.Gerasimov\r
\r
        MOV      ECX, [ESI].TControl.fOnClose.TMethod.Code\r
        JECXZ    @@wm_close1\r
        MOV      EBX, ECX\r
        PUSH     1\r
        MOV      ECX, ESP\r
        MOV      EDX, ESI\r
        MOV      EAX, [ESI].TControl.fOnClose.TMethod.Data\r
        CALL     EBX\r
        POP      ECX\r
        INC      ECX\r
        LOOP     @@wm_close0\r
        CMP      [AppletRunning], CL\r
        JZ       @@wm_close0\r
        //XOR      EAX, EAX\r
        //MOV      [ESI].TControl.fModalResult, 0\r
        JMP      @@0pass2defproc\r
\r
/////////////////\r
@@onmess:\r
        MOV      EAX, [ECX].TControl.fOnMessage.TMethod.Data\r
        MOV      EBX, [ECX].TControl.fOnMessage.TMethod.Code\r
@@callonmes:\r
        TEST     EBX, EBX\r
        JNZ      @@onmess1 // @@dynmes1\r
@@2onmessret:\r
        RET\r
@@onmess1:\r
        PUSH     0\r
\r
        MOV      EDX, EDI\r
        MOV      ECX, ESP\r
        CALL     EBX\r
        TEST     AL, AL\r
\r
        POP      EAX\r
        JZ       @@2onmessret\r
        POP      EDX // pop retaddr\r
        JMP      @@pass2defproc\r
/////////////////\r
\r
@@wm_close0:\r
        XOR      EAX, EAX\r
        MOV      [ESI].TControl.fOnClose.TMethod.Code, EAX\r
@@wm_close1:\r
        MOV      EAX, ESI\r
        CALL     TControl.IsMainWindow\r
        TEST     AL, AL\r
        MOV      ECX, [Applet]\r
        JNZ      @@wm_close2\r
        CMP      ESI, ECX\r
        JNE      @@calldef\r
\r
@@wm_close2:\r
        JECXZ    @@postquit\r
        CMP      ECX, ESI\r
        JE       @@postquit\r
        PUSH     0\r
        PUSH     0\r
        PUSH     WM_CLOSE\r
        PUSH     ECX\r
        CALL     TControl.Perform\r
@@postquit:\r
        PUSH     0\r
        CALL     PostQuitMessage\r
        //XOR      EAX, EAX\r
        JMP      @@0pass2defproc\r
\r
//********************************************************** Added By M.Gerasimov\r
//*\r
@@chk_WM_DESTROY:\r
        {CMP      word ptr [EDI].TMsg.message, WM_DESTROY\r
        JNE      @@chk_WM_NCDESTROY\r
        PUSH     GW_CHILD\r
        PUSH     [ESI].fHandle\r
        CALL     GetWindow\r
        TEST     EAX,EAX\r
        JZ       @@chk_WM_NCDESTROY\r
@@RmvNext:\r
        PUSH     EAX\r
        PUSH     offset[ID_PREVPROC]\r
        PUSH     EAX\r
        CALL     GetProp\r
        TEST     EAX,EAX\r
        JZ       @@GetNextChild\r
        POP      EAX\r
        PUSH     EAX\r
        PUSH     offset[ID_PREVPROC]\r
        PUSH     EAX\r
        CALL     RemoveProp\r
@@GetNextChild:\r
        POP      EAX\r
        PUSH     GW_HWNDNEXT\r
        PUSH     EAX\r
        CALL     GetWindow\r
        TEST     EAX,EAX\r
        JNZ       @@RmvNext}\r
//*\r
//********************************************************** Added By M.Gerasimov\r
@@chk_WM_NCDESTROY:\r
        //CMP      word ptr [EDI].TMsg.message, WM_NCDESTROY\r
        CMP      AX, WM_NCDESTROY\r
        JNE      @@chk_CM_RELEASE\r
//********************************************************** Added By M.Gerasimov\r
//*\r
        PUSH     offset[ID_SELF]\r
        PUSH     [ESI].fHandle\r
        CALL     RemoveProp\r
//*\r
//********************************************************** Added By M.Gerasimov\r
\r
        MOV      ECX, [Applet]\r
        JECXZ    @@nc_destroy1\r
        MOV      EAX, [ESI].TControl.fHandle\r
        CMP      EAX, [ECX].TControl.fHandle\r
        JE       @@calldef\r
@@nc_destroy1:\r
        MOV      EAX, ESI\r
        CALL     TControl.IsMainWindow\r
        TEST     AL, AL\r
        JZ       @@nc_destroy2\r
        PUSH     0\r
        PUSH     0\r
        PUSH     CM_RELEASE\r
        PUSH     [ESI].TControl.fHandle\r
        CALL     PostMessage\r
        JMP      @@calldef\r
\r
@@nc_destroy2:\r
        MOV      EAX, [ESI].TControl.fParent\r
        CMP      EAX, [Applet]\r
        JNE      @@calldef\r
\r
        MOV      [ESI].TControl.fNCDestroyed, 1\r
@@do_free:\r
        XCHG     EAX, ESI\r
        CALL     TObj.Free\r
\r
        XOR      EAX, EAX\r
        JMP      @@exit // WM_NCDESTROY and CM_RELEASE\r
                        // is not a subject to pass it\r
                        // to fPass2DefProc\r
\r
@@chk_CM_RELEASE:\r
        //CMP      word ptr [EDI].TMsg.message, CM_RELEASE\r
        CMP      AX, CM_RELEASE\r
        JNE      @@chk_WM_SIZE\r
\r
        MOV      [ESI].TControl.fDestroying, 1\r
        JMP      @@do_free\r
\r
@@chk_WM_SIZE:\r
        //CMP      word ptr [EDI].TMsg.message, WM_SIZE\r
        CMP      AX, WM_SIZE\r
        JNE      @@chk_WM_SHOWWINDOW\r
\r
        MOV      EDX, EDI\r
        MOV      EAX, ESI\r
        CALL     TControl.CallDefWndProc\r
        PUSH     EAX\r
\r
        MOV      ECX, [EDI].TMsg.wParam\r
        MOV      [ESI].TControl.fWindowState, CL\r
\r
        CMP      [ESI].TControl.fIsForm, 0\r
        JNZ      @@doGlobalAlignSelf\r
        MOV      EAX, [ESI].TControl.fParent\r
        TEST     EAX, EAX\r
        JZ       @@doGlobalAlignSelf\r
        CALL     dword ptr [Global_Align]\r
@@doGlobalAlignSelf:\r
        XCHG     EAX, ESI\r
        CALL     dword ptr [Global_Align]\r
\r
        //POP      EAX\r
        JMP      @@popeax_exit\r
                        // fPass2DefProc not needed,\r
                        // CallDefWndProc already called\r
\r
@@chk_WM_SHOWWINDOW:\r
        //CMP      word ptr [EDI].TMsg.message, WM_SHOWWINDOW\r
        CMP      AX, WM_SHOWWINDOW\r
        JNE      @@chk_WM_SYSCOMMAND\r
\r
        MOV      ECX, [EDI].TMsg.lParam\r
        LOOP     @@chk_SW_PARENTOPENING\r
\r
        PUSH     [ESI].TControl.fHandle\r
        CALL     IsIconic\r
        XOR      EBX, EBX\r
        MOV      BL, SW_SHOWMINNOACTIVE\r
        TEST     EAX, EAX\r
        JNZ      @@store_action\r
\r
        PUSH     [ESI].TControl.fHandle\r
        CALL     IsZoomed\r
        MOV      BL, SW_SHOWMAXIMIZED\r
        TEST     EAX, EAX\r
        JNZ      @@store_action\r
\r
        MOV      BL, SW_SHOWNOACTIVATE\r
@@store_action:\r
        MOV      [ESI].TControl.fShowAction, EBX\r
@@2calldef:\r
        JMP      @@calldef\r
\r
@@chk_SW_PARENTOPENING:\r
        DEC      ECX\r
        LOOP     @@2calldef\r
\r
        MOV      ECX, [ESI].TControl.fShowAction\r
        JECXZ    @@ret_0\r
\r
        PUSH     ECX\r
        PUSH     [ESI].TControl.fHandle\r
        CALL     ShowWindow\r
\r
        XOR      EAX, EAX\r
        MOV      [ESI].TControl.fShowAction, EAX\r
@@ret_0:\r
        //XOR      EAX, EAX\r
        JMP      @@0pass2defproc\r
\r
@@chk_WM_SYSCOMMAND:\r
        //CMP      word ptr [EDI].TMsg.message, WM_SYSCOMMAND\r
        CMP      AX, WM_SYSCOMMAND\r
        JNE      @@chk_WM_SETFOCUS\r
\r
        MOV      EAX, [EDI].TMsg.wParam\r
        {$IFDEF PARANOIA}\r
        DB $24, $F0\r
        {$ELSE}\r
        AND      AL, $F0\r
        {$ENDIF}\r
        CMP      AX, SC_MINIMIZE\r
        JNE      @@calldef\r
\r
        MOV      EAX, ESI\r
        CALL     TControl.IsMainWindow\r
        TEST     AL, AL\r
        JZ       @@calldef\r
\r
        CMP      ESI, [Applet]\r
        JE       @@calldef\r
\r
        PUSH     0\r
        PUSH     SC_MINIMIZE\r
        PUSH     WM_SYSCOMMAND\r
        MOV      EAX, [Applet]\r
        PUSH     [EAX].TControl.fHandle\r
        CALL     PostMessage\r
        JMP      @@ret_0\r
\r
@@chk_WM_SETFOCUS:\r
        //CMP      word ptr [EDI].TMsg.message, WM_SETFOCUS\r
        CMP      AX, WM_SETFOCUS\r
        JNE      @@chk_WM_SETCURSOR\r
\r
        MOV      EAX, ESI\r
        CALL     TControl.DoSetFocus\r
        TEST     AL, AL\r
        JZ       @@0pass2defproc\r
\r
//@@calldef_clickdisabled:\r
        INC      [ESI].TControl.fClickDisabled\r
\r
        MOV      EAX, ESI\r
        MOV      EDX, EDI\r
        CALL     TControl.CallDefWndProc\r
\r
        DEC      [ESI].TControl.fClickDisabled\r
        JMP      @@exit\r
\r
@@chk_WM_SETCURSOR:\r
        //CMP      word ptr [EDI].TMsg.message, WM_SETCURSOR\r
        CMP      AX, WM_SETCURSOR\r
        JNE      @@chk_WM_CTLCOLOR\r
\r
        CMP      [Global_DisableParentCursor], 0\r
        JNE      @@calldef\r
\r
        CALL     GetCapture\r
        TEST     EAX, EAX\r
        JNZ      @@calldef\r
\r
        CMP      word ptr [EDI].TMsg.lParam, HTCLIENT\r
        JNE      @@calldef\r
\r
        MOV      ECX, [ScreenCursor]\r
        INC      ECX\r
        LOOP     @@setupCursor\r
\r
        MOV      ECX, [ESI].TControl.fCursor\r
        TEST     ECX, ECX                    //YS\r
        JE       @@calldef                   //YS\r
@@setupCursor:\r
        PUSH     ECX\r
        CALL     Windows.SetCursor\r
\r
        MOV      AL, 1\r
        JMP      @@exit\r
\r
@@chk_WM_CTLCOLOR:\r
        //MOV      EAX, [EDI].TMsg.message\r
        MOV      EDX, EAX\r
        SUB      DX, WM_CTLCOLORMSGBOX\r
        CMP      DX, WM_CTLCOLORSTATIC-WM_CTLCOLORMSGBOX\r
        JA       @@chk_WM_COMMAND\r
\r
        PUSH     [EDI].TMsg.lParam\r
        PUSH     [EDI].TMsg.wParam\r
        ADD      AX, CN_BASE //+WM_CTLCOLORMSGBOX\r
        PUSH     EAX\r
        PUSH     [EDI].TMsg.lParam\r
        CALL     SendMessage\r
        JMP      @@pass2defproc\r
\r
@@chk_WM_COMMAND:\r
        //CMP      word ptr [EDI].TMsg.message, WM_COMMAND\r
        CMP      AX, WM_COMMAND\r
        JNE      @@chk_WM_KEY\r
\r
        PUSH     offset[ID_SELF]\r
        PUSH     [EDI].TMsg.lParam\r
        CALL     GetProp\r
        TEST     EAX, EAX\r
        JZ       @@calldef\r
\r
        PUSH     [EDI].TMsg.lParam\r
        PUSH     [EDI].TMsg.wParam\r
        PUSH     CM_COMMAND\r
        PUSH     [EDI].TMsg.lParam\r
        CALL     SendMessage\r
        JMP      @@pass2defproc\r
\r
@@chk_WM_KEY:\r
        //MOV      EAX, [EDI].TMsg.message\r
        MOV      EDX, EAX\r
        SUB      DX, WM_KEYFIRST\r
        CMP      DX, WM_KEYLAST-WM_KEYFIRST\r
        JA       @@chk_CM_EXECPROC\r
\r
        CALL     GetFocus\r
        CMP      EAX, [ESI].TControl.fFocusHandle\r
        JE       @@in_focus\r
        CMP      EAX, [ESI].TControl.fHandle\r
        JNE      @@0pass2defproc\r
\r
@@in_focus:\r
        PUSH     EAX\r
\r
        MOV      ECX, ESP\r
        MOV      EDX, EDI\r
        MOV      EAX, ESI\r
        CALL     dword ptr [fGlobalProcKeybd]\r
        TEST     AL, AL\r
        JNZ      @@to_exit\r
\r
        MOV      ECX, ESP\r
        MOV      EDX, EDI\r
        MOV      EAX, ESI\r
        CALL     [ESI].fWndProcKeybd\r
        TEST     AL, AL\r
@@to_exit:\r
        POP      EAX\r
        JNZ      @@pass2defproc\r
\r
        PUSH     VK_CONTROL\r
        CALL     GetKeyState\r
        XCHG     EBX, EAX\r
        PUSH     VK_MENU\r
        CALL     GetKeyState\r
        OR       EAX, EBX\r
        ADD      EAX, EAX\r
        JC       @@calldef\r
\r
        CMP      word ptr [EDI].TMsg.message, WM_CHAR\r
        JNE      @@to_fGotoControl\r
\r
        CMP      byte ptr [EDI].TMsg.wParam, 9\r
        JE       @@clear_wParam\r
        JMP      @@calldef\r
\r
@@to_fGotoControl:\r
        MOV      EAX, ESI\r
        CALL     TControl.ParentForm\r
        TEST     EAX, EAX\r
        JZ       @@calldef\r
\r
        MOV      ECX, [EAX].fGotoControl\r
        JECXZ    @@calldef\r
\r
        MOV      EBX, ECX\r
        CMP      [EDI].TMsg.message, WM_KEYDOWN\r
        SETNE    CL\r
        MOV      EDX, [EDI].TMsg.wParam\r
        MOV      EAX, ESI\r
        CALL     EBX\r
        TEST     AL, AL\r
        JZ       @@calldef\r
\r
@@clear_wParam:\r
        XOR      EAX, EAX\r
        MOV      [EDI].TMsg.wParam, EAX\r
        JMP      @@pass2defproc\r
\r
@@chk_CM_EXECPROC:\r
        //CMP      word ptr [EDI].TMsg.message, CM_EXECPROC\r
        CMP      AX, CM_EXECPROC\r
        JNE      @@chk_MM_MCINOTIFY\r
\r
        MOV      EAX, [EDI].TMsg.lParam\r
        MOV      EDX, [EDI].TMsg.wParam\r
        CALL     [Global_Synchronized]\r
        JMP      @@0pass2defproc\r
\r
@@chk_MM_MCINOTIFY:\r
        //CMP      word ptr [EDI].TMsg.message, MM_MCINOTIFY\r
        CMP      AX, MM_MCINOTIFY\r
        JNE      @@calldef\r
\r
        MOV      ECX, [FMMNotify]\r
        JECXZ    @@ret_0_MM\r
\r
        XCHG     EAX, EDI\r
        CALL     ECX\r
@@ret_0_MM:\r
        XOR      EAX, EAX\r
        JMP      @@exit\r
\r
@@calldef:\r
        XCHG     EAX, ESI\r
        MOV      EDX, EDI\r
        CALL     TControl.CallDefWndProc\r
        JMP      @@exit\r
\r
@@0pass2defproc:\r
        XOR      EAX, EAX\r
@@pass2defproc:\r
        PUSH     EAX\r
@@1pass2defproc:\r
        CMP      [AppletTerminated], 0 //\r
        JNZ      @@popeax_exit         // uncommented 25-Oct-2003\r
        CMP      [ESI].fNCDestroyed, 0 //\r
        JNZ      @@popeax_exit         //\r
\r
        MOV      ECX, ESP\r
        XCHG     EAX, ESI\r
        MOV      EDX, EDI\r
        CALL     dword ptr[EAX].fPass2DefProc\r
@@popeax_exit:\r
        POP      EAX\r
\r
@@exit:\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_LOCAL} //Pascal\r
\r
  {$IFDEF DEBUG_CREATEWINDOW}\r
  var DbgCWCount: Integer = 0;\r
  {$ENDIF DEBUG_CREATEWINDOW}\r
function TControl.WndProc( var Msg: TMsg ): Integer;\r
var Accept: Boolean;\r
    C : PControl;\r
    F {, Chld}: HWnd;\r
    Cur: HCURSOR; // YS\r
    PassFun: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
\r
    procedure Default;\r
    begin\r
      Result := CallDefWndProc( Msg );\r
    end;\r
\r
begin\r
   {$IFDEF DEBUG_CREATEWINDOW}\r
   Inc( DbgCWCount );\r
   if DbgCWCount < 10 then\r
     LogFileOutput( GetStartDir + 'Session.log', 'TControl.WndProc: ' +\r
     ' Msg.hwnd=' + Int2Str( Msg.hwnd ) +\r
     ' Msg.message=' + Int2Hex( Msg.message, 2 ) +\r
     ' Msg.wParam=' + Int2Str( Msg.wParam ) + '=$' + Int2Hex( Msg.wParam, 4 ) +\r
     ' Msg.lParam=' + Int2Str( Msg.lParam ) + '=$' + Int2Hex( Msg.lParam, 4 ) );\r
   {$ENDIF DEBUG_CREATEWINDOW}\r
   if (Msg.hwnd <> 0) and (fHandle = 0) then\r
      fHandle := Msg.hwnd;\r
\r
   PassFun := fPass2DefProc;\r
   if not Global_OnBufferedDraw( @Self, Msg, Result ) then\r
   if not (AppletRunning and (Applet <> @Self) and Assigned( Applet ) and\r
      Assigned( Applet.OnMessage ) and Applet.OnMessage( Msg, Result )) then\r
   if not (Assigned( OnMessage ) and OnMessage( Msg, Result )) then\r
   if not fOnDynHandlers( @Self, Msg, Result ) then\r
   begin\r
     if not fWndProcResizeFlicks( @Self, Msg, Result ) then\r
     case Msg.message of\r
     {$IFDEF NEW_MODAL}\r
     // version of code by Alexander Pravdin\r
     WM_CLOSE:\r
                begin\r
                  Accept := True;\r
                  if Assigned( fOnClose ) then begin\r
                    fOnClose( @Self, Accept );\r
                    if AppletRunning then\r
                      if Accept then\r
                        if fModal > 0 then begin\r
                          if ModalResult = 0 then\r
                            fModalResult := Integer($80000000);\r
                          Msg.message := 0;\r
                          Exit;\r
                        end\r
                        else\r
                          fOnClose := nil\r
                      else begin\r
                        Result := 0;\r
                        fModalResult := 0;\r
                      end\r
                    else\r
                      fOnClose := nil;\r
                  end\r
                  else begin\r
                    if fModal > 0 then begin\r
                      if ModalResult = 0 then\r
                        fModalResult := Integer($80000000);\r
                      Exit;\r
                    end;\r
                  end;\r
\r
                  if Accept then begin\r
                    if IsMainWindow or ( Applet = @Self ) then begin\r
                      if Assigned( Applet ) and ( Applet <> @Self ) then\r
                        Applet.Perform( WM_CLOSE, 0, 0 );\r
                      PostQuitMessage( 0 );\r
                      Result := 0;\r
                    end\r
                    else\r
                      Default;\r
                  end;\r
                end;\r
    {$ELSE}\r
     WM_CLOSE: begin\r
                  Accept := True;\r
                  if Assigned( fOnClose ) then\r
                  begin\r
                     fOnClose( @Self, Accept );\r
                     if (not Accept) and (AppletRunning) then\r
                     begin\r
                        Result := 0;\r
                        //ModalResult := 0;\r
                        //Exit; //?????????????????\r
                     end\r
                       else //+-+\r
                     fOnClose := nil;\r
                  end;\r
                  if Accept then\r
                  begin\r
                    if IsMainWindow or (Applet = @Self) then\r
                    begin\r
                       if Assigned( Applet ) and (Applet <> @Self) then\r
                          Applet.Perform( WM_CLOSE, 0, 0 );\r
                       PostQuitMessage( 0 );\r
                       Result := 0;\r
                       //Exit; //???????????????\r
                    end\r
                      else\r
                    Default;\r
                  end;\r
               end;\r
     {$ENDIF}\r
{//********************************************************** Added By M.Gerasimov\r
//*\r
     WM_DESTROY:\r
               begin\r
                Chld := GetWindow( fHandle, GW_CHILD );\r
                while Chld <> 0 do\r
                 begin\r
                  if GetProp( Chld, ID_PREVPROC ) <> 0 then\r
                   RemoveProp(Chld, ID_PREVPROC);\r
                   Chld := GetWindow( Chld, GW_HWNDNEXT );\r
                 end;\r
               end;\r
//*\r
//********************************************************** Added By M.Gerasimov}\r
     WM_NCDESTROY:\r
               begin\r
//********************************************************** Added By M.Gerasimov\r
//*\r
                RemoveProp( fHandle, ID_SELF );\r
//*\r
//********************************************************** Added By M.Gerasimov\r
                if (Applet = nil) or (Handle <> Applet.Handle) then\r
                  begin\r
                    if IsMainWindow then\r
                     begin\r
                      PostMessage( fHandle, CM_RELEASE, 0, 0 );\r
                      Default;\r
                     end\r
                    else\r
                     if fParent = Applet then\r
                      begin\r
                       fNCDestroyed := True;\r
                       Free;\r
                       Result := 0;\r
                       Exit; //!!!!!!!!!!!!!!!!!!!!!!!!!\r
                      end\r
                     else\r
                       Default;\r
                  end;\r
               end;\r
\r
     CM_RELEASE: begin\r
                  fDestroying := True;\r
                  Free;\r
                  Result := 0;\r
                  //Exit; //??????????????????????????\r
                 end;\r
\r
     WM_SIZE:  begin\r
                  Default;\r
                  case Msg.wParam of\r
                    SIZENORMAL: fWindowState := wsNormal;\r
                    SIZEICONIC: fWindowState := wsMinimized;\r
                    SIZEFULLSCREEN: fWindowState := wsMaximized;\r
                  end;\r
                  if not fIsForm and (fParent <> nil) then\r
                    Global_Align( fParent );\r
                  Global_Align( @Self );\r
                  Exit;\r
               end;\r
     WM_SHOWWINDOW:\r
               begin\r
                  case Msg.lParam of\r
                    SW_PARENTCLOSING:\r
                       begin\r
                          if IsIconic( fHandle ) then\r
                             fShowAction := SW_SHOWMINNOACTIVE\r
                          else\r
                          if IsZoomed( fHandle ) then\r
                             fShowAction := SW_SHOWMAXIMIZED\r
                          else\r
                             fShowAction := SW_SHOWNOACTIVATE;\r
                          Default;\r
                       end;\r
                    SW_PARENTOPENING:\r
                       begin\r
                          if fShowAction <> 0 then\r
                          begin\r
                             ShowWindow( Handle, fShowAction );\r
                             fShowAction := 0;\r
                          end;\r
                          Result := 0;\r
                          //Exit; //?????????????????????????\r
                       end;\r
                    else Default;\r
                  end;\r
               end;\r
     WM_SysCommand:\r
               begin\r
                  if ((Msg.wParam and $FFF0) = SC_MINIMIZE) and\r
                     IsMainWindow and (@Self <> Applet) then\r
                  begin\r
                     PostMessage( Applet.Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0 );\r
                     Result := 0;\r
                     //Exit; //???????????????????????????\r
                  end\r
                  else Default;\r
               end;\r
     WM_SETFOCUS:\r
               begin\r
                 if not DoSetFocus then\r
                 begin\r
                   Result := 0;\r
                   //Exit; //???????????????????????????\r
                 end\r
                   else\r
                 begin\r
                   Inc( fClickDisabled );\r
                   Default;\r
                   Dec( fClickDisabled );\r
                   Exit;\r
                 end;\r
               end;\r
     WM_SETCURSOR:\r
               if not Global_DisableParentCursor then\r
               begin\r
                  if (GetCapture = 0) and\r
                     (LOWORD( Msg.lParam ) = HTCLIENT) then\r
                  begin\r
                    if ScreenCursor <> 0 then                  //YS\r
                      Cur := ScreenCursor                      //YS\r
                    else                                       //YS\r
                      Cur := fCursor;                          //YS\r
                    if Cur <> 0 then                           //YS\r
                    begin                                      //YS\r
                      Windows.SetCursor( Cur );                //YS\r
                      Result := 1;                             //YS\r
                    end                                        //YS\r
                    else                                       //YS\r
                      Default;                                 //YS\r
                    //Exit; //?????????????????????\r
                  end\r
                  else Default;\r
               end\r
               else Default;\r
     WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:\r
     begin\r
       Result := SendMessage(Msg.LParam, CN_BASE + Msg.message, Msg.WParam, Msg.LParam);\r
       //exit; //???????????????????????\r
     end;\r
     WM_COMMAND:\r
               begin\r
                 C := Pointer( GetProp( Msg.lParam, ID_SELF ) );\r
                 if C <> nil then\r
                 begin\r
                   Result := SendMessage( Msg.lParam, CM_COMMAND, Msg.wParam, Msg.lParam );\r
                   //Exit; //???????????????????????\r
                 end\r
                 else Default;\r
               end;\r
     WM_KEYFIRST..WM_KEYLAST:\r
               begin\r
                 F := GetFocus;\r
                 if (F <> fFocusHandle) and (F <> fHandle) then\r
                 begin\r
                   Result := 0;\r
                   // Jump to PassFun here. Prevents beep in case when WM_KEYDOWN\r
                   // called another form and focus is changed, so WM_KEYUP failed\r
                   // to handle.\r
                 end\r
                   else\r
                 begin\r
                   if fGlobalProcKeybd( @Self, Msg, Result ) then Exit; //??????????????????\r
                     //else\r
                   if fWndProcKeybd( @Self, Msg, Result ) then Exit; //???????????????????\r
                     //else\r
                   if ((GetKeystate( VK_CONTROL ) or GetKeyState( VK_MENU )) >= 0) then\r
                   begin\r
                     //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\r
                     if (Msg.message <> WM_CHAR) // v1.02 Tabulate AND " in EditBox fix\r
                     //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\r
                     then\r
                     begin\r
                       C := ParentForm;\r
                       if (C <> nil) and Assigned(C.fGotoControl) and\r
                          C.fGotoControl( @Self, Msg.wParam, Msg.message <> WM_KEYDOWN ) then\r
                       begin\r
                            Msg.wParam := 0;\r
                            Result := 0;\r
                            //+-+exit;\r
                       end\r
                       else Default;\r
                     end\r
                     //+++++++++++++++++++++++++++++++++++++++++++++//\r
                       else                                         //\r
                     if Msg.wParam = 9 then // prevent system beep  //\r
                     begin                                          //\r
                        Msg.wParam := 0;                            //\r
                        Result := 0;                                //\r
                        //+-+exit;                                  //\r
                     end                                            //\r
                     //+++++++++++++++++++++++++++++++++++++++++++++//\r
                     else Default;\r
                   end\r
                   else Default;\r
                 end;\r
               end;\r
     CM_EXECPROC: begin\r
                    Global_Synchronized( Pointer( Msg.lParam ), Pointer( Msg.wParam ) );\r
                    Result := 0;\r
                    //Exit; //???????????????????\r
                  end;\r
     MM_MCINOTIFY: begin\r
                     if Assigned( FMMNotify ) then\r
                        FMMNotify( Msg );\r
                     Result := 0;\r
                     exit;\r
                   end;\r
     else  begin\r
             Default; //+-+\r
             Exit;    //+-+\r
           end;\r
     end;\r
   end;\r
\r
   if not AppletTerminated and not fNCDestroyed then\r
     PassFun( @Self, Msg, Result ); //+-+\r
end;\r
{$ENDIF ASM_LOCAL}\r
//[END TContro]\r
\r
{$UNDEF ASM_LOCAL}\r
\r
//[procedure SetMouseEvent]\r
procedure SetMouseEvent( Self_: PControl );\r
begin\r
  Self_.AttachProc( WndProcMouse );\r
end;\r
\r
//[procedure TControl.SetMouseDown]\r
procedure TControl.SetMouseDown(const Value: TOnMouse);\r
begin\r
  fOnMouseDown := Value;\r
  SetMouseEvent( @Self );\r
end;\r
\r
//[procedure TControl.SetMouseMove]\r
procedure TControl.SetMouseMove(const Value: TOnMouse);\r
begin\r
  fOnMouseMove := Value;\r
  SetMouseEvent( @Self );\r
end;\r
\r
//[procedure TControl.SetMouseUp]\r
procedure TControl.SetMouseUp(const Value: TOnMouse);\r
begin\r
  fOnMouseUp := Value;\r
  SetMouseEvent( @Self );\r
end;\r
\r
//[procedure TControl.SetMouseDblClk]\r
procedure TControl.SetMouseDblClk(const Value: TOnMouse);\r
begin\r
  fOnMouseDblClk := Value;\r
  SetMouseEvent( @Self );\r
end;\r
\r
//[procedure TControl.SetMouseWheel]\r
procedure TControl.SetMouseWheel(const Value: TOnMouse);\r
begin\r
  fOnMouseWheel := Value;\r
  SetMouseEvent( @Self );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetClsStyle]\r
procedure TControl.SetClsStyle( Value: DWord );\r
asm     //cmd    //opd\r
        CMP      EDX, [EAX].TControl.fClsStyle\r
        JE       @@exit\r
        MOV      [EAX].TControl.fClsStyle, EDX\r
        MOV      ECX, [EAX].TControl.fHandle\r
        JECXZ    @@exit\r
        PUSH     EDX\r
        PUSH     GCL_STYLE\r
        PUSH     ECX\r
        CALL     SetClassLong\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetClsStyle( Value: DWord );\r
begin\r
   if fClsStyle = Value then Exit;\r
   fClsStyle := Value;\r
   if fHandle = 0 then Exit;\r
   SetClassLong( fHandle, GCL_STYLE, Value );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetStyle]\r
procedure TControl.SetStyle( Value: DWord );\r
const SWP_FLAGS = SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or\r
                 SWP_NOZORDER or SWP_FRAMECHANGED;\r
asm\r
        CMP      EDX, [EAX].fStyle\r
        JZ       @@exit\r
        MOV      [EAX].fStyle, EDX\r
        MOV      ECX, [EAX].fHandle\r
        JECXZ    @@exit\r
\r
        PUSH     EAX\r
\r
        PUSH     SWP_FLAGS\r
        XOR      EAX, EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        PUSH     EDX\r
        PUSH     GWL_STYLE\r
        PUSH     ECX\r
        CALL     SetWindowLong\r
\r
        CALL     SetWindowPos\r
\r
        POP      EAX\r
        CALL     Invalidate\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetStyle( Value: DWord );\r
begin\r
   if fStyle = Value then Exit;\r
   fStyle := Value;\r
   if fHandle = 0 then Exit;\r
   SetWindowLong( fHandle, GWL_STYLE, Value );\r
\r
   SetWindowPos( fHandle, 0, 0, 0, 0, 0,\r
                 SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or\r
                 SWP_NOZORDER or SWP_FRAMECHANGED );\r
   Invalidate;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetExStyle]\r
procedure TControl.SetExStyle( Value: DWord );\r
const SWP_FLAGS = SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or\r
                 SWP_NOZORDER or SWP_FRAMECHANGED;\r
asm\r
        CMP      EDX, [EAX].fExStyle\r
        JZ       @@exit\r
        MOV      [EAX].fExStyle, EDX\r
        MOV      ECX, [EAX].fHandle\r
        JECXZ    @@exit\r
\r
        PUSH     EAX\r
\r
        PUSH     SWP_FLAGS\r
        XOR      EAX, EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     ECX\r
\r
        PUSH     EDX\r
        PUSH     GWL_EXSTYLE\r
        PUSH     ECX\r
        CALL     SetWindowLong\r
\r
        CALL     SetWindowPos\r
\r
        POP      EAX\r
        CALL     Invalidate\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetExStyle( Value: DWord );\r
begin\r
   if fExStyle = Value then Exit;\r
   fExStyle := Value;\r
   if fHandle = 0 then Exit;\r
   SetWindowLong( fHandle, GWL_EXSTYLE, Value );\r
\r
   SetWindowPos( fHandle, 0, 0, 0, 0, 0,\r
                 SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or\r
                 SWP_NOZORDER or SWP_FRAMECHANGED );\r
   Invalidate;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetCursor]\r
procedure TControl.SetCursor( Value: HCursor );\r
asm     //cmd    //opd\r
        CMP      EDX, [EAX].TControl.fCursor\r
        JE       @@exit\r
        MOV      [EAX].TControl.fCursor, EDX\r
        MOV      ECX, [EAX].TControl.fHandle\r
        JECXZ    @@exit\r
        TEST     EDX, EDX                      //YS\r
        JE       @@exit                        //YS\r
        MOV      ECX, [ScreenCursor]\r
        INC      ECX\r
        LOOP     @@exit\r
\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     ESP\r
        CALL     GetCursorPos\r
        MOV      EDX, ESP\r
        MOV      ECX, EDX\r
        MOV      EAX, EBX\r
        CALL     Screen2Client\r
        ADD      ESP, -16\r
        MOV      EDX, ESP\r
        MOV      EAX, EBX\r
        CALL     TControl.ClientRect\r
        MOV      EDX, ESP\r
        LEA      EAX, [ESP+16]\r
        CALL     PointInRect\r
        ADD      ESP, 24\r
        TEST     AL, AL\r
        JZ       @@fin\r
        CALL     Windows.SetCursor\r
        PUSH     EAX\r
@@fin:  POP      EAX\r
        POP      EBX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetCursor( Value: HCursor );\r
var P: TPoint;\r
begin\r
   if fCursor = Value then Exit;\r
   fCursor := Value;\r
   if (fHandle = 0) or (fCursor = 0) then Exit;        //YS\r
   if ScreenCursor <> 0 then Exit;\r
   GetCursorPos( P );\r
   P := Screen2Client( P );\r
   if PointInRect( P, ClientRect ) then\r
   Windows.SetCursor( Value );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.CursorLoad]\r
procedure TControl.CursorLoad(Inst: Integer; ResName: PChar);\r
begin\r
  Cursor := LoadCursor( Inst, ResName );\r
  fCursorShared := TRUE;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetIcon]\r
procedure TControl.SetIcon( Value: HIcon );\r
asm     //cmd    //opd\r
        CMP      EDX, [EAX].TControl.fIcon\r
        JE       @@exit\r
        MOV      [EAX].TControl.fIcon, EDX\r
        INC      EDX\r
        JZ       @@1\r
        DEC      EDX\r
@@1:\r
        PUSH     EDX\r
        PUSH     1 //ICON_BIG\r
        PUSH     WM_SETICON\r
        PUSH     EAX\r
        CALL     Perform\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        PUSH     EAX\r
        CALL     DestroyIcon\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetIcon( Value: HIcon );\r
var OldIco: HIcon;\r
begin\r
   if fIcon = Value then Exit;\r
   fIcon := Value;\r
   if Value = THandle(-1) then\r
     Value := 0;\r
   OldIco := Perform( WM_SETICON, 1 {ICON_BIG}, Value );\r
   if OldIco <> 0 then\r
     DestroyIcon( OldIco );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetMenu]\r
procedure TControl.SetMenu( Value: HMenu );\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        CMP      [EBX].fMenu, EDX\r
        JZ       @@exit\r
        PUSH     EDX\r
        MOV      ECX, [EBX].fMenuObj\r
        JECXZ    @@no_free_menuctl\r
        XCHG     EAX, EDX\r
        CALL     TObj.Free\r
@@no_free_menuctl:\r
        MOV      ECX, [EBX].fMenu\r
        JECXZ    @@no_destroy\r
        PUSH     ECX\r
        CALL     DestroyMenu\r
@@no_destroy:\r
        POP      EDX\r
        MOV      [EBX].fMenu, EDX\r
        MOV      ECX, [EBX].fHandle\r
        JECXZ    @@exit\r
        PUSH     EDX\r
        PUSH     ECX\r
        CALL     Windows.SetMenu\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetMenu( Value: HMenu );\r
begin\r
  if fMenu = Value then Exit;\r
  if fMenuObj <> nil then\r
     fMenuObj.Free;\r
  if fMenu <> 0 then\r
     DestroyMenu( fMenu );\r
  fMenu := Value;\r
  if fHandle = 0 then Exit;\r
  Windows.SetMenu( fHandle, Value );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure CallWinHelp]\r
procedure CallWinHelp( Context: Integer; CtxCtl: PControl );\r
var Cmd: Integer;\r
    Form: PControl;\r
    Popup: Boolean;\r
begin\r
  Cmd := HELP_CONTEXT;\r
  if CtxCtl <> nil then\r
  begin\r
    Form := CtxCtl.ParentForm;\r
    if Form <> nil then\r
    if Assigned( Form.OnHelp ) then\r
    begin\r
      Popup := FALSE;\r
      Form.OnHelp( CtxCtl, Context, Popup );\r
      if Popup then\r
        Cmd := HELP_CONTEXTPOPUP;\r
      if CtxCtl = nil then Exit;\r
    end;\r
  end\r
    else\r
  if Context = 0 then\r
    Cmd := HELP_CONTENTS;\r
  WinHelp( Applet.Handle, PChar( Applet.GetHelpPath ), Cmd, Context );\r
end;\r
\r
var HHCtrl: THandle;\r
    HtmlHelp: procedure( Wnd: HWnd; Path: PChar; Cmd, Data: Integer ); stdcall;\r
\r
//[procedure HtmlHelpCommand]\r
procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: String; Cmd, Data: Integer );\r
begin\r
  if HHCtrl = 0 then\r
    HHCtrl := LoadLibrary( 'HHCTRL.OCX' );\r
  if HHCtrl = 0 then Exit;\r
  if not Assigned( HtmlHelp ) then\r
    HtmlHelp := GetProcAddress( HHCtrl, 'HtmlHelpA' );\r
  if not Assigned( HtmlHelp ) then Exit;\r
  HtmlHelp( Wnd, PChar( HelpFilePath ), Cmd, Data );\r
end;\r
\r
//[procedure CallHtmlHelp]\r
procedure CallHtmlHelp( Context: Integer; CtxCtl: PControl );\r
var Cmd: Integer;\r
    Form: PControl;\r
    Popup: Boolean;\r
    Ids: array[ 0..2 ] of DWORD;\r
begin\r
\r
  Cmd := $F; // HH_HELP_CONTEXT;\r
  if CtxCtl <> nil then\r
  begin\r
    Form := CtxCtl.ParentForm;\r
    if Form <> nil then\r
    if Assigned( Form.OnHelp ) then\r
    begin\r
      Popup := FALSE;\r
      Form.OnHelp( CtxCtl, Context, Popup );\r
      if Popup then\r
      begin\r
        Cmd := $10; //HH_TP_HELPCONTEXTMENU;\r
        Ids[ 0 ] := CtxCtl.fMenu;\r
        Ids[ 1 ] := Context;\r
        Ids[ 2 ] := 0;\r
        Context := Integer( @ Ids );\r
      end;\r
      if CtxCtl = nil then Exit;\r
    end;\r
  end\r
    else\r
  if Context = 0 then\r
    Cmd := 1; // HH_DISPLAY_TOC;\r
  HtmlHelpCommand( Applet.Handle, HelpFilePath, Cmd, Context );\r
end;\r
\r
var\r
  Global_HelpProc: procedure( Context: Integer; CtxCtl: PControl ) = CallWinHelp;\r
\r
//[function WndProcHelp]\r
function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var HI: PHelpInfo;\r
    Ctx: Integer;\r
    Ctl: PControl;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_HELP then\r
  begin\r
    Ctx := 0;\r
    Ctl := nil;\r
    HI := Pointer( Msg.lParam );\r
    if HI.iContextType = HELPINFO_WINDOW then\r
    begin\r
      Ctl := Pointer( GetProp( HI.hItemHandle, ID_SELF ) );\r
      while Ctl <> nil do\r
      begin\r
        Ctx := Ctl.fHelpContext;\r
        if Ctx <> 0 then break;\r
        Ctl := Ctl.Parent;\r
      end;\r
    end\r
      else\r
    //if HI.iContextType = HELPINFO_MENUITEM then\r
      Ctx := GetMenuContextHelpID( HI.hItemHandle );\r
    Applet.CallHelp( Ctx, Ctl );\r
    Rslt := 1;\r
    Result := TRUE;\r
  end\r
  {$IFDEF AUTO_CONTEXT_HELP}\r
    else\r
  if (Msg.message = WM_CONTEXTMENU) then\r
  begin\r
    Ctl := Pointer( GetProp( Msg.wParam, ID_SELF ) );\r
    if (Ctl <> nil) and (Ctl.fHelpContext <> 0) then\r
    //if (Ctl.fAutoPopupMenu = nil) then // seems not working\r
    begin\r
      Applet.CallHelp( Ctl.fHelpContext, Ctl );\r
      Rslt := 1;\r
      Result := TRUE;\r
    end;\r
  end\r
  {$ENDIF}\r
     ;\r
end;\r
\r
//[procedure TControl.SetHelpContext]\r
procedure TControl.SetHelpContext(Value: Integer);\r
var F: PControl;\r
begin\r
  fHelpContext := Value;\r
  F := ParentForm;\r
  if F = nil then Exit;\r
  F.AttachProc( WndProcHelp );\r
  SetWindowContextHelpId( GetWindowHandle, Value );\r
end;\r
\r
//[function TControl.AssignHelpContext]\r
function TControl.AssignHelpContext(Context: Integer): PControl;\r
begin\r
  SetHelpContext( Context );\r
  Result := @ Self;\r
end;\r
\r
//[procedure AssignHtmlHelp]\r
procedure AssignHtmlHelp( const HtmlHelpPath: String );\r
begin\r
  Assert( (HtmlHelpPath <> '') and (Applet <> nil), 'Error parameters' );\r
  if HelpFilePath <> '' then\r
    FreeMem( HelpFilePath );\r
  GetMem( HelpFilePath, Length( HtmlHelpPath ) + 1 );\r
  StrCopy( HelpFilePath, @ HtmlHelpPath[ 1 ] );\r
  Global_HelpProc := CallHtmlHelp;\r
  Applet.AttachProc( WndProcHelp );\r
end;\r
\r
//[procedure TControl.CallHelp]\r
procedure TControl.CallHelp(Context: Integer; CtxCtl: PControl {; CtlID: Integer} );\r
begin\r
  Global_HelpProc( Context, CtxCtl {, CtlID} );\r
end;\r
\r
//[function TControl.GetHelpPath]\r
function TControl.GetHelpPath: String;\r
begin\r
  Result := HelpFilePath;\r
  if Result = '' then\r
  begin\r
    Result := ParamStr( 0 );\r
    Result := ReplaceFileExt( Result, '.hlp' );\r
  end;\r
end;\r
\r
//[procedure TControl.SetHelpPath]\r
procedure TControl.SetHelpPath(const Value: String);\r
begin\r
  Assert( Value <> '', 'Error parameter' );\r
  if HelpFilePath <> '' then\r
    FreeMem( HelpFilePath );\r
  GetMem( HelpFilePath, Length( Value ) + 1 );\r
  StrCopy( HelpFilePath, @ Value[ 1 ] );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetCaption]\r
function TControl.GetCaption: String;\r
asm\r
        XCHG      EAX, EDX\r
        MOVZX     ECX, [EDX].fIgnoreWndCaption\r
        JECXZ     @@getwndcaption\r
\r
@@ret_fCaption:\r
        MOV       EDX, [EDX].fCaption\r
        JMP       System.@LStrFromPChar\r
\r
@@getwndcaption:\r
        MOV       ECX, [EDX].fHandle\r
        JECXZ     @@ret_fCaption\r
\r
        PUSH      EBX\r
        PUSH      ESI\r
        XCHG      EBX, EAX\r
\r
        MOV       ESI, ECX\r
        PUSH      ESI\r
        CALL      GetWindowTextLength\r
        MOV       EDX, EAX\r
        INC       EAX\r
        PUSH      EAX // MaxLen\r
\r
        MOV       EAX, EBX\r
        CALL      System.@LStrSetLength\r
\r
        POP       EDX\r
        MOV       ECX, [EBX]\r
        JECXZ     @@exit\r
        PUSH      EDX // MaxLen = Length(Result) + 1\r
\r
        PUSH      ECX //@Result[1]\r
        PUSH      ESI // fHandle\r
        CALL      GetWindowText\r
\r
@@exit:\r
        POP       ESI\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetCaption: String;\r
var Buf: PChar;\r
    Sz: Integer;\r
begin\r
   if not fIgnoreWndCaption and (FHandle <> 0) then\r
   begin\r
     Sz := GetWindowTextLength( FHandle );\r
     if Sz = 0 then\r
        Buf := nil\r
     else\r
     begin\r
       GetMem( Buf, Sz + 1 );\r
       GetWindowText( FHandle, Buf, Sz + 1 );\r
     end;\r
     Result := Buf;\r
     if Buf <> nil then\r
        FreeMem( Buf );\r
     Exit;\r
   end;\r
   Result := FCaption;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetCaption]\r
procedure TControl.SetCaption( const Value: String );\r
asm\r
        PUSH    EBX\r
        XCHG    EBX, EAX\r
        PUSH    EDX\r
        MOV     EAX, [EBX].fCaption\r
        TEST    EAX, EAX\r
        JZ      @@store_Caption\r
        CALL    System.@FreeMem\r
@@store_Caption:\r
        POP     EAX\r
        CALL    EAX2PChar\r
        PUSH    EAX\r
        CALL    StrLen\r
        INC     EAX\r
        CALL    System.@GetMem\r
        MOV     [EBX].fCaption, EAX\r
        POP     EDX\r
        CALL    StrCopy\r
        MOV     ECX, [EBX].fHandle\r
        JECXZ   @@exit\r
        PUSH    [EBX].fCaption\r
        PUSH    ECX\r
        CALL    SetWindowText\r
        CMP     [EBX].fIsStaticControl, 0\r
        JZ      @@1\r
        MOV     EAX, EBX\r
        CALL    Invalidate\r
@@1:\r
        XCHG    EAX, EBX\r
        MOV     ECX, [EAX].fAutoSize\r
        JECXZ   @@exit\r
        CALL    ECX\r
@@exit: POP     EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetCaption( const Value: String );\r
var L: DWORD;\r
begin\r
  //if fHandle = 0 then\r
  begin\r
    if fCaption <> nil then\r
       FreeMem( fCaption );\r
    L := Length( Value ) + 1;\r
    GetMem( fCaption, L );\r
    StrCopy( fCaption, PChar( Value ) );\r
    //Exit;\r
  end;\r
  if fHandle = 0 then Exit;\r
  SetWindowText( fHandle, @Value[ 1 ] );\r
  if not fIsStaticControl then\r
    Invalidate;\r
  if Assigned( fAutoSize ) then\r
    fAutoSize( @Self );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetVisible]\r
function TControl.GetVisible: Boolean;\r
asm\r
        MOV     ECX, [EAX].fHandle\r
        JECXZ   @@check_fStyle\r
\r
        {CMP     [EAX].fIsControl, 0\r
        JNE     @@check_fStyle}\r
\r
          PUSH  EAX\r
        PUSH    ECX\r
        CALL    IsWindowVisible\r
        TEST    EAX, EAX\r
          POP   EAX\r
        JMP     @@checked // Z if not visible\r
\r
@@check_fStyle:\r
        TEST    byte ptr [EAX].fStyle+3, 10h // WS_VISIBLE shr 3\r
@@checked:\r
        SETNZ   DL\r
        MOV     [EAX].fVisible, DL\r
        XCHG    EAX, EDX\r
end;\r
{$ELSE ASM_VERSION}\r
function TControl.GetVisible: Boolean;\r
begin\r
   if (fHandle <> 0)\r
      //and (not fIsControl or (ParentForm <> nil) and ParentForm.Visible)\r
      //and not fIsControl\r
   then\r
      fVisible :=\r
        //LongBool( GetWindowLong( fHandle, GWL_STYLE ) and WS_VISIBLE )\r
        IsWindowVisible( fHandle )\r
   else\r
      fVisible := (FStyle and WS_VISIBLE) <> 0;\r
   Result := fVisible;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Get_Visible]\r
function TControl.Get_Visible: Boolean;\r
asm     //     //\r
        MOV    ECX, [EAX].fHandle\r
        JECXZ  @@ret_fVisible\r
        CMP    [EAX].fIsControl, 0\r
        JNZ    @@ret_fVisible\r
        PUSH   EAX\r
        PUSH   ECX\r
        CALL   IsWindowVisible\r
        XCHG   EDX, EAX\r
        POP    EAX\r
        MOV    [EAX].fVisible, DL\r
@@ret_fVisible:\r
        MOVZX  EAX, [EAX].fVisible\r
end;\r
{$ELSE ASM_VERSION} // Pascal\r
function TControl.Get_Visible: Boolean;\r
begin\r
   if (fHandle <> 0)\r
      //and (not fIsControl or (ParentForm <> nil) and ParentForm.Visible)\r
      and not fIsControl\r
   then\r
      fVisible :=\r
        //LongBool( GetWindowLong( fHandle, GWL_STYLE ) and WS_VISIBLE )\r
        IsWindowVisible( fHandle );\r
   Result := fVisible;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.Set_Visible]\r
procedure TControl.Set_Visible( Value: Boolean );\r
const wsVisible = $10;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        //MOV      ESI, EAX\r
        XCHG     ESI, EAX\r
        MOVZX    EBX, DL\r
        {CALL     Get_Visible\r
        CMP      AL, BL\r
        JE       @@reset_fCreateHidden}\r
\r
        MOV      AL, byte ptr [ESI].fStyle + 3\r
        TEST     EBX, EBX\r
        JZ       @@reset_WS_VISIBLE\r
        OR       AL, wsVisible\r
        PUSH     SW_SHOW\r
        JMP      @@store_Visible\r
@@reset_WS_VISIBLE:\r
        AND      AL, not wsVisible\r
        PUSH     SW_HIDE\r
\r
@@store_Visible:\r
        MOV      byte ptr [ESI].fStyle + 3, AL\r
        MOV      [ESI].fVisible, BL\r
        MOV      ECX, [ESI].fHandle\r
        JECXZ    @@after_showwindow\r
\r
        PUSH     ECX\r
        CALL     ShowWindow\r
        PUSH     ECX\r
@@after_showwindow:\r
        POP      ECX\r
\r
        MOV      ECX, [ESI].fParent\r
        JECXZ    @@chk_align_Self\r
        XCHG     EAX, ECX\r
        CALL     dword ptr [Global_Align]\r
\r
@@chk_align_Self:\r
        TEST     EBX, EBX\r
        JZ       @@reset_fCreateHidden\r
        MOV      EAX, ESI\r
        CALL     dword ptr [Global_Align]\r
\r
\r
@@reset_fCreateHidden:\r
        MOV      ECX, [ESI].fHandle\r
        JECXZ    @@exit\r
        TEST     BL, BL\r
        JNZ      @@exit\r
        MOV      [ESI].fCreateHidden, 0 { +++ }\r
@@exit:\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} // Pascal\r
procedure TControl.Set_Visible( Value: Boolean );\r
var CmdShow: DWORD;\r
begin\r
   //if Get_Visible <> Value then // commented to allow to set up controls visibility\r
   begin                          // on invisible form (Vladimir Piven)\r
     if Value then\r
     begin\r
       fStyle := fStyle or WS_VISIBLE;\r
       CmdShow := SW_SHOW;\r
     end\r
        else\r
     begin\r
       fStyle := fStyle and not WS_VISIBLE;\r
       CmdShow := SW_HIDE;\r
     end;\r
     fVisible := Value;\r
     if fHandle = 0 then Exit;\r
     ShowWindow( fHandle, CmdShow );\r
     if fParent <> nil then\r
       Global_Align( fParent );\r
     //else\r
     if Value then\r
       Global_Align( @Self );\r
   end;\r
   if not Value and (fHandle <> 0) then\r
     fCreateHidden := FALSE; // { +++ }\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.SetVisible]\r
procedure TControl.SetVisible( Value: Boolean );\r
begin\r
   fCreateVisible := TRUE;\r
   Set_Visible( Value );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetBoundsRect]\r
function TControl.GetBoundsRect: TRect;\r
asm\r
        PUSH      ESI\r
        PUSH      EDI\r
        LEA       ESI, [EAX].fBoundsRect\r
        MOV       EDI, EDX\r
\r
        PUSH      EDX\r
\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
\r
        POP       EDI\r
\r
        XCHG      ESI, EAX\r
        MOV       ECX, [ESI].fHandle\r
        JECXZ     @@exit\r
\r
        PUSH      EDI\r
        PUSH      ECX\r
        CALL      GetWindowRect\r
\r
        CMP       [ESI].fIsControl, 0\r
        JZ        @@storeBounds\r
\r
        MOV       EAX, [ESI].fParent\r
\r
        TEST      EAX, EAX\r
        JZ        @@exit\r
\r
        XOR       EDX, EDX\r
        PUSH      EDX\r
        PUSH      EDX\r
        MOV       ECX, ESP\r
        PUSH      EDX\r
        PUSH      EDX\r
        MOV       EDX, ESP\r
        CALL      TControl.Client2Screen\r
        POP       EAX\r
        POP       EAX\r
\r
        POP       EAX\r
        NEG       EAX\r
        POP       ECX\r
        NEG       ECX\r
        PUSH      ECX\r
        PUSH      EAX\r
        PUSH      EDI\r
        CALL      OffsetRect\r
\r
@@storeBounds:\r
        XCHG      ESI, EDI\r
        LEA       EDI, [EDI].fBoundsRect\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
\r
@@exit:\r
        POP       EDI\r
        POP       ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetBoundsRect: TRect;\r
var W: PControl;\r
    P: TPoint;\r
begin\r
   Result := fBoundsRect;\r
   if fHandle <> 0 then\r
   begin\r
      GetWindowRect( fHandle, Result );\r
      if fIsControl then\r
      begin\r
        W := fParent; // WindowedParent;\r
        if W <> nil then\r
        begin\r
          P.x := 0; P.y := 0;\r
          P := W.Client2Screen( P );\r
          OffsetRect( Result, -P.x, -P.y );\r
        end;\r
      end;\r
      fBoundsRect := Result;\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[PROCEDURE HelpGetBoundsRect]\r
{$IFDEF ASM_VERSION}\r
procedure HelpGetBoundsRect;\r
asm\r
        POP       ECX\r
        ADD       ESP, - size_TRect\r
        MOV       EDX, ESP\r
        PUSH      ECX\r
        PUSH      EAX\r
        CALL      TControl.GetBoundsRect\r
        POP       EAX\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END HelpGetBoundsRect]\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetBoundsRect]\r
procedure TControl.SetBoundsRect( const Value: TRect );\r
const swp_flags = SWP_NOZORDER or SWP_NOACTIVATE;\r
asm\r
        PUSH      EDI\r
        MOV       EDI, EAX\r
\r
        PUSH      ESI\r
        MOV       ESI, EDX\r
\r
        CALL      HelpGetBoundsRect\r
\r
        MOV       EAX, ESI\r
        MOV       EDX, ESP\r
        CALL      RectsEqual\r
        TEST      AL, AL\r
        JNZ       @@exit\r
\r
        POP       EDX   // left\r
        POP       ECX   // top\r
        POP       EAX   // right\r
        PUSH      EAX\r
        PUSH      ECX\r
        PUSH      EDX\r
\r
        SUB       EAX, EDX  // EAX = width\r
        CMP       EDX, [ESI].TRect.Left\r
        MOV       DL, 0\r
        JE        @@1\r
        INC       EDX\r
@@1:    CMP       ECX, [ESI].TRect.Top\r
        JE        @@2\r
        OR        DL, 2\r
@@2:    OR        [EDI].fChangedPosSz, DL\r
\r
        PUSH      EAX      // W saved\r
\r
        MOV       EAX, [EDI].fBoundsRect.Bottom\r
        SUB       EAX, ECX\r
        PUSH      EAX      // H saved\r
\r
        PUSH      EDI      // @Self saved\r
\r
        LEA       EDI, [EDI].fBoundsRect\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
        MOVSD\r
\r
        MOV       ESI, EDI\r
        POP       EDI     // @ Self restored\r
        MOV       ECX, [EDI].fHandle\r
        JECXZ     @@fin\r
\r
        STD\r
\r
        PUSH      swp_flags\r
\r
        LODSD\r
        LODSD\r
        XCHG      EDX, EAX // EDX = bottom\r
        LODSD\r
        XCHG      ECX, EAX // ECX = right\r
        LODSD\r
        SUB       EDX, EAX // EAX = bottom - top\r
        PUSH      EDX       // push HEIGHT\r
        XCHG      EDX, EAX  // EDX = top\r
        LODSD     // EAX = left\r
        CLD\r
\r
        SUB       ECX, EAX\r
        PUSH      ECX       // push WIDTH\r
\r
        PUSH      EDX       // push TOP\r
        PUSH      EAX       // push LEFT\r
        PUSH      0\r
\r
        PUSH      [EDI].fHandle\r
        CALL      SetWindowPos\r
\r
        CMP       [EDI].fSizeRedraw, 0\r
        JE        @@fin\r
        XCHG      EAX, EDI\r
        CALL      Invalidate  // *MUST* be called?\r
\r
@@fin:\r
        POP       EDX       // H restored\r
        POP       EAX       // W restored\r
\r
@@exit:\r
        ADD       ESP, size_TRect\r
        POP       ESI\r
        POP       EDI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetBoundsRect( const Value: TRect );\r
var Rect: TRect;\r
begin\r
   Rect := GetBoundsRect;\r
   if RectsEqual( Value, Rect ) then Exit;\r
   if Value.Left <> fBoundsRect.Left then fChangedPosSz := fChangedPosSz or 1;\r
   if Value.Top  <> fBoundsRect.Top  then fChangedPosSz := fChangedPosSz or 2;\r
   fBoundsRect := Value;\r
   Rect := Value;\r
\r
   if fHandle <> 0 then\r
   begin\r
     SetWindowPos( fHandle, 0, Rect.Left, Rect.Top, Rect.Right - Rect.Left,\r
                   Rect.Bottom - Rect.Top, SWP_NOZORDER or SWP_NOACTIVATE );\r
     if fSizeRedraw then\r
       Invalidate;\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
const\r
  WindowStateShowCommands: array[TWindowState] of Byte =\r
    (SW_SHOWNOACTIVATE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetWindowState]\r
procedure TControl.SetWindowState( Value: TWindowState );\r
asm     //cmd    //opd\r
        CMP      [EAX].TControl.fWindowState, DL\r
        JE       @@exit\r
        MOV      [EAX].TControl.fWindowState, DL\r
        XCHG     EAX, EDX\r
        CBW\r
        CWDE\r
        MOV      AL, byte ptr [WindowStateShowCommands+EAX]\r
        PUSH     EAX\r
        XCHG     EAX, EDX\r
        CALL     TControl.GetWindowHandle\r
        PUSH     EAX\r
        CALL     ShowWindow\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetWindowState( Value: TWindowState );\r
begin\r
   if fWindowState <> Value then\r
   begin\r
      fWindowState := Value;\r
      ShowWindow(GetWindowHandle, WindowStateShowCommands[Value]);\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.Show]\r
procedure TControl.Show;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CALL     CreateWindow\r
        MOV      DL, 1\r
        MOV      EAX, EBX\r
        CALL     SetVisible\r
        PUSH     [EBX].fHandle\r
        CALL     SetForegroundWindow\r
        XCHG     EAX, EBX\r
        CALL     DoSetFocus\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.Show;\r
begin\r
   CreateWindow;\r
   SetVisible( True );\r
   SetForegroundWindow( Handle );\r
   DoSetFocus;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.Hide]\r
procedure TControl.Hide;\r
begin\r
   SetVisible( False );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Client2Screen]\r
function TControl.Client2Screen( const P: TPoint ): TPoint;\r
asm\r
        PUSH      ESI\r
        PUSH      EDI\r
\r
        MOV       ESI, EDX\r
        MOV       EDI, ECX\r
\r
        MOVSD\r
        MOVSD\r
\r
        PUSH      ECX\r
        MOV       ECX, [EAX].fHandle\r
        JECXZ     @@exit\r
\r
        PUSH      ECX\r
        CALL      ClientToScreen\r
        PUSH      ECX\r
\r
@@exit: POP       ECX\r
        POP       EDI\r
        POP       ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Client2Screen( const P: TPoint ): TPoint;\r
begin\r
   Result := P;\r
   if fHandle <> 0 then\r
      Windows.ClientToScreen( fHandle, Result );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Screen2Client]\r
function TControl.Screen2Client( const P: TPoint ): TPoint;\r
asm\r
        PUSH      ESI\r
        PUSH      EDI\r
\r
        MOV       ESI, EDX\r
        MOV       EDI, ECX\r
\r
        MOVSD\r
        MOVSD\r
\r
        PUSH      ECX\r
        MOV       ECX, [EAX].fHandle\r
        JECXZ     @@exit\r
\r
        PUSH      ECX\r
        CALL      ScreenToClient\r
        PUSH      ECX\r
\r
@@exit: POP       ECX\r
        POP       EDI\r
        POP       ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Screen2Client( const P: TPoint ): TPoint;\r
begin\r
   Result := P;\r
   if Handle <> 0 then\r
      Windows.ScreenToClient( Handle, Result );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.ClientRect]\r
function TControl.ClientRect: TRect;\r
asm\r
        PUSH      [EAX].fClientLeft\r
        PUSH      [EAX].fClientRight\r
        PUSH      [EAX].fClientTop\r
        PUSH      [EAX].fClientBottom\r
        PUSH      EDX\r
        PUSH      EDX      // prepare 'dest' for GetClientRect\r
\r
          PUSH      EAX\r
            LEA       EAX, [EAX].fBoundsRect\r
\r
            XOR       ECX, ECX\r
            MOV       CL, size_TRect\r
\r
            CALL      System.Move\r
          POP       EAX  // EAX = @Self\r
\r
          CALL      TControl.GetWindowHandle\r
\r
          // this version is more correct ?:\r
          //------------------------------\r
          {PUSH      EAX\r
          CALL      CallTControlCreateWindow\r
          POP       EAX\r
          MOV       EAX, [EAX].fHandle}\r
          //-------------------------------\r
\r
          TEST      EAX, EAX\r
          JZ        @@exit\r
\r
          PUSH      EAX    // prepare 'handle' for GetClientRect\r
          CALL      GetClientRect\r
          PUSH      EAX\r
\r
@@exit: POP       EDX\r
        POP       EDX  // EDX = @Result\r
        POP       EAX  // EAX = fClientBottom\r
        SUB       [EDX].TRect.Bottom, EAX\r
        POP       EAX  // EAX = fClientTop\r
        ADD       [EDX].TRect.Top, EAX  // Correct Result.Top\r
        POP       EAX  // EAX = fClientRight\r
        SUB       [EDX].TRect.Right, EAX\r
        POP       EAX // EAX = fClientLeft\r
        ADD       [EDX].TRect.Left, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.ClientRect: TRect;\r
const BorderParams: array[ 0..5 ] of DWORD =\r
      ( SM_CXBORDER, SM_CXFRAME, SM_CXSIZEFRAME, SM_CYBORDER, SM_CYFRAME, SM_CYSIZEFRAME );\r
begin\r
   Result := fBoundsRect;\r
   GetWindowHandle;\r
   //CreateWindow; //virtual!!!\r
   if (fHandle <> 0) then\r
      GetClientRect( fHandle, Result );\r
   Inc( Result.Top, fClientTop );\r
   Dec( Result.Bottom, fClientBottom );\r
   Inc( Result.Left, fClientLeft );\r
   Dec( Result.Right, fClientRight );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.Invalidate]\r
procedure TControl.Invalidate;\r
asm\r
        XOR       EDX, EDX\r
        CMP       [AppletTerminated], DL\r
        JNZ       @@exit\r
        MOV       ECX, [EAX].fHandle\r
        JECXZ     @@exit\r
        PUSH      EAX\r
        PUSH      1\r
        PUSH      EDX //=0\r
        PUSH      ECX\r
        CALL      Windows.InvalidateRect\r
        POP       EAX\r
        CALL      dword ptr[Global_Invalidate]\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.Invalidate;\r
begin\r
   if AppletTerminated then Exit;\r
   if fHandle = 0 then Exit;\r
   InvalidateRect( fHandle, nil, True );\r
\r
   Global_Invalidate( @Self );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetIcon]\r
function TControl.GetIcon: HIcon;\r
asm\r
        PUSH      EBX\r
        XCHG      EBX, EAX\r
        MOV       EAX, [EBX].fIcon\r
        INC       EAX\r
        JZ        @@exit\r
        DEC       EAX\r
        JNZ       @@exit\r
\r
        MOV       ECX, [Applet]\r
        JECXZ     @@load\r
        CMP       ECX, EBX\r
        JZ        @@load\r
\r
        XCHG      EAX, ECX\r
        CALL      TControl.GetIcon\r
        TEST      EAX, EAX\r
        JZ        @@exit\r
\r
        XOR       EDX, EDX\r
        PUSH      EDX\r
        PUSH      EDX\r
        PUSH      EDX\r
        INC       EDX  // IMAGE_ICON = 1\r
        PUSH      EDX\r
        PUSH      EAX\r
        CALL      CopyImage\r
        JMP       @@store_fIcon\r
\r
@@main_icon:\r
        DB  'MAINICON',0\r
\r
@@load:\r
        PUSH      offset @@main_icon\r
        PUSH      [hInstance]\r
        CALL      LoadIcon\r
@@store_fIcon:\r
        MOV       [EBX].fIcon, EAX\r
@@exit:\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetIcon: HIcon;\r
begin\r
   Result := fIcon;\r
   if Result = THandle( -1 ) then\r
   begin\r
     Result := 0;\r
     Exit;\r
   end;\r
   if Result = 0 then\r
   if (Assigned( Applet )) and\r
      (@Self <> Applet) then\r
   begin\r
      Result := Applet.Icon;\r
      if Result <> 0 then\r
        Result := CopyImage( Result, IMAGE_ICON, 0, 0, 0 );\r
   end\r
     else\r
   begin\r
     //if Result = 0 then\r
        Result := LoadIcon( hInstance, 'MAINICON' );\r
        //Result := LoadImage( hInstance, 'MAINICON', IMAGE_ICON, 16, 16, LR_SHARED );\r
   end;\r
   fIcon := Result;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[procedure TControl.IconLoad]\r
procedure TControl.IconLoad(Inst: Integer; ResName: PChar);\r
begin\r
  Icon := LoadIcon( Inst, ResName );\r
  fIconShared := TRUE;\r
end;\r
\r
//[procedure TControl.IconLoadCursor]\r
procedure TControl.IconLoadCursor(Inst: Integer; ResName: PChar);\r
begin\r
  Icon := LoadCursor( Inst, ResName );\r
  fIconShared := TRUE;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.CallDefWndProc]\r
function TControl.CallDefWndProc(var Msg: TMsg): Integer;\r
asm\r
        PUSH     [EDX].TMsg.lParam\r
        PUSH     [EDX].TMsg.wParam\r
        PUSH     [EDX].TMsg.message\r
\r
        MOV      ECX, [EAX].fDefWndProc\r
        JECXZ    @@defwindowproc\r
\r
        PUSH     [EAX].fHandle\r
        PUSH     ECX\r
        CALL     CallWindowProc\r
        RET\r
\r
@@defwindowproc:\r
        PUSH     [EDX].TMsg.hwnd\r
        CALL     DefWindowProc\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.CallDefWndProc(var Msg: TMsg): Integer;\r
begin\r
    if FDefWndProc <> nil then\r
       Result := CallWindowProc( FDefWndProc, FHandle, Msg.message, Msg.wParam, Msg.lParam )\r
    else\r
       Result := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetWindowState]\r
function TControl.GetWindowState: TWindowState;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        PUSH     ESI\r
        XCHG     ESI, EAX\r
        MOVZX    EBX, [ESI].TControl.fWindowState\r
        MOV      ECX, [ESI].TControl.fHandle\r
        JECXZ    @@ret_EBX\r
        MOV      BL, 2\r
        MOV      ESI, ECX\r
        PUSH     ESI\r
        CALL     IsZoomed\r
        TEST     EAX, EAX\r
        JNZ      @@ret_EBX\r
        DEC      EBX\r
        PUSH     ESI\r
        CALL     IsIconic\r
        TEST     EAX, EAX\r
        JNZ      @@ret_EBX\r
        DEC      EBX\r
@@ret_EBX:\r
        XCHG     EAX, EBX\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetWindowState: TWindowState;\r
begin\r
   Result := fWindowState;\r
   if Handle <> 0 then\r
   begin\r
      if IsIconic( Handle ) then\r
         Result := wsMinimized\r
      else\r
      if IsZoomed( Handle ) then\r
         Result := wsMaximized\r
      else\r
         Result := wsNormal;\r
      fWindowState := Result;\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.DoSetFocus]\r
function TControl.DoSetFocus: Boolean;\r
asm\r
        PUSH      ESI\r
        MOV       ESI, EAX\r
\r
        {MOV       EDX, [ESI].fStyle\r
        TEST      EDX, WS_TABSTOP\r
        JZ        @@exit}\r
\r
        CALL      GetEnabled\r
        TEST      AL, AL\r
        JZ        @@exit\r
\r
        XOR       EAX, EAX\r
        CMP       [ESI].fTabstop, AL\r
        JZ        @@exit\r
\r
        INC       [ESI].TControl.fClickDisabled\r
\r
        PUSH      [ESI].fHandle\r
        CALL      SetFocus\r
\r
        DEC       [ESI].TControl.fClickDisabled\r
\r
        MOV       AL, 1\r
\r
@@exit:\r
        POP       ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.DoSetFocus: Boolean;\r
begin\r
  Result := False;\r
  if Enabled and fTabstop {and (fStyle and WS_TABSTOP <> 0)} then\r
  begin\r
    Inc( fClickDisabled );\r
    SetFocus( fHandle );\r
    Dec( fClickDisabled );\r
    Result := True;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TControl.HandleAllocated]\r
function TControl.HandleAllocated: Boolean;\r
begin\r
  Result := FHandle <> 0;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetEnabled]\r
function TControl.GetEnabled: Boolean;\r
asm\r
        MOV       ECX, [EAX].fHandle\r
        JECXZ     @@get_field\r
\r
        PUSH      ECX\r
        CALL      IsWindowEnabled\r
        {                  but 00000001 is returned anywhere...\r
        NEG       EAX\r
        SBB       EAX, EAX\r
        NEG       EAX\r
        }\r
        RET\r
\r
@@get_field:\r
        TEST      byte ptr [EAX].fStyle + 3, 8 //WS_DISABLED shr 3\r
        SETZ      AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetEnabled: Boolean;\r
begin\r
  if FHandle = 0 then\r
     Result := (Style and WS_DISABLED) = 0\r
  else\r
     Result := IsWindowEnabled( FHandle );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.IsMainWindow]\r
function TControl.IsMainWindow: Boolean;\r
asm\r
        CMP       [EAX].fIsControl, 0\r
        JNZ       @@no_notmain\r
\r
        XCHG      EDX, EAX\r
        MOV       EAX, [EDX].fParent\r
\r
        TEST      EAX, EAX\r
        JZ        @@1\r
\r
        MOV       ECX, [EAX].fParent\r
        INC       ECX\r
        LOOP      @@no_notmain\r
\r
        MOV       EAX, [EAX].fChildren\r
\r
        MOV       ECX, [EAX].TList.fCount\r
        JECXZ     @@no_notmain\r
\r
        MOV       EAX, [EAX].TList.fItems\r
        CMP       EDX, [EAX]\r
        MOV       AL, 1\r
        JMP       @@2\r
@@1:\r
        INC       EAX\r
        MOVZX     ECX, [AppButtonUsed]\r
        JECXZ     @@yes_main\r
        CMP       EDX, [Applet]\r
@@2:\r
        JZ        @@yes_main\r
\r
@@no_notmain:\r
        XOR       EAX, EAX\r
@@yes_main:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.IsMainWindow: Boolean;\r
var A: PControl;\r
begin\r
  Result := False;\r
  if fIsControl then Exit;\r
  A := fParent; // WindowedParent;\r
  if A = nil then\r
  begin\r
    Result := (@Self = Applet) or not AppButtonUsed;\r
    Exit;\r
  end\r
     else\r
  if A.fParent <> nil then Exit;\r
  //--------------------------------------------------------------------------------\r
  if A.fChildren.fCount = 0 then Exit; // by ECM, fixes AV when user changed (logoff)\r
  //--------------------------------------------------------------------------------\r
  Result := A.fChildren.fItems[ 0 ] = @Self;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.get_ClassName]\r
function TControl.get_ClassName: String;\r
asm\r
        PUSH      EBX\r
        XCHG      EBX, EAX\r
        XCHG      EAX, EDX\r
        MOV       EDX, [EBX].fControlClassName\r
        PUSH      EAX\r
        CALL      System.@LStrFromPChar\r
        POP       EAX\r
        CMP       [EBX].fCtlClsNameChg, 0\r
        JNZ       @@exit\r
        MOV       ECX, [EAX]\r
        MOV       EDX, offset[ @@obj ]\r
        CALL      System.@LStrCat3\r
        JMP       @@exit\r
\r
        DD        -1, 4\r
@@obj:  DB        'obj_', 0\r
\r
@@exit:\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.get_ClassName: String;\r
begin\r
  if not fCtlClsNameChg then\r
    Result := 'obj_' + fControlClassName\r
  else\r
    Result := fControlClassName;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.set_ClassName]\r
procedure TControl.set_ClassName(const Value: String);\r
begin\r
  if fCtlClsNameChg then\r
    FreeMem( fControlClassName );\r
  GetMem( fControlClassName, Length( Value ) + 1 );\r
  StrCopy( fControlClassName, @ Value[ 1 ] );\r
  fCtlClsNameChg := TRUE;\r
end;\r
\r
//[function WndProcQueryEndSession]\r
function WndProcQueryEndSession( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Accept: Boolean;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_QUERYENDSESSION then\r
  begin\r
    if Assigned( Sender.fOnQueryEndSession ) then\r
    begin\r
      Accept := TRUE;\r
      Sender.fCloseQueryReason := qShutdown;\r
      if LongBool(Msg.lParam and {ENDSESSION_LOGOFF} DWORD($80000000)) then\r
        Sender.fCloseQueryReason := qLogoff;\r
      Sender.fOnQueryEndSession( Sender, Accept );\r
      Sender.fCloseQueryReason := qClose;\r
      Rslt := Integer( Accept );\r
      // Äîáàâèòü. Íóæíî äëÿ òîãî, ÷òîáû îòìåíèëîñü çàâåðøåíèå ñåàíñà,\r
      // åñëè Accept óñòàíîâëåí â False è ñåàíñ çàâåðøèëñÿ ïðè Accept = True\r
      // Add (YS). To cancel ending session if Accept=FALSE but allow ending\r
      // session if Accept=TRUE.\r
      Result := True;  // {YS}: no further processing\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnQueryEndSession]\r
procedure TControl.SetOnQueryEndSession(const Value: TOnEventAccept);\r
begin\r
  AttachProc( WndProcQueryEndSession );\r
  fOnQueryEndSession := Value;\r
end;\r
\r
//[function WndProcMinMaxRestore]\r
function WndProcMinMaxRestore( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_SYSCOMMAND then\r
  begin\r
    case Msg.wParam of\r
    SC_MINIMIZE: if Assigned( Sender.fOnMinimize ) then\r
                   Sender.fOnMinimize( Sender );\r
    SC_MAXIMIZE: if Assigned( Sender.fOnMaximize ) then\r
                   Sender.fOnMaximize( Sender );\r
    SC_RESTORE:  if Assigned( Sender.fOnRestore ) then\r
                   Sender.fOnRestore( Sender );\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnMinMaxRestore]\r
procedure TControl.SetOnMinMaxRestore(const Index: Integer;\r
  const Value: TOnEvent);\r
type POnEvent = ^TOnEvent;\r
{$IFDEF F_P}\r
var Ptr1: Pointer;\r
{$ELSE DELPHI}\r
var Ev: POnEvent;\r
{$ENDIF F_P/DELPHI}\r
begin\r
  AttachProc( WndProcMinMaxRestore );\r
  {$IFDEF F_P}\r
  Ptr1 := Self;\r
  asm\r
    MOV  EAX, [Ptr1]\r
    LEA  EAX, [EAX].TControl.fOnMinimize\r
    ADD  EAX, [Index]\r
    MOV  EDX, [Value]\r
    MOV  [EAX], EDX\r
    MOV  EDX, [Value+4]\r
    MOV  [EAX+4], EDX\r
  end [ 'EAX', 'EDX' ];\r
  {$ELSE DELPHI}\r
  Ev := Pointer( Integer( @ TMethod( fOnMinimize ).Code ) + Index );\r
  //Ev := Pointer( Integer( @ fOnMinimize ) + Index );\r
  Ev^ := Value;\r
  {$ENDIF}\r
end;\r
\r
{$IFDEF F_P}\r
//[function TControl.GetOnMinMaxRestore]\r
function TControl.GetOnMinMaxRestore(const Index: Integer): TOnEvent;\r
begin\r
  CASE Index OF\r
  0: Result := fOnMinimize;\r
  8: Result := fOnMaximize;\r
  16: Result := fOnRestore;\r
  END;\r
end;\r
{$ENDIF F_P}\r
\r
{$IFDEF INPACKAGE}\r
  {$IFDEF ASM_LOCAL}\r
    {$UNDEF ASM_LOCAL}\r
  {$ENDIF}\r
{$ELSE}\r
  {$IFDEF ASM_VERSION}\r
    {$DEFINE ASM_LOCAL}\r
  {$ENDIF}\r
{$ENDIF}\r
\r
{$IFDEF ASM_LOCAL} \r
//[procedure TControl.SetParent]\r
procedure TControl.SetParent( Value: PControl );\r
asm\r
        PUSH     EBX\r
        PUSH     EDI\r
        XCHG     EBX, EAX\r
        MOV      EDI, [EBX].fParent\r
\r
        CMP      EDX, EDI\r
        JZ       @@exit\r
\r
        PUSH     EDX\r
        TEST     EDI, EDI\r
        JZ       @@set_another_parent\r
\r
        MOV      EAX, [EDI].fChildren\r
        MOV      EDX, EBX\r
        CALL     TList.Remove\r
\r
        MOV      ECX, [EDI].fNotifyChild\r
        JECXZ    @@set_another_parent\r
\r
        MOV      EAX, EDI\r
        XOR      EDX, EDX\r
        CALL     ECX\r
\r
@@set_another_parent:\r
        POP      EDI\r
        MOV      [EBX].fParent, EDI\r
        TEST     EDI, EDI\r
        JZ       @@exit\r
\r
        MOV      EAX, [EDI].fChildren\r
        MOV      EDX, EBX\r
        CALL     TList.Add\r
\r
        {$IFNDEF INPACKAGE}\r
        MOV      ECX, [EBX].FHandle\r
        JECXZ    @@parentwnd_assigned\r
        PUSH     ECX\r
        MOV      EAX, EDI\r
        CALL     GetWindowHandle\r
        POP      ECX\r
        PUSH     EAX\r
        PUSH     ECX\r
        CALL     Windows.SetParent\r
\r
@@parentwnd_assigned:\r
        {$ENDIF}\r
\r
        MOV      ECX, [EDI].fNotifyChild\r
        JECXZ    @@exit\r
\r
        MOV      EAX, EDI\r
        MOV      EDX, EBX\r
        CALL     ECX\r
\r
@@exit:\r
        POP      EDI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetParent( Value: PControl );\r
begin\r
   if Value = fParent then Exit;\r
   if fParent <> nil then\r
   begin\r
     fParent.fChildren.Remove( @Self );\r
     if Assigned( fParent.fNotifyChild ) then\r
       fParent.fNotifyChild( fParent, nil );\r
   end;\r
   fParent := Value;\r
   if fParent <> nil then\r
   begin\r
     fParent.fChildren.Add( @Self );\r
     {$IFNDEF INPACKAGE}\r
     if FHandle <> 0 then\r
       Windows.SetParent( FHandle, Value.GetWindowHandle );\r
     {$ENDIF}\r
     if Assigned( fParent.fNotifyChild ) then\r
       fParent.fNotifyChild( fParent, @ Self );\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TControl.ChildIndex]\r
function TControl.ChildIndex(Child: PControl): Integer;\r
begin\r
  Result := fChildren.IndexOf( Child );\r
end;\r
\r
//*\r
//[procedure TControl.MoveChild]\r
procedure TControl.MoveChild(Child: PControl; NewIdx: Integer);\r
var I: Integer;\r
begin\r
  I := ChildIndex( Child );\r
  Assert( I>=0, 'TControl.MoveChild: index out of bounds' );\r
  fChildren.MoveItem( I, NewIdx );\r
end;\r
\r
//[procedure TControl.EnableChildren]\r
procedure TControl.EnableChildren(Enable, Recursive: Boolean);\r
var I: Integer;\r
    C: PControl;\r
begin\r
  for I := 0 to ChildCount-1 do\r
  begin\r
    C := Children[ I ];\r
    C.Enabled := Enable;\r
    if Recursive then\r
      C.EnableChildren( Enable, TRUE );\r
  end;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[constructor TControl.CreateParented]\r
constructor TControl.CreateParented(AParent: PControl);\r
asm     //cmd    //opd\r
        //CALL     System.@ObjSetup // generated automatically\r
        //JZ       @@exit           // generated automatically\r
        PUSH     EAX\r
        MOV      EDX, ECX\r
        MOV      ECX, [EAX]\r
        CALL     dword ptr [ECX+8]\r
        POP      EAX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
constructor TControl.CreateParented(AParent: PControl);\r
begin\r
  InitParented( AParent );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetLeft]\r
function TControl.GetLeft: Integer;\r
asm\r
        CALL      HelpGetBoundsRect\r
        POP       EAX\r
\r
        POP       ECX\r
        POP       ECX\r
        POP       ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetLeft: Integer;\r
begin\r
   Result := BoundsRect.Left;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetLeft]\r
procedure TControl.SetLeft( Value: Integer );\r
asm\r
        PUSH      EDI\r
\r
        PUSH      EDX\r
        CALL      HelpGetBoundsRect\r
        POP       EDX           // EDX = Left\r
        POP       ECX           // ECX = Top\r
        POP       EDI           // EDI = Right\r
\r
        SUB       EDI, EDX      // EDI = width\r
        MOV       EDX, [ESP+4]  // EDX = Left'\r
        ADD       EDI, EDX      // EDI = Right'\r
\r
        PUSH      EDI\r
        PUSH      ECX\r
        PUSH      EDX\r
        MOV       EDX, ESP\r
\r
        CALL      SetBoundsRect\r
        ADD       ESP, size_TRect + 4\r
\r
        POP       EDI\r
\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetLeft( Value: Integer );\r
var R: TRect;\r
begin\r
   R := BoundsRect;\r
   R.Left := Value;\r
   R.Right := Value + Width;\r
   SetBoundsRect( R );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetTop]\r
function TControl.GetTop: Integer;\r
asm\r
        CALL      HelpGetBoundsRect\r
        POP       EDX\r
          POP       EAX\r
        POP       EDX\r
        POP       EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetTop: Integer;\r
begin\r
   Result := BoundsRect.Top;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetTop]\r
procedure TControl.SetTop( Value: Integer );\r
asm\r
        PUSH      ESI\r
        PUSH      EDI\r
\r
          PUSH      EDX\r
        CALL      HelpGetBoundsRect\r
        POP       EDX           // EDX = Left\r
        POP       ECX           // ECX = Top\r
        POP       EDI           // EDI = Right\r
        POP       ESI           // ESI = Bottom\r
\r
        SUB       ESI, ECX      // ESI = Height'\r
          POP       ECX         // ECX = Top'\r
        ADD       ESI, ECX      // ESI = Bottom'\r
\r
        PUSH      ESI\r
        PUSH      EDI\r
        PUSH      ECX\r
        PUSH      EDX\r
        MOV       EDX, ESP\r
\r
        CALL      SetBoundsRect\r
        ADD       ESP, size_TRect\r
\r
        POP       EDI\r
        POP       ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetTop( Value: Integer );\r
var R: TRect;\r
begin\r
   R := BoundsRect;\r
   R.Top := Value;\r
   R.Bottom := Value + Height;\r
   SetBoundsRect( R );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetWidth]\r
function TControl.GetWidth: Integer;\r
asm\r
        CALL      HelpGetBoundsRect\r
        POP       EDX\r
          POP       ECX\r
        POP       EAX\r
        SUB       EAX, EDX\r
          POP       ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetWidth: Integer;\r
begin\r
  with BoundsRect do\r
    Result := Right - Left;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetWidth]\r
procedure TControl.SetWidth( Value: Integer );\r
asm\r
        PUSH      EDX\r
\r
        CALL      HelpGetBoundsRect\r
        POP       EDX\r
        PUSH      EDX\r
        ADD       EDX, [ESP].size_TRect\r
        MOV       [ESP].TRect.Right, EDX\r
\r
        MOV       EDX, ESP\r
        CALL      SetBoundsRect\r
\r
        ADD       ESP, size_TRect + 4\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetWidth( Value: Integer );\r
var R: TRect;\r
begin\r
  R := BoundsRect;\r
  with R do\r
    Right := Left + Value;\r
  SetBoundsRect( R );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetHeight]\r
function TControl.GetHeight: Integer;\r
asm\r
        CALL      HelpGetBoundsRect\r
        POP       ECX\r
        POP       EDX          // EDX = top\r
        POP       ECX\r
        POP       EAX          // EAX = bottom\r
        SUB       EAX, EDX     // result = height\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetHeight: Integer;\r
begin\r
  with BoundsRect do\r
   Result := Bottom - Top;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetHeight]\r
procedure TControl.SetHeight( Value: Integer );\r
asm\r
        PUSH      EDX\r
\r
        CALL      HelpGetBoundsRect\r
        MOV       EDX, [ESP].TRect.Top\r
        ADD       EDX, [ESP].size_TRect\r
        MOV       [ESP].TRect.Bottom, EDX\r
\r
        MOV       EDX, ESP\r
        CALL      SetBoundsRect\r
\r
        ADD       ESP, size_TRect + 4\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetHeight( Value: Integer );\r
var R: TRect;\r
begin\r
   R := BoundsRect;\r
   with R do\r
     Bottom := Top + Value;\r
   SetBoundsRect( R );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetPosition]\r
function TControl.GetPosition: TPoint;\r
asm\r
        PUSH      EDX\r
        CALL      HelpGetBoundsRect\r
        POP       EAX         // EAX = left\r
        POP       ECX         // ECX = top\r
        POP       EDX\r
        POP       EDX\r
        POP       EDX         // EDX = @Result\r
        MOV       [EDX], EAX\r
        MOV       [EDX+4], ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetPosition: TPoint;\r
begin\r
  Result.x := BoundsRect.Left;\r
  Result.y := BoundsRect.Top;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.Set_Position]\r
procedure TControl.Set_Position( Value: TPoint );\r
asm\r
        PUSH      ESI\r
        PUSH      EDI\r
\r
        PUSH      EAX\r
        PUSH      EDX\r
        CALL      HelpGetBoundsRect\r
        POP       EDX           // left\r
        POP       EAX           // top\r
        POP       ECX           // right\r
        SUB       ECX, EDX      // ECX = width\r
        POP       EDX           // bottom\r
        SUB       EDX, EAX      // EDX = height\r
        POP       EAX           // EAX = @Value\r
        POP       ESI           // ESI = @Self\r
\r
        MOV       EDI, [EAX+4]  // top'\r
        ADD       EDX, EDI\r
        PUSH      EDX           // bottom'\r
\r
        MOV       EAX, [EAX]    // left'\r
        ADD       ECX, EAX\r
        PUSH      ECX           // right'\r
\r
        PUSH      EDI           // top'\r
        PUSH      EAX           // left'\r
\r
        MOV       EAX, ESI\r
        MOV       EDX, ESP\r
        CALL      SetBoundsRect\r
\r
        ADD       ESP, size_TRect\r
\r
        POP       EDI\r
        POP       ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.Set_Position( Value: TPoint );\r
var R: TRect;\r
begin\r
   R.Top := Value.y;\r
   R.Left := Value.x;\r
   R.Right := R.Left + Width;\r
   R.Bottom := R.Top + Height;\r
   BoundsRect := R;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function WndProcConstraints]\r
function WndProcConstraints( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var MMI: PMinMaxInfo;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_GETMINMAXINFO then\r
  begin\r
    Rslt := Sender.CallDefWndProc( Msg );\r
    MMI := Pointer( Msg.lParam );\r
    if Sender.FMaxWidth > 0 then\r
    begin\r
      MMI.ptMaxSize.x := Sender.FMaxWidth;\r
      MMI.ptMaxTrackSize.x := Sender.FMaxWidth;\r
    end;\r
    if Sender.FMaxHeight > 0 then\r
    begin\r
      MMI.ptMaxSize.y := Sender.FMaxHeight;\r
      MMI.ptMaxTrackSize.y := Sender.FMaxHeight;\r
    end;\r
    MMI.ptMinTrackSize := MakePoint( Sender.FMinWidth, Sender.FMinHeight );\r
    Rslt := 0;\r
    Result := TRUE;\r
  end;\r
end;\r
\r
{$IFDEF USE_MHTOOLTIP}\r
{$DEFINE implementation}\r
{$I KOLMHToolTip}\r
{$UNDEF implementation}\r
{$ENDIF}\r
\r
//[procedure TControl.SetConstraint]\r
procedure TControl.SetConstraint(const Index, Value: Integer);\r
begin\r
  AttachProc( WndProcConstraints );\r
  case Index of\r
  0: FMinWidth := Value;\r
  1: FMinHeight := Value;\r
  2: FMaxWidth := Value;\r
  3: FMaxHeight := Value;\r
  end;\r
end;\r
\r
{$IFDEF F_P}\r
//[function TControl.GetConstraint]\r
function TControl.GetConstraint(const Index: Integer): Integer;\r
begin\r
  CASE Index OF\r
  0: Result := FMinWidth;\r
  1: Result := FMinHeight;\r
  2: Result := FMaxWidth;\r
  3: Result := FMaxHeight;\r
  END;\r
end;\r
{$ENDIF F_P}\r
\r
//*\r
//[function TControl.ControlRect]\r
function TControl.ControlRect: TRect;\r
var C: PControl;\r
    R: TRect;\r
begin\r
   Result := BoundsRect;\r
   C := Parent;\r
   if C <> nil then\r
   begin\r
      //DoScrollOffset( @Result );\r
\r
      if not C.fIsControl then Exit;\r
\r
      R := C.ControlRect;\r
      OffsetRect( Result, R.Left, R.Top );\r
\r
      if C.fChildren <> nil then\r
      if C.FChildren.IndexOf( @Self ) >= C.MembersCount then\r
      begin\r
         R := C.ClientRect;\r
         Dec( R.Top, C.fClientTop );\r
         Dec( R.Left, C.fClientLeft );\r
         OffsetRect( Result, R.Left, R.Top );\r
      end;\r
   end;\r
end;\r
\r
//*\r
//[function TControl.ControlAtPos]\r
function TControl.ControlAtPos( X, Y: Integer;\r
                                   IgnoreDisabled: Boolean ): PControl;\r
var I: Integer;\r
    C: PControl;\r
    CR, VR: TRect;\r
begin\r
   Result := nil;\r
   CR := ControlRect;\r
   if Windowed then\r
      CR := MakeRect( 0, 0, 0, 0 );\r
   X := X + CR.Left; // - R.Left;\r
   Y := Y + CR.Top; // - R.Top;\r
   for I := ChildCount { + MembersCount } - 1 downto 0 do\r
   begin\r
      C := Children[ I ]; //Members[ I ];\r
      if C.Visible then\r
      if (not IgnoreDisabled) or IgnoreDisabled and C.Enabled then\r
      begin\r
         VR := C.ControlRect;\r
         if (X >= VR.Left) and (X < VR.Right) and\r
            (Y >= VR.Top) and (Y < VR.Bottom) then\r
         begin\r
            Result := C;\r
            Exit;\r
         end;\r
      end;\r
   end;\r
end;\r
\r
//[PROCEDURE DefaultPaintBackground]\r
{$IFDEF ASM_VERSION}\r
procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );\r
asm\r
        PUSH      EDI\r
\r
        PUSH      EDI\r
        MOV       EDI, ESP\r
\r
        PUSH      ECX\r
        PUSH      EDX\r
\r
        MOV       EAX, [EAX].TControl.fColor\r
        CALL      Color2RGB\r
        PUSH      EAX\r
        CALL      CreateSolidBrush\r
        STOSD\r
        MOV       EDI, EAX\r
        CALL      windows.FillRect\r
        PUSH      EDI\r
        CALL      DeleteObject\r
        POP       EDI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );\r
var B: HBrush;\r
begin\r
  B := CreateSolidBrush( Color2Rgb( Sender.Color ) );\r
  Windows.FillRect( DC, Rect^, B );\r
  DeleteObject( B );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END DefaultPaintBackground]\r
\r
//[procedure TControl.PaintBackground]\r
procedure TControl.PaintBackground( DC: HDC; Rect: PRect );\r
begin\r
  Global_OnPaintBkgnd( @Self, DC, Rect );\r
end;\r
\r
//[procedure TControl.SetCtlColor]\r
{$IFDEF ASM_VERSION}\r
procedure TControl.SetCtlColor( Value: TColor );\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        {$IFNDEF INPACKAGE}\r
        PUSH     EDX\r
\r
        CALL     GetWindowHandle\r
        XCHG     ECX, EAX\r
\r
        POP      EDX\r
        {$ELSE}\r
        MOV      ECX, [EBX].fHandle\r
        {$ENDIF}\r
\r
        JECXZ    @@1\r
\r
        MOVZX    ECX, [EBX].fCommandActions.aSetBkColor\r
        JECXZ    @@1\r
\r
        PUSH     EDX\r
\r
        XCHG     EAX, EDX\r
        PUSH     ECX\r
        CALL     Color2RGB\r
        POP      ECX\r
\r
        PUSH     EAX        // Color2RGB( Value )\r
        PUSH     0          // 0\r
        PUSH     ECX        // fCommandActions.aSetBkColor\r
        PUSH     EBX        // @ Self\r
        CALL     TControl.Perform\r
\r
        POP      EDX\r
\r
@@1:\r
        CMP      EDX, [EBX].fColor\r
        JZ       @@exit\r
\r
        MOV      [EBX].fColor, EDX\r
\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EBX].fTmpBrush\r
        JECXZ    @@setbrushcolor\r
\r
        PUSH     EDX\r
        PUSH     ECX\r
        CALL     DeleteObject\r
        POP      EDX\r
\r
@@setbrushcolor:\r
        MOV      ECX, [EBX].fBrush\r
        JECXZ    @@invldte\r
\r
        XCHG     EAX, ECX\r
        MOV      ECX, EDX\r
        //MOV      EDX, go_Color\r
        XOR      EDX, EDX\r
        CALL     TGraphicTool.SetInt\r
\r
@@invldte:\r
        XCHG     EAX, EBX\r
        CALL     TControl.Invalidate\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetCtlColor( Value: TColor );\r
begin\r
  {$IFNDEF INPACKAGE}\r
  if GetWindowHandle <> 0 then\r
  {$ELSE}\r
  if fHandle <> 0 then\r
  {$ENDIF}\r
  if fCommandActions.aSetBkColor <> 0 then\r
    Perform( fCommandActions.aSetBkColor, 0, Color2RGB( Value ) );\r
  if fColor = Value then Exit;\r
  fColor := Value;\r
  if fTmpBrush <> 0 then\r
  begin\r
    DeleteObject( fTmpBrush );\r
    fTmpBrush := 0;\r
  end;\r
  if fBrush <> nil then\r
    fBrush.Color := Value;\r
  Invalidate;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetParentWnd]\r
function TControl.GetParentWnd( NeedHandle: Boolean ): HWnd;\r
asm\r
        MOV       ECX, [EAX].fParent\r
        JECXZ     @@exit\r
\r
        PUSH      ECX\r
        TEST      DL, DL\r
        JZ        @@load_handle\r
\r
        XCHG      EAX, ECX\r
        CALL      GetWindowHandle\r
\r
@@load_handle:\r
        POP       ECX\r
        MOV       ECX, [ECX].fHandle\r
\r
@@exit: XCHG      EAX, ECX\r
\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetParentWnd( NeedHandle: Boolean ): HWnd;\r
var C: PControl;\r
begin\r
   Result := 0;\r
   C := fParent; // WindowedParent;\r
   if C <> nil then\r
   begin\r
     if NeedHandle then\r
        C.GetWindowHandle;\r
     Result := C.fHandle;\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.CreateChildWindows]\r
procedure TControl.CreateChildWindows;\r
asm\r
        PUSH      ESI\r
        MOV       ESI, [EAX].TControl.fChildren\r
        MOV       ECX, [ESI].TList.fCount\r
        MOV       ESI, [ESI].TList.fItems\r
        JECXZ     @@exit\r
\r
@@loop: PUSH      ECX\r
        LODSD\r
        CALL      CallTControlCreateWindow\r
        //CALL      TControl.GetWindowHandle\r
        POP       ECX\r
        LOOP      @@loop\r
\r
@@exit: POP       ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.CreateChildWindows;\r
var I: Integer;\r
    C: PControl;\r
begin\r
  for I := 0 to fChildren.Count - 1 do\r
  begin\r
     C := fChildren.fItems[ I ];\r
     //C.GetWindowHandle;\r
     C.CreateWindow; //virtual!!!\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TControl.GetMembers]\r
function TControl.GetMembers(Idx: Integer): PControl;\r
begin\r
   Result := fChildren.fItems[ Idx ];\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.DestroyChildren]\r
procedure TControl.DestroyChildren;\r
asm\r
        PUSH      ESI\r
\r
        MOV       EAX, [EAX].fChildren\r
        PUSH      EAX\r
        MOV       ECX, [EAX].TList.fCount\r
        JECXZ     @@clear\r
        MOV       ESI, [EAX].TList.fItems\r
        LEA       ESI, [ESI + ECX*4 - 4]  // is order really important ?\r
\r
@@loop: STD                               //\r
        LODSD\r
        CLD                               //\r
\r
        PUSH      ECX\r
        CALL      TObj.Free\r
        POP       ECX\r
\r
        LOOP      @@loop\r
\r
@@clear:\r
        POP       EAX\r
        CALL      TList.Clear\r
\r
        POP       ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.DestroyChildren;\r
var I: Integer;\r
    W: PControl;\r
begin\r
   for I := fChildren.fCount - 1 downto 0 do\r
   begin\r
      W := fChildren.fItems[ I ];\r
      W.Free;\r
   end;\r
   fChildren.Clear;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{//-\r
//[function TControl.WindowedParent]\r
function TControl.WindowedParent: PControl;\r
begin\r
  Result := fParent;\r
end;}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.ProcessMessage]\r
function TControl.ProcessMessage: Boolean;\r
const size_TMsg = sizeof( TMsg );\r
asm\r
        PUSH      EBX\r
        XCHG      EBX, EAX\r
\r
        ADD       ESP, -size_TMsg-4\r
\r
        MOV       EDX, ESP\r
        PUSH      1\r
        XOR       ECX, ECX\r
        PUSH      ECX\r
        PUSH      ECX\r
        PUSH      ECX\r
        PUSH      EDX\r
        CALL      PeekMessage\r
\r
        TEST      EAX, EAX\r
        JZ        @@exit\r
\r
        MOV       EDX, [ESP].TMsg.message\r
        CMP       DX, WM_QUIT\r
        JNZ       @@tran_disp\r
        MOV       [AppletTerminated], 1\r
        JMP       @@fin\r
\r
@@tran_disp:\r
        MOV       ECX, [EBX].fExMsgProc\r
        JECXZ     @@do_tran_disp\r
        MOV       EAX, EBX\r
        MOV       EDX, ESP\r
        CALL      ECX\r
        TEST      AL, AL\r
        JNZ       @@fin\r
\r
@@do_tran_disp:\r
        MOV       EAX, ESP\r
        PUSH      EAX\r
        PUSH      EAX\r
        CALL      TranslateMessage\r
        CALL      DispatchMessage\r
\r
@@fin:\r
        MOV       AX, word ptr [ESP].TMsg.message\r
        TEST      AX, AX\r
        SETNZ     AL\r
\r
@@exit: ADD       ESP, size_TMsg+4\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.ProcessMessage: Boolean;\r
var Msg: TMsg;\r
begin\r
   Result := False;\r
   if PeekMessage( Msg, 0, 0, 0, PM_REMOVE ) then\r
   begin\r
      Result := Msg.message <> 0;\r
      if (Msg.message = WM_QUIT) then\r
        AppletTerminated := True\r
      else\r
      begin\r
        if not(Assigned( fExMsgProc ) and fExMsgProc( @Self, Msg )) then\r
        begin\r
          TranslateMessage( Msg );\r
          DispatchMessage( Msg );\r
        end;\r
      end;\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.ProcessMessages]\r
procedure TControl.ProcessMessages;\r
asm\r
@@loo:  PUSH     EAX\r
        CALL     ProcessMessage\r
        DEC      AL\r
        POP      EAX\r
        JZ       @@loo\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.ProcessMessages;\r
begin\r
  while ProcessMessage do ;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.ProcessMessagesEx]\r
procedure TControl.ProcessMessagesEx;\r
begin\r
  PostMessage( GetWindowHandle, CM_PROCESS, 0, 0 );\r
  ProcessMessages;\r
end;\r
\r
//[FUNCTION WndProcForm]\r
{$IFDEF ASM_VERSION}\r
function WndProcForm(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
const szPaintStruct = sizeof(TPaintStruct);\r
asm     //cmd    //opd\r
        CMP      word ptr [EDX].TMsg.message, WM_ENDSESSION\r
        JNE      @@chk_WM_SETFOCUS\r
\r
        CMP      [EDX].TMsg.wParam, 0\r
        JZ       @@ret_false\r
\r
        CALL     TObj.RefDec\r
        XOR      EAX, EAX\r
        MOV      [AppletRunning], AL\r
        XCHG     EAX, [Applet]\r
        INC      [AppletTerminated]\r
\r
        CALL     TObj.Free\r
        CALL     System.@Halt0\r
        //-------\r
\r
@@chk_WM_SETFOCUS:\r
        CMP      word ptr [EDX].TMsg.message, WM_SETFOCUS\r
        JNE      @@ret_false\r
\r
        PUSH     EBX\r
        PUSH     ESI\r
        XOR      EBX, EBX\r
        XCHG     ESI, EAX\r
      {$IFDEF FIX_MODAL_SETFOCUS}\r
        MOV      ECX, [ESI].TControl.fModalForm\r
        JECXZ    @@no_fix_modal_setfocus\r
        PUSH     [ECX].TControl.fHandle\r
        CALL     SetFocus\r
@@no_fix_modal_setfocus:\r
      {$ENDIF}\r
\r
        MOV      ECX, [ESI].TControl.FCurrentControl\r
        JECXZ    @@1\r
        INC      EBX\r
        XCHG     EAX, ECX\r
\r
        // or CreateForm?\r
        PUSH     EAX\r
        CALL     CallTControlCreateWindow\r
        POP      EAX\r
        PUSH     [EAX].TControl.fHandle\r
\r
        CALL     SetFocus\r
@@1:    MOV      ECX, [Applet]\r
        JECXZ    @@ret_EBX\r
        CMP      ECX, ESI\r
        JE       @@ret_EBX\r
        MOV      [ECX].TControl.FCurrentControl, ESI\r
@@ret_EBX:\r
        XCHG     EAX, EBX\r
        POP      ESI\r
        POP      EBX\r
        RET\r
\r
@@ret_false:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcForm(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var App: PControl;\r
begin\r
  Result := True;\r
  with Self_{-}^{+} do\r
  case Msg.message of\r
  WM_ENDSESSION:\r
    begin\r
      if Msg.wParam <> 0 then\r
      begin\r
        Self_.RefDec;\r
        { Normally, WM_ENDSESSION is sent to a main form, not to Applet.\r
          Since we do not plan further working after handling this message,\r
          we decrease RefCount for the form (in was increased in EnumDynHandlers\r
          to prevent object destroying while its message processing is not\r
          finished). }\r
        App := Applet;\r
        //Rslt := 0; { We will not return any result at all. }\r
        {$IFDEF DEBUG_ENDSESSION}\r
        EndSession_Initiated := TRUE;\r
        LogFileOutput( GetStartDir + 'es_debug.txt',\r
                       'Self_=' + Int2Hex( DWORD( Self_ ), 8 ) +\r
                       ' Self_.Handle=' + Int2Str( Self_.FHandle ) );\r
        {$ENDIF}\r
        AppletTerminated := TRUE;\r
        AppletRunning := FALSE;\r
        Applet := nil;\r
        App.Free; { We provide OnDestroy handlers to be called for any objects here }\r
        Halt; { Stop further executing. }\r
      end else Result := FALSE;\r
    end;\r
  WM_SETFOCUS:\r
    begin\r
      {$IFDEF NEW_MODAL}\r
      if fModalForm <> nil then\r
        SetFocus( fModalForm.fHandle )\r
      else if ( FCurrentControl <> nil ) and not ( fCurrentControl.IsForm xor fIsApplet ) then\r
      {$ELSE not NEW_MODAL}\r
      if FCurrentControl <> nil then\r
      {$ENDIF}\r
      begin\r
        FCurrentControl.CreateWindow; //virtual!!!\r
        SetFocus( FCurrentControl.fHandle );\r
      end\r
      else\r
        Result := False;\r
      if assigned( Applet ) and (Applet <> Self_) then\r
         Applet.FCurrentControl := Self_;\r
    end;\r
  else Result := False;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcForm]\r
\r
//[FUNCTION GetPrevCtrlBoundsRect]\r
{$IFDEF ASM_VERSION}\r
function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean;\r
asm\r
        MOV       EDX, EBX\r
        MOV       EAX, [EBX].TControl.fParent\r
        TEST      EAX, EAX\r
        JZ        @@exit\r
          PUSH      EAX\r
        CALL      TControl.ChildIndex\r
        TEST      EAX, EAX\r
        XCHG      EDX, EAX\r
          POP       EAX\r
        JZ        @@exit\r
        DEC       EDX\r
        CALL      TControl.GetMembers\r
\r
        POP       ECX  // retaddr\r
        ADD       ESP, -size_TRect\r
        MOV       EDX, ESP\r
        PUSH      ECX\r
        CALL      TControl.GetBoundsRect\r
        STC       // return CARRY\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean;\r
var Idx: Integer;\r
begin\r
  Result := False;\r
  if P.FParent = nil then Exit;\r
  Idx := P.FParent.ChildIndex( P ) - 1;\r
  if Idx < 0 then Exit;\r
  Result := True;\r
  R := P.FParent.Children[ Idx ].BoundsRect;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END GetPrevCtrlBoundsRect]\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.PlaceUnder]\r
function TControl.PlaceUnder: PControl;\r
asm\r
        PUSH      EBX\r
        XCHG      EBX, EAX\r
        CALL      GetPrevCtrlBoundsRect\r
        JNC       @@exit\r
        POP       EDX  // EDX = Left\r
        MOV       EAX, EBX\r
        CALL      TControl.SetLeft\r
\r
        POP       EDX\r
        POP       EDX\r
        POP       EDX  // EDX = Bottom\r
\r
        MOV       EAX, [EBX].fParent\r
        ADD       EDX, [EAX].fMargin\r
\r
        MOV       EAX, EBX\r
        CALL      TControl.SetTop\r
@@exit:\r
        XCHG      EAX, EBX\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.PlaceUnder: PControl;\r
var R: TRect;\r
begin\r
  Result := @Self;\r
  if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;\r
  Top := R.Bottom + fParent.fMargin;\r
  Left := R.Left;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.PlaceDown]\r
function TControl.PlaceDown: PControl;\r
asm\r
        PUSH      EBX\r
        XCHG      EBX, EAX\r
        CALL      GetPrevCtrlBoundsRect\r
        JNC       @@exit\r
        POP       EDX\r
        POP       EDX\r
        POP       EDX\r
        POP       EDX  // EDX = Bottom\r
\r
        MOV       EAX, [EBX].fParent\r
        ADD       EDX, [EAX].fMargin\r
\r
        MOV       EAX, EBX\r
        CALL      TControl.SetTop\r
@@exit:\r
        XCHG       EAX, EBX\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.PlaceDown: PControl;\r
var R: TRect;\r
begin\r
  Result := @Self;\r
  if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;\r
  Top := R.Bottom + fParent.fMargin;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.PlaceRight]\r
function TControl.PlaceRight: PControl;\r
asm\r
        PUSH      EBX\r
        XCHG      EBX, EAX\r
        CALL      GetPrevCtrlBoundsRect\r
        JNC       @@exit\r
        POP       EDX\r
        POP       EDX  // EDX = Top\r
        MOV       EAX, EBX\r
        CALL      TControl.SetTop\r
        POP       EDX  // EDX = Right\r
\r
        MOV       EAX, [EBX].fParent\r
        ADD       EDX, [EAX].fMargin\r
\r
        POP       ECX\r
        MOV       EAX, EBX\r
        CALL      TControl.SetLeft\r
@@exit:\r
        XCHG      EAX, EBX\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.PlaceRight: PControl;\r
var R: TRect;\r
begin\r
  Result := @Self;\r
  if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;\r
  Top := R.Top;\r
  Left := R.Right + fParent.fMargin;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.SetSize]\r
function TControl.SetSize(W, H: Integer): PControl;\r
asm\r
        PUSH      EBX\r
        XCHG      EBX, EAX\r
        SUB  ESP, 16\r
        XCHG      EAX, EDX\r
        MOV  EDX, ESP\r
        PUSH      ECX // save H\r
        PUSH      EAX // save W\r
        MOV  EAX, EBX\r
        CALL GetBoundsRect\r
        POP       ECX // pop W\r
        JECXZ     @@nochg_W\r
        ADD       ECX, [ESP+4].TRect.Left\r
        MOV       [ESP+4].TRect.Right, ECX\r
@@nochg_W:\r
        POP       ECX // pop H\r
        JECXZ     @@nochg_H\r
        ADD       ECX, [ESP].TRect.Top\r
        MOV       [ESP].TRect.Bottom, ECX\r
@@nochg_H:\r
        MOV       EAX, EBX\r
        MOV       EDX, ESP\r
        CALL      TControl.SetBoundsRect\r
        ADD  ESP, 16\r
        XCHG      EAX, EBX\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.SetSize(W, H: Integer): PControl;\r
var R: TRect;\r
begin\r
  R := BoundsRect;\r
  if W > 0 then R.Right := R.Left + W;\r
  if H > 0 then R.Bottom := R.Top + H;\r
  SetBoundsRect( R );\r
  Result := @Self;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TControl.SetClientSize]\r
function TControl.SetClientSize(W, H: Integer): PControl;\r
begin\r
  if W > 0 then ClientWidth := W;\r
  if H > 0 then ClientHeight := H;\r
  Result := @Self;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.AlignLeft]\r
function TControl.AlignLeft(P: PControl): PControl;\r
asm\r
        PUSH     EAX\r
        MOV      EAX, EDX\r
        CALL     TControl.GetLeft\r
        MOV      EDX, EAX\r
        POP      EAX\r
        PUSH     EAX\r
        CALL     TControl.SetLeft\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.AlignLeft(P: PControl): PControl;\r
begin\r
  Result := @Self;\r
  Left := P.Left;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.AlignTop]\r
function TControl.AlignTop(P: PControl): PControl;\r
asm\r
        PUSH     EAX\r
        MOV      EAX, EDX\r
        CALL     TControl.GetTop\r
        MOV      EDX, EAX\r
        POP      EAX\r
        PUSH     EAX\r
        CALL     TControl.SetTop\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.AlignTop(P: PControl): PControl;\r
begin\r
  Result := @Self;\r
  Top := P.Top;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[FUNCTION WndProcCtrl]\r
{$IFDEF ASM_VERSION} // see addition for combobox in pas version\r
function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        PUSH     ESI\r
        PUSH     EDI\r
        MOV      EDI, EDX\r
        MOV      EDX, [EDI].TMsg.message\r
\r
        SUB      DX, CN_CTLCOLORMSGBOX\r
        CMP      DX, CN_CTLCOLORSTATIC-CN_CTLCOLORMSGBOX\r
        JA       @@chk_CM_COMMAND\r
@@2:\r
        PUSH     ECX\r
        MOV      EAX, [EBX].TControl.fTextColor\r
        CALL     Color2RGB\r
        XCHG     ESI, EAX\r
        PUSH     ESI\r
        PUSH     [EDI].TMsg.wParam\r
        CALL     SetTextColor\r
        CMP      [EBX].TControl.fTransparent, 0\r
        JZ       @@opaque\r
\r
        PUSH     Windows.TRANSPARENT\r
        PUSH     [EDI].TMsg.wParam\r
        CALL     SetBkMode\r
        PUSH     NULL_BRUSH\r
        CALL     GetStockObject\r
        JMP      @@ret_rslt\r
\r
@@opaque:\r
        MOV      EAX, [EBX].TControl.fColor\r
        CALL     Color2RGB\r
        XCHG     ESI, EAX\r
        PUSH     OPAQUE\r
        PUSH     [EDI].TMsg.wParam\r
        CALL     SetBkMode\r
        PUSH     ESI\r
        PUSH     [EDI].TMsg.wParam\r
        CALL     SetBkColor\r
\r
        MOV      EAX, EBX\r
        CALL     Global_GetCtlBrushHandle\r
@@ret_rslt:\r
        XCHG     ECX, EAX\r
@@tmpbrushready:\r
        POP      EAX\r
        MOV      [EAX], ECX\r
@@ret_true:\r
        MOV      AL, 1\r
\r
        JMP      @@ret_EAX\r
\r
@@chk_CM_COMMAND:\r
        CMP      word ptr [EDI].TMsg.message, CM_COMMAND\r
        JNE      @@chk_WM_SETFOCUS\r
\r
        PUSH     ECX\r
\r
        MOVZX    ECX, word ptr [EDI].TMsg.wParam+2\r
        CMP      CX, [EBX].TControl.fCommandActions.aClick\r
        JNE      @@chk_aEnter\r
\r
        CMP      [EBX].TControl.fClickDisabled, 0\r
        JG       @@calldef\r
        MOV      EAX, EBX\r
        CALL     TControl.DoClick\r
        JMP      @@calldef\r
\r
@@chk_aEnter:\r
        LEA      EAX, [EBX].TControl.fOnEnter\r
        CMP      CX, [EBX].TControl.fCommandActions.aEnter\r
        JE       @@goEvent\r
        LEA      EAX, [EBX].TControl.fOnLeave\r
        CMP      CX, [EBX].TControl.fCommandActions.aLeave\r
        JE       @@goEvent\r
        LEA      EAX, [EBX].TControl.fOnChange\r
        CMP      CX, [EBX].TControl.fCommandActions.aChange\r
        JNE      @@chk_aSelChange\r
@@goEvent:\r
        MOV      ECX, [EAX].TMethod.Code\r
        JECXZ    @@2calldef\r
        MOV      EAX, [EAX].TMethod.Data\r
        MOV      EDX, EBX\r
        CALL     ECX\r
@@2calldef:\r
        JMP      @@calldef\r
\r
@@chk_aSelChange:\r
        CMP      CX, [EBX].TControl.fCommandActions.aSelChange\r
        JNE      @@chk_WM_SETFOCUS_1\r
        MOV      EAX, EBX\r
        CALL     TControl.DoSelChange\r
\r
@@calldef:\r
        XCHG     EAX, EBX\r
        MOV      EDX, EDI\r
        CALL     TControl.CallDefWndProc\r
        JMP      @@ret_rslt\r
\r
@@chk_WM_SETFOCUS_1:\r
        POP      ECX\r
@@chk_WM_SETFOCUS:\r
        XOR      EAX, EAX\r
        CMP      word ptr [EDI].TMsg.message, WM_SETFOCUS\r
        JNE      @@ret_EAX\r
\r
        MOV      [ECX], EAX\r
        MOV      EAX, EBX\r
        CALL     TControl.ParentForm\r
        TEST     EAX, EAX\r
        JZ       @@ret_true\r
\r
        MOV      [EAX].TControl.FCurrentControl, EBX\r
        XOR      EAX, EAX\r
\r
        PUSH     EDX\r
@@2ret_EAX:\r
        POP      EDX\r
\r
@@ret_EAX:\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
var F: PControl;\r
    Cmd : DWORD;\r
begin\r
  //Result := FALSE;\r
  with Self_{-}^{+} do\r
  case Msg.message of\r
  CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:\r
       begin\r
         SetTextColor(Msg.WParam, Color2RGB(fTextColor));\r
         if fTransparent {AND (fPaintDC = Msg.wParam)} then\r
         begin\r
            SetBkMode( Msg.wParam, Windows.TRANSPARENT );\r
            Rslt := GetStockObject( NULL_BRUSH );\r
         end\r
            else\r
         begin\r
            SetBkMode( Msg.wParam, Windows.OPAQUE );\r
            SetBkColor(Msg.WParam, Color2RGB( fColor ) );\r
            Rslt := Global_GetCtlBrushHandle( Self_ );\r
         end;\r
         Result := TRUE;\r
       end;\r
  CM_COMMAND:\r
       begin\r
         Result := True;\r
         Cmd := HiWord( Msg.wParam );\r
         if Cmd = fCommandActions.aClick then\r
         begin\r
            if Integer( fClickDisabled ) <= 0 then\r
              DoClick;\r
         end else\r
         if Cmd = fCommandActions.aEnter then\r
         begin\r
            if Assigned( fOnEnter ) then fOnEnter( Self_ );\r
         end else\r
         if Cmd = fCommandActions.aLeave then\r
         begin\r
            if Assigned( fOnLeave ) then fOnLeave( Self_ );\r
         end else\r
         if Integer(Cmd) = fCommandActions.aChange then\r
         begin\r
            if Assigned( fOnChange ) then fOnChange( Self_ );\r
            //if fTransparent then Invalidate;\r
         end else\r
         if Integer(Cmd) = fCommandActions.aSelChange then\r
         begin\r
           DoSelChange;\r
           // if fTransparent then Invalidate;\r
         end\r
         else Result := False;\r
\r
         if Result then\r
           Rslt := CallDefWndProc( Msg );\r
\r
       end;\r
\r
  WM_SETFOCUS:\r
       begin\r
         Rslt := 0;\r
         Result := TRUE;\r
         F := ParentForm;\r
         if F <> nil then\r
         begin\r
           F.fCurrentControl := Self_;\r
           Result := False; // go further handling\r
         end;\r
       end;\r
  {$IFDEF ESC_CLOSE_DIALOGS}\r
  //---------------------------------Babenko Alexey--------------------------\r
  WM_KEYDOWN:\r
         begin\r
           if (Self_.ParentForm.ExStyle and WS_EX_DLGMODALFRAME) <> 0 then\r
            if Msg.wParam = 27 then SendMessage(Self_.ParentForm.Handle, WM_CLOSE, 0, 0);\r
            result:=false;\r
         end;\r
  //---------------------------------Babenko Alexey-------------------------- \r
  {$ENDIF ESC_CLOSE_DIALOGS}\r
  else Result := False;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcCtrl]\r
\r
//[FUNCTION WndProcPaint]\r
{$IFDEF ASM_noVERSION}\r
function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
const szPaintStruct = sizeof(TPaintStruct);\r
asm     //cmd    //opd\r
        CMP      word ptr [EDX].TMsg.message, WM_PRINT\r
        JE       @@print\r
        CMP      word ptr [EDX].TMsg.message, WM_PAINT\r
        JNE      @@ret_false\r
@@print:\r
        CMP      word ptr [EAX].TControl.fOnPaint.TMethod.Code+2, 0\r
        JE       @@ret_false\r
        PUSH     EBX\r
        PUSH     ESI\r
\r
        XCHG     EBX, EAX\r
        MOV      ESI, EDX\r
        XOR      EAX, EAX\r
        PUSH     ECX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        CALL     CreateRectRgn\r
        MOV      [EBX].TControl.fUpdRgn, EAX\r
\r
        MOVSX    EDX, [EBX].TControl.fEraseUpdRgn\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     GetUpdateRgn\r
\r
        CMP      EAX, 1\r
        JA       @@collectUpdRgn\r
\r
        XOR      EAX, EAX\r
        XCHG     EAX, [EBX].TControl.fUpdRgn\r
        PUSH     EAX\r
        CALL     DeleteObject\r
\r
@@collectUpdRgn:\r
        MOV      ECX, [EBX].TControl.fCollectUpdRgn\r
        JECXZ    @@asg_fPaintDC\r
        XCHG     EAX, ECX\r
        MOV      ECX, [EBX].TControl.fUpdRgn\r
        JECXZ    @@asg_fPaintDC\r
\r
        PUSH     RGN_OR\r
        PUSH     ECX\r
        PUSH     EAX\r
        PUSH     EAX\r
        CALL     CombineRgn\r
\r
        DEC      EAX\r
        JNZ      @@invalidateRgn\r
\r
        ADD      ESP, -16\r
        PUSH     ESP\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     Windows.GetClientRect\r
\r
        PUSH     [EBX].TControl.fCollectUpdRgn\r
        CALL     DeleteObject\r
        CALL     CreateRectRgn\r
        MOV      [EBX].TControl.fCollectUpdRgn, EAX\r
\r
@@invalidateRgn:\r
        MOVSX    EDX, [EBX].TControl.fEraseUpdRgn\r
        PUSH     EDX\r
        PUSH     [EBX].TControl.fCollectUpdRgn\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     InvalidateRgn\r
\r
\r
@@asg_fPaintDC:\r
        MOV      ECX, [ESI].TMsg.wParam\r
        INC      ECX\r
        LOOP     @@storePaintDC\r
\r
        ADD      ESP, -szPaintStruct\r
        PUSH     ESP\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     BeginPaint\r
        XCHG     ECX, EAX\r
@@storePaintDC:\r
        MOV      [EBX].TControl.fPaintDC, ECX\r
        XCHG     EAX, ECX\r
\r
        MOV      ECX, [EBX].TControl.fCollectUpdRgn\r
        JECXZ    @@doOnPaint\r
\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     SelectClipRgn\r
\r
@@doOnPaint:\r
        MOV      ECX, [EBX].TControl.fPaintDC\r
        MOV      EDX, EBX\r
        MOV      EAX, [EBX].TControl.fOnPaint.TMethod.Data\r
        CALL     dword ptr [EBX].TControl.fOnPaint.TMethod.Code\r
\r
        MOV      ECX, [EBX].TControl.fCanvas\r
        JECXZ    @@e_paint\r
\r
        XCHG     EAX, ECX\r
        XOR      EDX, EDX\r
        CALL     TCanvas.SetHandle\r
\r
@@e_paint:\r
        MOV      ECX, [ESI].TMsg.wParam\r
        INC      ECX\r
        LOOP     @@zero_fPaintDC\r
\r
        PUSH     ESP\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     EndPaint\r
        ADD      ESP, szPaintStruct\r
\r
@@zero_fPaintDC:\r
        XOR      ECX, ECX\r
        MOV      [EBX].TControl.fPaintDC, ECX\r
\r
        POP      EAX\r
        MOV      [EAX], ECX\r
\r
        XCHG     ECX, [EBX].TControl.fUpdRgn\r
        JECXZ    @@exit_True\r
\r
        PUSH     ECX\r
        CALL     DeleteObject\r
\r
@@exit_True:\r
        POP      ESI\r
        POP      EBX\r
        MOV      AL, 1\r
        RET\r
\r
@@ret_false:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var PaintStruct: TPaintStruct;\r
    CR: TRect;\r
    Cplxity: Integer;\r
    OldPaintDC: HDC;\r
begin\r
  with Self_{-}^{+} do\r
  case Msg.message of\r
  WM_PRINT,\r
  WM_PAINT: if assigned( fOnPaint ) then\r
            begin\r
               fUpdRgn := CreateRectRgn( 0, 0, 0, 0 );\r
               Cplxity := Integer( GetUpdateRgn( fHandle, fUpdRgn, fEraseUpdRgn ) );\r
               if (Cplxity = NULLREGION) or (Cplxity = ERROR) then\r
               begin\r
                 DeleteObject( fUpdRgn );\r
                 fUpdRgn := 0;\r
               end;\r
\r
               if (fCollectUpdRgn <> 0) and (fUpdRgn <> 0) then\r
               begin\r
                 if CombineRgn( fCollectUpdRgn, fCollectUpdRgn, fUpdRgn, RGN_OR )\r
                    = COMPLEXREGION then\r
                 begin\r
                   windows.GetClientRect( Self_.fHandle, CR );\r
                   DeleteObject( fCollectUpdRgn );\r
                   fCollectUpdRgn := CreateRectRgnIndirect( CR );\r
                 end;\r
                 InvalidateRgn( fHandle, fCollectUpdRgn, fEraseUpdRgn );\r
               end;\r
\r
               OldPaintDC := fPaintDC;\r
               fPaintDC := Msg.wParam;\r
               if fPaintDC = 0 then\r
                 fPaintDC := BeginPaint( fHandle, PaintStruct );\r
\r
               if fCollectUpdRgn <> 0 then\r
                 SelectClipRgn( fPaintDC, fCollectUpdRgn );\r
\r
               fOnPaint( Self_, fPaintDC );\r
\r
               if assigned( Self_.fCanvas ) then\r
                 Self_.fCanvas.SetHandle( 0 );\r
\r
               if Msg.wParam = 0 then\r
                 EndPaint( fHandle, PaintStruct );\r
               fPaintDC := OldPaintDC;\r
\r
               Rslt := 0;\r
\r
               Result := True;\r
               if fUpdRgn <> 0 then\r
                 DeleteObject( fUpdRgn );\r
               fUpdRgn := 0;\r
               Exit;\r
            end;\r
  end;\r
  Result := FALSE;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcPaint]\r
\r
//[procedure TControl.SetOnPaint]\r
procedure TControl.SetOnPaint( const Value: TOnPaint );\r
begin\r
  fOnPaint := Value;\r
  AttachProc( WndProcPaint );\r
end;\r
\r
//*\r
//[function WndProcEraseBkgnd]\r
function WndProcEraseBkgnd( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var PaintStruct: TPaintStruct;\r
    OldPaintDC: HDC;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_ERASEBKGND then\r
  begin\r
    if Assigned( Sender.OnEraseBkgnd ) then\r
    begin\r
      OldPaintDC := Sender.fPaintDC;\r
      Sender.fPaintDC := Msg.wParam;\r
      if Sender.fPaintDC = 0 then\r
        Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct );\r
      Sender.OnEraseBkgnd( Sender, Msg.wParam );\r
      if Msg.wParam = 0 then\r
        EndPaint( Sender.fHandle, PaintStruct );\r
      if Assigned( Sender.fCanvas ) then\r
        Sender.fCanvas.SetHandle( 0 );\r
      Sender.fPaintDC := OldPaintDC;\r
      Rslt := 0;\r
      Result := TRUE;\r
    end\r
      else\r
      Rslt := 0;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnEraseBkgnd]\r
procedure TControl.SetOnEraseBkgnd(const Value: TOnPaint);\r
begin\r
  fOnEraseBkgnd := Value;\r
  AttachProc( WndProcEraseBkgnd );\r
end;\r
\r
//[FUNCTION WndProcGradient]\r
{$IFDEF ASM_noVERSION}\r
function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
const szPaintStruct = sizeof( TPaintStruct );\r
asm     //cmd    //opd\r
        CMP      word ptr [EDX].TMsg.message, WM_PRINTCLIENT\r
        JE       @@print\r
        CMP      word ptr [EDX].TMsg.message, WM_PAINT\r
        JNE      @@ret_false\r
@@print:\r
        PUSHAD\r
        XCHG     EDI, EAX\r
        MOV      ESI, EDX\r
        XOR      EAX, EAX\r
        MOV      [ECX], EAX\r
        OR       EAX, [ESI].TMsg.wParam\r
        JNZ      @@1\r
        ADD      ESP, -szPaintStruct\r
        PUSH     ESP\r
        PUSH     [EDI].TControl.fHandle\r
        CALL     BeginPaint\r
@@1:    MOV      [EDI].TControl.fPaintDC, EAX\r
        ADD      ESP, -16\r
        MOV      EDX, ESP\r
        MOV      EAX, EDI\r
        CALL     TControl.ClientRect\r
        MOV      EAX, [EDI].TControl.fColor1\r
        CALL     Color2RGB\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EDI].TControl.fColor2\r
        CALL     Color2RGB\r
        MOV      EBP, [ESP].TRect.Bottom\r
@@loo:\r
        MOV      EDX, [ESP].TRect.Top\r
        CMP      EBP, EDX\r
        JLE      @@e_loo\r
        INC      EDX\r
        MOV      [ESP].TRect.Bottom, EDX\r
\r
        INC      EBP\r
        PUSH     EAX\r
\r
        PUSH     EAX\r
        {SUB      AL, BL\r
        MOV      AH, 0\r
\r
        CWDE}\r
        AND      EAX, $FF\r
        MOV      EDX, EBX\r
        AND      EDX, $FF\r
        SUB      EAX, EDX\r
\r
\r
        MOV      ECX, [ESP+8].TRect.Top\r
        IMUL     ECX\r
        IDIV     EBP\r
        XOR      EDX, EDX\r
        ADD      AL, BL\r
        MOV      AH, 0\r
        CWDE\r
        XCHG     [ESP], EAX\r
\r
        PUSH     EAX\r
        {SUB      AH, BH\r
        MOV      AL, AH\r
        MOV      AH, 0\r
\r
        CWDE}\r
        SHR      EAX, 8\r
        AND      EAX, $FF\r
        MOV      EDX, EBX\r
        SHR      EDX, 8\r
        AND      EDX, $FF\r
        SUB      EAX, EDX\r
\r
        IMUL     ECX\r
        IDIV     EBP\r
        ADD      AL, BH\r
        AND      EAX, $FF\r
        SHL      EAX, 8\r
        XCHG     [ESP], EAX\r
\r
        SHR      EAX, 16\r
        MOV      EDX, EBX\r
        SHR      EDX, 16\r
        PUSH     EDX\r
        SUB      EAX, EDX\r
        IMUL     ECX\r
        IDIV     EBP\r
        POP      EDX\r
        //AND      EAX, $FF00\r
        ADD      EAX, EDX\r
        SHL      EAX, 16\r
\r
        POP      EDX\r
        MOV      AH, DH\r
        POP      EDX\r
        MOV      AL, DL\r
\r
        PUSH     EAX\r
        CALL     CreateSolidBrush\r
\r
        PUSH     EAX\r
\r
        PUSH     EAX\r
        LEA      EDX, [ESP+12]\r
        PUSH     EDX\r
        PUSH     [EDI].TControl.fPaintDC\r
        CALL     Windows.FillRect\r
\r
        CALL     DeleteObject\r
\r
        POP      EAX\r
        DEC      EBP\r
        INC      [ESP].TRect.Top\r
        JMP      @@loo\r
@@e_loo:\r
        ADD      ESP, 16\r
        MOV      ECX, [ESI].TMsg.wParam\r
        INC      ECX\r
        LOOP     @@2\r
        PUSH     ESP\r
        PUSH     [EDI].TControl.fHandle\r
        CALL     EndPaint\r
        ADD      ESP, szPaintStruct\r
@@2:    XOR      EAX, EAX\r
        MOV      [EDI].TControl.fPaintDC, EAX\r
        POPAD\r
        MOV      Al, 1\r
        RET\r
@@ret_false:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var PaintStruct: TPaintStruct;\r
    Bmp: PBitmap;\r
    CR: TRect;\r
    I: Integer;\r
    R, G, B: Integer;\r
    R1, G1, B1: Integer;\r
    C: TColor;\r
    W, H, WH: Integer;\r
    W9x: Boolean;\r
    Br: HBrush;\r
    //Save: Integer;\r
    OldPaintDC: HDC;\r
begin\r
  case Msg.message of\r
  WM_PAINT, WM_PRINTCLIENT:\r
            begin\r
               OldPaintDC := Self_.fPaintDC;\r
               Self_.fPaintDC := Msg.wParam;\r
               if Self_.fPaintDC = 0 then\r
                  Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );\r
               CR := Self_.ClientRect;\r
               W9x := WinVer < wvNT;\r
               W := 1;\r
               H := CR.Bottom;\r
               WH := H;\r
               Bmp := nil;\r
               if Self_.fGradientStyle = gsHorizontal then\r
               begin\r
                 W := CR.Right;\r
                 H := 1;\r
                 WH := W;\r
               end;\r
               if not W9x then\r
                 Bmp := NewDIBBitmap( W, H, pf32bit );\r
               C := Color2RGB( Self_.fColor1 );\r
               R := C shr 16;\r
               G := (C shr 8) and $FF;\r
               B := C and $FF;\r
               C := Color2RGB( Self_.fColor2 );\r
               R1 := C shr 16;\r
               G1 := (C shr 8) and $FF;\r
               B1 := C and $FF;\r
               for I := 0 to WH-1 do\r
               begin\r
                 C := ((( R + (R1 - R) * I div WH ) and $FF) shl 16) or\r
                      ((( G + (G1 - G) * I div WH ) and $FF) shl 8) or\r
                      ( B + (B1 - B) * I div WH ) and $FF;\r
                 if W9x then\r
                 begin\r
                   if Self_.fGradientStyle = gsVertical then\r
                     CR.Bottom := CR.Top + 1\r
                   else\r
                     CR.Right := CR.Left + 1;\r
                   Br := CreateSolidBrush( C );\r
                   Windows.FillRect( Self_.fPaintDC, CR, Br );\r
                   DeleteObject( Br );\r
                   if Self_.fGradientStyle = gsVertical then\r
                     Inc( CR.Top )\r
                   else\r
                     Inc( CR.Left );\r
                 end\r
                   else\r
                 begin\r
                   if Self_.fGradientStyle = gsVertical then\r
                     Bmp.DIBPixels[ 0, I ] := C\r
                   else\r
                     Bmp.DIBPixels[ I, 0 ] := C;\r
                 end;\r
               end;\r
               if not W9x then\r
               begin\r
                 SetStretchBltMode( Self_.fPaintDC, HALFTONE );\r
                 SetBrushOrgEx( Self_.fPaintDC, 0, 0, nil );\r
                 StretchBlt( Self_.fPaintDC, 0, 0, CR.Right, CR.Bottom, Bmp.Canvas.Handle,\r
                             0, 0, W, H, SRCCOPY );\r
                 Bmp.Free;\r
               end;\r
               if Msg.wParam = 0 then\r
                 EndPaint( Self_.fHandle, PaintStruct );\r
               Self_.fPaintDC := OldPaintDC;\r
               Rslt := 0;\r
               Result := True;\r
               Exit;\r
            end;\r
  end;\r
  Result := False;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcGradient]\r
\r
//[function WndProcGradientEx]\r
function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
  function Ceil( X: Double ): Integer;\r
  begin\r
    Result := Round( X ) + 1;\r
  end;\r
const\r
  SQRT2 = 1.4142135623730950488016887242097;\r
var\r
  RC, R0: TRect;\r
  C, C2: TColor;\r
  R1, G1, B1: Integer;\r
  R2, G2, B2: Integer;\r
  DX1, DX2, DY1, DY2, DR, DG, DB, K: Double;\r
  PaintStruct: TPaintStruct;\r
  I: Integer;\r
  Br: HBrush;\r
  Rgn: HRgn;\r
  Poly: array[ 0..3 ] of TPoint;\r
  OldPaintDC: HDC;\r
  fX1, fX2, fY1, fY2: Double;\r
\r
  procedure OffsetF( DX, DY: Double );\r
  begin\r
    fX1 := fX1 + DX;\r
    fX2 := fX2 + DX;\r
    fY1 := fY1 + DY;\r
    fY2 := fY2 + DY;\r
  end;\r
begin\r
  Result := FALSE;\r
  if (Msg.message <> WM_PAINT) and (Msg.message <> WM_PRINTCLIENT) then Exit;\r
  if Self_.fGradientStyle in [ gsHorizontal, gsVertical ] then\r
  begin\r
    Result := WndProcGradient( Self_, Msg, Rslt );\r
    Exit;\r
  end;\r
  C := Color2RGB( Self_.fColor2 );\r
  R2 := C and $FF;\r
  G2 := (C shr 8) and $FF;\r
  B2 := (C shr 16) and $FF;\r
  C := Color2RGB( Self_.fColor1 );\r
  R1 := C and $FF;\r
  G1 := (C shr 8) and $FF;\r
  B1 := (C shr 16) and $FF;\r
  DR := (R2 - R1) / 256;\r
  DG := (G2 - G1) / 256;\r
  DB := (B2 - B1) / 256;\r
  OldPaintDC := Self_.fPaintDC;\r
  Self_.fPaintDC := Msg.wParam;\r
  if Self_.fPaintDC = 0 then\r
    Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );\r
  RC := Self_.ClientRect;\r
  fX1 := 0;\r
  fY1 := 0;\r
  case Self_.fGradientStyle of\r
  gsRombic:\r
    //RF := MakeRect( 0, 0, RC.Right div 128, RC.Bottom div 128 );\r
    begin\r
      fX2 := RC.Right / 128;\r
      fY2 := RC.Bottom / 128;\r
    end;\r
  gsElliptic:\r
    //RF := MakeRect( 0, 0, Ceil( RC.Right / 256 * SQRT2 ), Ceil( RC.Bottom / 256 * SQRT2 ) );\r
    begin\r
      fX2 := RC.Right / 256 * SQRT2;\r
      fY2 := RC.Bottom / 256 * SQRT2;\r
    end;\r
  else\r
    //RF := MakeRect( 0, 0, RC.Right div 256, RC.Bottom div 256 );\r
    begin\r
      fX2 := RC.Right / 256;\r
      fY2 := RC.Bottom / 256;\r
    end;\r
  end;\r
  case Self_.fGradientStyle of\r
  gsRectangle, gsRombic, gsElliptic:\r
    begin\r
      case Self_.FGradientLayout of\r
      glCenter, glTop, glBottom:\r
        //OffsetRect( RF, (RC.Right - RF.Right) div 2, 0 );\r
        OffsetF( (RC.Right - fX2) / 2, 0 );\r
      glTopRight, glBottomRight, glRight:\r
        //OffsetRect( RF, RC.Right - RF.Right div 2, 0 );\r
        OffsetF( RC.Right - fX2 / 2, 0 );\r
      glTopLeft, glBottomLeft, glLeft:\r
        //OffsetRect( RF, -RF.Right div 2, 0 );\r
        OffsetF( -fX2 / 2, 0 );\r
      end;\r
      case Self_.FGradientLayout of\r
      glCenter, glLeft, glRight:\r
        //OffsetRect( RF, 0, (RC.Bottom - RF.Bottom) div 2 );\r
        OffsetF( 0, (RC.Bottom - fY2) / 2 );\r
      glBottom, glBottomLeft, glBottomRight:\r
        //OffsetRect( RF, 0, RC.Bottom - RF.Bottom div 2 );\r
        OffsetF( 0, RC.Bottom - fY2 / 2 );\r
      glTop, glTopLeft, glTopRight:\r
        //OffsetRect( RF, 0, -RF.Bottom div 2 );\r
        OffsetF( 0, -fY2 / 2 )\r
      end;\r
    end;\r
  end;\r
  DX1 := -fX1 / 255; //(-RF.Left) / 255;\r
  DY1 := -fY1 / 255; // (-RF.Top) / 255;\r
  DX2 := (RC.Right - fX2) / 255; //(RC.Right - RF.Right) / 255;\r
  DY2 := (RC.Bottom - fY2) / 255;\r
  case Self_.fGradientStyle of\r
  gsRombic, gsElliptic:\r
    begin\r
      if DX2 < -DX1 then DX2 := -DX1;\r
      if DY2 < -DY1 then DY2 := -DY1;\r
      K := 2;\r
      if Self_.fGradientStyle = gsElliptic then K := SQRT2;\r
      DX2 := DX2 * K;\r
      DY2 := DY2 * K;\r
      DX1 := -DX2;\r
      DY1 := -DY2;\r
    end;\r
  end;\r
  C2 := C;\r
  for I := 0 to 255 do\r
  begin\r
    if (I < 255) then\r
    begin\r
      C2 := TColor( (( Ceil( B1 + DB * (I+1) ) and $FF) shl 16) or\r
          (( Ceil( G1 + DG * (I+1) ) and $FF) shl 8) or\r
           Ceil( R1 + DR * (I+1) ) and $FF );\r
      if (Self_.fGradientStyle in [gsRombic,gsElliptic,gsRectangle]) and\r
         (C2 = C) then continue;\r
    end;\r
    Br := CreateSolidBrush( C );\r
    R0 := MakeRect( Ceil( fX1 + DX1 * I ),\r
                    Ceil( fY1 + DY1 * I ),\r
                    Ceil( fX2 + DX2 * I ) + 1,\r
                    Ceil( fY2 + DY2 * I ) + 1 );\r
    Rgn := 0;\r
    case Self_.fGradientStyle of\r
    gsRectangle:\r
      Rgn := CreateRectRgnIndirect( R0 );\r
    gsRombic:\r
      begin\r
        Poly[ 0 ].x := R0.Left;\r
        Poly[ 0 ].y := R0.Top + (R0.Bottom - R0.Top) div 2;\r
        Poly[ 1 ].x := R0.Left + (R0.Right - R0.Left) div 2;\r
        Poly[ 1 ].y := R0.Top;\r
        Poly[ 2 ].x := R0.Right;\r
        Poly[ 2 ].y := Poly[ 0 ].y;\r
        Poly[ 3 ].x := Poly[ 1 ].x;\r
        Poly[ 3 ].y := R0.Bottom;\r
        Rgn := CreatePolygonRgn( Poly[ 0 ].x, 4, ALTERNATE );\r
      end;\r
    gsElliptic:\r
      Rgn := CreateEllipticRgnIndirect( R0 );\r
    end;\r
    if Rgn <> 0 then\r
    begin\r
      if Rgn <> NULLREGION then\r
      begin\r
        Windows.FillRgn( Self_.fPaintDC, Rgn, Br );\r
        ExtSelectClipRgn( Self_.fPaintDC, Rgn, RGN_DIFF );\r
      end;\r
      DeleteObject( Rgn );\r
    end;\r
    DeleteObject( Br );\r
    C := C2;\r
  end;\r
  if Self_.fPaintDC <> HDC( Msg.wParam ) then\r
    EndPaint( Self_.fHandle, PaintStruct );\r
  Self_.fPaintDC := OldPaintDC;\r
  Rslt := 0;\r
  Result := True;\r
end;\r
\r
//*\r
//[function WndProcLabelEffect]\r
function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var\r
    Sz: TSize;\r
    P0: TPoint;\r
    CR: TRect;\r
    B : Boolean;\r
    CShadow: TColor;\r
    Target: PCanvas;\r
    Txt: String;\r
    LCaption: PChar;\r
    OldPaintDC: HDC;\r
\r
    procedure doTextOut( shfx, shfy: Integer; col: TColor );\r
    begin\r
        SetTextColor( Target.fHandle, col );\r
        Windows.ExtTextOut( Target.fHandle, P0.x + shfx, P0.y + shfy,\r
                            ETO_CLIPPED, @CR,\r
                            PChar(Txt), Length(Txt), nil );\r
        //GDIFlush; // for test only\r
    end;\r
\r
var I, J, Istp : Integer;\r
    PS: TPaintStruct;\r
    //DoEndPaint: Boolean;\r
begin\r
  Result := False;\r
\r
  case Msg.message of\r
\r
  WM_SETTEXT:\r
    begin\r
      LCaption := PChar( Msg.lParam );\r
      if LCaption <> Self_.fCaption then\r
      begin\r
        if Self_.fCaption <> nil then\r
           FreeMem( Self_.fCaption );\r
        GetMem( Self_.fCaption, StrLen( LCaption ) + 1 );\r
        StrCopy( Self_.fCaption, LCaption );\r
      end;\r
      Result := True;\r
      Rslt := 1;\r
      Exit;\r
    end;\r
\r
  WM_PRINTCLIENT, WM_PAINT:\r
  begin\r
    OldPaintDC := Self_.fPaintDC;\r
    Self_.fPaintDC := Msg.wParam;\r
    if Self_.fPaintDC = 0 then\r
      Self_.fPaintDC := BeginPaint( Self_.fHandle, PS );\r
    begin\r
       Target := Self_.Canvas;\r
       Txt := Self_.fCaption;\r
       Target.TextArea( Txt, Sz, P0 );\r
       if Self_.fShadowDeep <> 0 then\r
       begin\r
         for B := False to Self_.fCtl3D do\r
         begin\r
           Inc( Sz.cx, Abs( Self_.fShadowDeep ) );\r
           Inc( Sz.cy, Abs( Self_.fShadowDeep ) );\r
         end;\r
       end;\r
       CR := Self_.ClientRect;\r
       case Self_.fTextAlign of\r
       taCenter: P0.x := P0.x + (CR.Right - Sz.cx) div 2;\r
       taRight:  P0.x := P0.x + (CR.Right - Sz.cx);\r
       end;\r
       case Self_.fVerticalAlign of\r
       vaCenter: P0.y := P0.y + (CR.Bottom - Sz.cy) div 2;\r
       vaBottom: P0.y := P0.y + (CR.Bottom - Sz.cy);\r
       end;\r
       if Self_.fShadowDeep <> 0 then\r
       begin\r
         if Self_.fColor2 = clNone then\r
           CShadow := ColorsMix(Color2RGB(Self_.fTextColor),Color2RGB(Self_.fColor2))\r
         else\r
           CShadow := Color2RGB( Self_.fColor2 );\r
         if not Self_.fTransparent then\r
           Target.FillRect( CR ); // GDIFlush; for test only\r
         //Target.DeselectHandles;\r
         Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
         SetBkMode( Target.fHandle, Windows.TRANSPARENT );\r
         if Self_.fCtl3D then\r
         begin\r
           I := - Self_.fShadowDeep;\r
           Istp := 1;\r
           if Self_.ShadowDeep > 0 then Istp := -1;\r
           repeat\r
             J := - Self_.fShadowDeep;\r
             repeat\r
               if not ( (I=0) and (J=0) ) then\r
               begin\r
                 if (I * Istp < 0) and (J * Istp < 0) then\r
                 begin\r
                    doTextOut( I, J, CShadow );\r
                 end;\r
               end;\r
               J := J - Istp;\r
             until J = Self_.fShadowDeep - IStp;\r
             I := I - Istp;\r
           until I = Self_.fShadowDeep - IStp;\r
         end\r
            else\r
         doTextout( Self_.fShadowDeep, Self_.fShadowdeep, CShadow );\r
         doTextout( 0, 0, Color2RGB(Self_.fTextColor) );\r
       end\r
          else\r
       begin\r
         //Target.DeselectHandles;\r
         Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );\r
         SetBkMode( Target.fHandle, Windows.TRANSPARENT );\r
         //Target.TextRect( CR, P0.x, P0.y, Txt );\r
         doTextout( 0, 0, Color2RGB(Self_.fTextColor) );\r
       end;\r
    end;\r
    if assigned( Self_.fCanvas ) then\r
      Self_.fCanvas.SetHandle( 0 );\r
    if MSg.wParam = 0 then\r
      EndPaint( Self_.fHandle, PS );\r
    Self_.fPaintDC := OldPaintDC;\r
    Rslt := 0;\r
    Result := True;\r
    Exit;\r
    end;\r
  end;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.DoClick]\r
procedure TControl.DoClick;\r
asm\r
        PUSH     EAX\r
        CALL     [EAX].fControlClick\r
        POP      EDX\r
\r
        MOV      ECX, [EDX].fOnClick.TMethod.Code\r
        JECXZ    @@exit\r
        MOV      EAX, [EDX].fOnClick.TMethod.Data\r
        CALL     ECX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.DoClick;\r
begin\r
  fControlClick( @Self );\r
  if Assigned( fOnClick ) then\r
     fOnClick( @Self );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.ParentForm]\r
function TControl.ParentForm: PControl;\r
asm\r
@@1:    CMP      [EAX].fIsControl, 0\r
        JZ       @@exit\r
        MOV      EAX, [EAX].fParent\r
        TEST     EAX, EAX\r
        JNZ      @@1\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.ParentForm: PControl;\r
begin\r
  Result := @Self;\r
  if Result.fIsControl then\r
  repeat\r
    Result := Result.fParent;\r
  until (Result = nil) or not Result.fIsControl;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetProgressColor]\r
procedure TControl.SetProgressColor(const Value: TColor);\r
asm\r
        PUSH     EDX\r
        PUSH     EAX\r
        MOV      EAX, EDX\r
        CALL     Color2RGB\r
        POP      EDX\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     0\r
        PUSH     PBM_SETBARCOLOR\r
        PUSH     EDX\r
        CALL     Perform\r
        TEST     EAX, EAX\r
        POP      EAX\r
        POP      EDX\r
        JZ       @@exit\r
        MOV      [EAX].fTextColor, EDX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetProgressColor(const Value: TColor);\r
begin\r
  if Perform( PBM_SETBARCOLOR, 0, Color2RGB(Value) ) <> 0 then\r
    fTextColor := Value;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.SetShadowDeep]\r
procedure TControl.SetShadowDeep(const Value: Integer);\r
begin\r
  fShadowDeep := Value;\r
  Invalidate;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetFont]\r
function TControl.GetFont: PGraphicTool;\r
asm\r
        MOV      ECX, [EAX].FFont\r
        INC      ECX\r
        LOOP     @@exit\r
        PUSH     EAX\r
        CALL     NewFont\r
        POP      EDX\r
        MOV      [EDX].FFont, EAX\r
        MOV      ECX, [EDX].fTextColor\r
        MOV      [EAX].TGraphicTool.fData.Color, ECX\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Code, offset[FontChanged]\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Data, EDX\r
        RET\r
@@exit: XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetFont: PGraphicTool;\r
begin\r
  if FFont = nil then\r
  begin\r
     FFont := NewFont;\r
     FFont.fData.Color := fTextColor;\r
     FFont.OnChange := FontChanged;\r
  end;\r
  Result := FFont;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetBrush]\r
function TControl.GetBrush: PGraphicTool;\r
asm\r
        MOV      ECX, [EAX].FBrush\r
        INC      ECX\r
        LOOP     @@exit\r
        PUSH     EAX\r
        CALL     NewBrush\r
        POP      EDX\r
        MOV      [EDX].FBrush, EAX\r
        MOV      ECX, [EDX].fColor\r
        MOV      [EAX].TGraphicTool.fData.Color, ECX\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Code, offset[BrushChanged]\r
        MOV      [EAX].TGraphicTool.fOnChange.TMethod.Data, EDX\r
        RET\r
@@exit: XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetBrush: PGraphicTool;\r
begin\r
  if FBrush = nil then\r
  begin\r
    FBrush := NewBrush;\r
    FBrush.fData.Color := fColor;\r
    FBrush.OnChange := BrushChanged;\r
  end;\r
  Result := FBrush;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.FontChanged]\r
procedure TControl.FontChanged(Sender: PGraphicTool);\r
asm\r
        MOV      ECX, [EDX].TGraphicTool.fData.Color\r
        MOV      [EAX].fTextColor, ECX\r
        PUSH     EAX\r
        CALL     ApplyFont2Wnd\r
        POP      EAX\r
        CALL     Invalidate\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.FontChanged(Sender: PGraphicTool);\r
begin\r
  fTextColor := Sender.fData.Color;\r
  ApplyFont2Wnd;\r
  Invalidate;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.BrushChanged]\r
procedure TControl.BrushChanged(Sender: PGraphicTool);\r
asm\r
        MOV      ECX, [EDX].TGraphicTool.fData.Color\r
        MOV      [EAX].fColor, ECX\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EAX].fTmpBrush\r
        JECXZ    @@inv\r
        PUSH     EAX\r
        PUSH     ECX\r
        CALL     DeleteObject\r
        POP      EAX\r
@@inv:  CALL     Invalidate\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.BrushChanged(Sender: PGraphicTool);\r
begin\r
  fColor := Sender.fData.Color;\r
  if fTmpBrush <> 0 then\r
  begin\r
    DeleteObject( fTmpBrush );\r
    fTmpBrush := 0;\r
  end;\r
  if fPaintDC = 0 then\r
  // only if not in painting already :\r
    Invalidate;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.ApplyFont2Wnd]\r
procedure TControl.ApplyFont2Wnd;\r
asm\r
        PUSH       EBX\r
        XCHG       EBX, EAX\r
\r
        MOV        ECX, [EBX].fFont\r
        JECXZ      @@exit\r
        XCHG       EAX, ECX\r
\r
        MOV        ECX, [EBX].fHandle\r
        JECXZ      @@0\r
\r
        MOV        EDX, [EAX].TGraphicTool.fData.Color\r
        MOV        [EBX].fTextColor, EDX\r
\r
        PUSH       $FFFF\r
        CALL       TGraphicTool.GetHandle\r
        PUSH       EAX\r
        PUSH       WM_SETFONT\r
        PUSH       EBX\r
        CALL       Perform\r
\r
@@0:\r
        XOR        ECX, ECX\r
        XCHG       ECX, [EBX].fCanvas\r
        JECXZ      @@1\r
\r
        XCHG       EAX, ECX\r
        CALL       TObj.Free\r
@@1:\r
        MOV        ECX, [EBX].fAutoSize\r
        JECXZ      @@exit\r
        XCHG       EAX, EBX\r
        CALL       ECX\r
@@exit:\r
        POP        EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.ApplyFont2Wnd;\r
begin\r
  if fFont <> nil then\r
  begin\r
    if fHandle <> 0 then\r
    begin\r
      fTextColor := fFont.fData.Color;\r
      Perform( WM_SETFONT, FFont.Handle, 1 );\r
    end;\r
\r
    if fCanvas <> nil then\r
    begin\r
      fCanvas.Free;\r
      fCanvas := nil;\r
    end;\r
\r
    if Assigned( fAutoSize ) then\r
      fAutoSize( @Self );\r
    //if assigned( fCanvas ) then\r
    //   {fCanvas.fFont :=} fCanvas.fFont.Assign( fFont );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.ResizeParent]\r
function TControl.ResizeParent: PControl;\r
asm\r
        LEA       EDX, [TControl.ResizeParentRight]\r
        PUSH      EDX\r
        CALL      EDX\r
        CALL      TControl.ResizeParentBottom\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.ResizeParent: PControl;\r
begin\r
            ResizeParentBottom;\r
            ResizeParentRight;\r
            // Once again, to fix Windows (or my???) bug with\r
            // incorrect calculating of GetClientRect after\r
            // SetWindowLong( GWL_[EX}STYLE,... )\r
  Result := ResizeParentBottom;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.ResizeParentBottom]\r
function TControl.ResizeParentBottom: PControl;\r
asm\r
        PUSH      EAX\r
        PUSH      EBX\r
        MOV       EBX, [EAX].fParent\r
        TEST      EBX, EBX\r
        JZ        @@exit\r
\r
        MOV       EDX, [EAX].fBoundsRect.Bottom\r
        ADD       EDX, [EBX].fMargin\r
\r
        TEST      [EBX].fChangedPosSz, 20h\r
        JZ        @@1\r
\r
        PUSH      EDX\r
        MOV       EAX, EBX\r
        CALL      GetClientHeight\r
        POP       EDX\r
\r
        CMP       EDX, EAX\r
        JLE       @@exit\r
@@1:\r
        MOV       EAX, EBX\r
        CALL      TControl.SetClientHeight\r
        OR        [EBX].fChangedPosSz, 20h\r
@@exit:\r
        POP       EBX\r
        POP       EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.ResizeParentBottom: PControl;\r
var NewCH: Integer;\r
begin\r
  Result := @Self;\r
  if fParent <> nil then\r
  begin\r
    NewCH := BoundsRect.Bottom + fParent.fMargin;\r
    if (fParent.fChangedPosSz and $20) <> 0 then\r
       if NewCH < fParent.ClientHeight then Exit;\r
    fParent.ClientHeight := NewCH;\r
    fParent.fChangedPosSz := fParent.fChangedPosSz or $20;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.ResizeParentRight]\r
function TControl.ResizeParentRight: PControl;\r
asm\r
        PUSH      EAX\r
        PUSH      EBX\r
        MOV       EBX, [EAX].fParent\r
        TEST      EBX, EBX\r
        JZ        @@exit\r
\r
        MOV       EDX, [EAX].fBoundsRect.Right\r
        ADD       EDX, [EBX].fMargin\r
\r
        TEST      [EBX].fChangedPosSz, 10h\r
        JZ        @@1\r
\r
        PUSH      EDX\r
        MOV       EAX, EBX\r
        CALL      GetClientWidth\r
        POP       EDX\r
\r
        CMP       EDX, EAX\r
        JLE       @@exit\r
@@1:\r
        MOV       EAX, EBX\r
        CALL      TControl.SetClientWidth\r
        OR        [EBX].fChangedPosSz, 10h\r
@@exit:\r
        POP       EBX\r
        POP       EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.ResizeParentRight: PControl;\r
var NewCW: Integer;\r
begin\r
  Result := @Self;\r
  if fParent <> nil then\r
  begin\r
    NewCW := fBoundsRect.Right + fParent.fMargin;\r
    if (fParent.fChangedPosSz and $10) <> 0 then\r
       if NewCW < fParent.ClientWidth then Exit;\r
    fParent.ClientWidth := NewCW;\r
    fParent.fChangedPosSz := fParent.fChangedPosSz or $10;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetClientHeight]\r
function TControl.GetClientHeight: Integer;\r
asm\r
        ADD       ESP, -size_TRect\r
        MOV       EDX, ESP\r
        CALL      TControl.ClientRect\r
        POP       EDX\r
        POP       ECX            // Top\r
        POP       EDX\r
        POP       EAX            // Bottom\r
        SUB       EAX, ECX       // Result = Bottom - Top\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetClientHeight: Integer;\r
begin\r
  with ClientRect do\r
    Result := Bottom - Top;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetClientWidth]\r
function TControl.GetClientWidth: Integer;\r
asm\r
        ADD       ESP, -size_TRect\r
        MOV       EDX, ESP\r
        CALL      TControl.ClientRect\r
        POP       ECX            // Left\r
        POP       EDX\r
        POP       EAX            // Right\r
        SUB       EAX, ECX       // Result = Right - Left\r
        POP       EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetClientWidth: Integer;\r
begin\r
  with ClientRect do\r
    Result := Right - Left;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetClientHeight]\r
procedure TControl.SetClientHeight(const Value: Integer);\r
asm\r
        PUSH      EBX\r
         PUSH      EDX\r
\r
        MOV       EBX, EAX\r
        CALL      TControl.GetClientHeight\r
          PUSH      EAX\r
        MOV       EAX, EBX\r
        CALL      TControl.GetHeight // EAX = Height\r
\r
          POP       EDX              // EDX = ClientHeight\r
        SUB       EAX, EDX           // EAX = Delta\r
         POP       EDX               // EDX = Value\r
        ADD       EDX, EAX           // EDX = Value + Delta\r
        XCHG      EAX, EBX           // EAX = @Self\r
        CALL      TControl.SetHeight\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetClientHeight(const Value: Integer);\r
var Delta: Integer;\r
begin\r
  Delta := ClientHeight;\r
  Delta := Height - Delta;\r
  Height := Value + Delta;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetClientWidth]\r
procedure TControl.SetClientWidth(const Value: Integer);\r
asm\r
        PUSH      EBX\r
         PUSH      EDX\r
\r
        MOV       EBX, EAX\r
        CALL      TControl.GetClientWidth\r
          PUSH      EAX\r
        MOV       EAX, EBX\r
        CALL      TControl.GetWidth  // EAX = Width\r
\r
          POP       EDX              // EDX = ClientWidth\r
        SUB       EAX, EDX           // EAX = Width - ClientWidth\r
         POP       EDX               // EDX = Value\r
        ADD       EDX, EAX           // EDX = Value + Delta\r
        XCHG      EAX, EBX           // EAX = @Self\r
        CALL      TControl.SetWidth\r
        POP       EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetClientWidth(const Value: Integer);\r
var Delta: Integer;\r
begin\r
  Delta := ClientWidth;\r
  Delta := Width - Delta;\r
  Width := Value + Delta;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.CenterOnParent]\r
function TControl.CenterOnParent: PControl;\r
asm\r
        PUSHAD\r
\r
        XCHG     ESI, EAX\r
        MOV      ECX, [ESI].fParent\r
        JECXZ    @@1\r
        CMP      [ESI].fIsControl, 0\r
        JNZ      @@2\r
\r
@@1:\r
        PUSH     SM_CYSCREEN\r
        CALL     GetSystemMetrics\r
        PUSH     EAX\r
\r
        PUSH     SM_CXSCREEN\r
        CALL     GetSystemMetrics\r
        PUSH     EAX\r
\r
        PUSH     0\r
        PUSH     0               // ESP -> Rect( 0, 0, CX, CY )\r
\r
        JMP      @@3\r
\r
@@2:    ADD      ESP, -size_TRect\r
        MOV      EDX, ESP\r
        XCHG     EAX, ECX\r
        CALL     TControl.ClientRect\r
                                 // ESP -> ClientRect\r
@@3:    MOV      EAX, ESI\r
        CALL     GetWindowHandle\r
\r
        MOV      EAX, ESI\r
        CALL     GetWidth\r
\r
        POP      EDX       // left\r
        ADD      EAX, EDX          // + width\r
\r
        POP      EDI       // top\r
        POP      EDX       // right\r
\r
        SUB      EDX, EAX\r
        SAR      EDX, 1\r
\r
        MOV      EAX, ESI\r
        CALL     SetLeft\r
\r
        MOV      EAX, ESI\r
        CALL     GetHeight\r
\r
        ADD      EAX, EDI  // height + top\r
\r
        POP      EDX       // bottom\r
        SUB      EDX, EAX\r
        SAR      EDX, 1\r
\r
        XCHG     EAX, ESI\r
        CALL     SetTop\r
\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.CenterOnParent: PControl;\r
var PCR: TRect;\r
begin\r
  Result := @Self;\r
  if (fParent = nil) or not fIsControl then\r
    PCR := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) )\r
  else\r
    PCR := fParent.ClientRect;\r
  GetWindowHandle;\r
  Left := (PCR.Right - PCR.Left - Width) div 2;\r
  Top := (PCR.Bottom - PCR.Top - Height) div 2;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TControl.GetHasBorder]\r
function TControl.GetHasBorder: Boolean;\r
const style_mask = WS_BORDER or WS_THICKFRAME or WS_DLGFRAME;\r
asm\r
        CALL     UpdateWndStyles\r
        MOV      EAX, [EAX].fStyle\r
        AND      EAX, style_mask\r
        SETNZ    AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetHasBorder: Boolean;\r
begin\r
  UpdateWndStyles;\r
  Result := LongBool( fStyle and (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME))\r
         or LongBool( fExStyle and WS_EX_CLIENTEDGE );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_noVERSION} // YS\r
//[procedure TControl.SetHasBorder]\r
procedure TControl.SetHasBorder(const Value: Boolean);\r
const style_mask = WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION\r
                             or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU;\r
      exstyle_mask = not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME\r
                                or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE);\r
asm\r
\r
        PUSH     EAX\r
          PUSH     EDX\r
\r
            CALL     GetHasBorder\r
          POP      ECX\r
          CMP      AL, CL\r
\r
        POP      EAX\r
        JZ       @@exit\r
\r
        MOV      EDX, [EAX].fStyle\r
        DEC      CL\r
        MOVZX    ECX, [EAX].fIsControl\r
        JNZ      @@1\r
\r
        OR       EDX, WS_THICKFRAME\r
        INC      ECX\r
        LOOP     @@set_style\r
        OR       EDX, style_mask\r
        JMP      @@set_style\r
\r
@@1:    AND      EDX, not style_mask\r
        INC      ECX\r
        LOOP     @@2\r
        OR       EDX, WS_POPUP\r
\r
@@2:    PUSH     EDX\r
\r
        MOV      EDX, [EAX].fExStyle\r
        AND      EDX, exstyle_mask\r
\r
        PUSH     EAX\r
        CALL     SetExStyle\r
        POP      EAX\r
\r
        POP      EDX\r
@@set_style:\r
        CALL     SetStyle\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetHasBorder(const Value: Boolean);\r
var NewStyle: DWORD;\r
begin\r
  if Value = GetHasBorder then Exit;\r
  {if Value then\r
  begin\r
    NewStyle := fStyle or WS_THICKFRAME;\r
    if not fIsControl then\r
      NewStyle := NewStyle or WS_BORDER or\r
               WS_DLGFRAME or WS_CAPTION or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or\r
               WS_SYSMENU;\r
    Style := NewStyle;\r
  end}\r
  if Value then\r
  begin\r
    if not fIsControl then\r
      Style := fStyle or WS_THICKFRAME or WS_BORDER or\r
               WS_DLGFRAME or WS_CAPTION or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or\r
               WS_SYSMENU\r
    else\r
      if fCtl3D then\r
        ExStyle := fExStyle or WS_EX_CLIENTEDGE\r
      else\r
        Style := fStyle or WS_BORDER;\r
  end\r
    else\r
  begin\r
    NewStyle := fStyle and not (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION\r
                             or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU);\r
    if not fIsControl then NewStyle := NewStyle or WS_POPUP;\r
    Style := NewStyle;\r
    ExStyle := fExStyle and not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME\r
                                or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE);\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetHasCaption]\r
function TControl.GetHasCaption: Boolean;\r
const style_mask1 = (WS_POPUP or WS_DLGFRAME) shr 16;\r
      style_mask2 = WS_CAPTION shr 16;\r
asm\r
        CALL     UpdateWndStyles\r
        MOV      ECX, [EAX].fStyle + 2\r
        MOV      EDX, ECX\r
        MOV      AL, 1\r
        AND      DX, style_mask1\r
        JZ       @@1\r
        AND      CX, style_mask2\r
        JNZ      @@1\r
        XOR      EAX, EAX\r
@@1:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetHasCaption: Boolean;\r
begin\r
  UpdateWndStyles;\r
  Result := not LongBool( fStyle and (WS_POPUP or WS_DLGFRAME))\r
            or LongBool( fStyle and WS_CAPTION);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetHasCaption]\r
procedure TControl.SetHasCaption(const Value: Boolean);\r
const style_mask = not (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION\r
                             or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU);\r
      exstyle_mask = not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME\r
                                or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE);\r
asm\r
        PUSH     EAX\r
          PUSH     EDX\r
\r
            CALL     GetHasCaption\r
          POP      ECX\r
          CMP      AL, CL\r
\r
        POP      EAX\r
        JZ       @@exit   // Value = HasCaption\r
\r
        MOV      EDX, [EAX].fStyle\r
        DEC      CL\r
        JNZ      @@1      // if not Value -> @@1\r
\r
        AND      EDX, not WS_POPUP\r
        OR       EDX, WS_CAPTION\r
        JMP      @@set_style\r
\r
@@1:\r
        CMP      [EAX].fIsControl, 0\r
        JNZ      @@2               // if fIsControl -> @@2\r
\r
        AND      EDX, not (WS_CAPTION or WS_SYSMENU)\r
        OR       EDX, WS_POPUP\r
        JMP      @@3\r
\r
@@2:\r
        AND      EDX, not WS_CAPTION\r
        OR       EDX, WS_DLGFRAME\r
\r
@@3:\r
        PUSH     EDX\r
\r
        MOV      EDX, [EAX].fExStyle\r
        OR       EDX, WS_EX_DLGMODALFRAME\r
\r
        PUSH     EAX\r
        CALL     SetExStyle\r
        POP      EAX\r
\r
        POP      EDX\r
@@set_style:\r
        CALL     SetStyle\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetHasCaption(const Value: Boolean);\r
begin\r
  if Value = GetHasCaption then Exit;\r
  if Value then\r
  begin\r
     Style := fStyle and not (WS_POPUP or WS_DLGFRAME) or WS_CAPTION;\r
  end\r
    else\r
  begin\r
    if fIsControl then\r
       Style := fStyle and not WS_CAPTION or WS_DLGFRAME\r
    else\r
       Style := fStyle and not (WS_CAPTION or WS_SYSMENU) or WS_POPUP;\r
    ExStyle := fExStyle or WS_EX_DLGMODALFRAME;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetCanResize]\r
function TControl.GetCanResize: Boolean;\r
asm\r
        MOV      AL, [EAX].fPreventResize\r
        {$IFDEF PARANOIA}\r
        DB $34,$01\r
        {$ELSE}\r
        XOR      AL, 1\r
        {$ENDIF}\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetCanResize: Boolean;\r
begin\r
  //UpdateWndStyles;\r
  //Result := LongBool( fStyle and WS_THICKFRAME);\r
  Result := not fPreventResize;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function WndProcCanResize]\r
function WndProcCanResize( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;\r
var W, H: Integer;\r
    P: PMinMaxInfo;\r
begin\r
  if not Sender.CanResize then\r
  if M.message = WM_GETMINMAXINFO then\r
  begin\r
    Rslt := Sender.CallDefWndProc( M );\r
    W := Sender.FFixWidth;\r
    H := Sender.FFixHeight;\r
    P := Pointer( M.lParam );\r
    P.ptMinTrackSize.x := W;\r
    P.ptMinTrackSize.y := H;\r
    P.ptMaxTrackSize := P.ptMinTrackSize;\r
    Result := True; // stop further processing (prevent resizing)\r
    Exit;\r
  end\r
    else\r
  if M.message = WM_NCHITTEST then\r
  begin\r
    Rslt := Sender.CallDefWndProc( M );\r
    if (Rslt >= 10) and (Rslt <= 17) then\r
    begin\r
      Rslt := {-}HTBORDER{+}{++}(*18{HTBORDER}*){--};\r
      Result := True;\r
      exit;\r
    end;\r
  end;\r
  Result := False; // continue message processing\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetCanResize]\r
procedure TControl.SetCanResize( const Value: Boolean );\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
            CALL     GetCanResize\r
        CMP      AL, DL\r
\r
        JZ       @@exit   // Value = CanResize\r
        MOV      [EBX].fPreventResize, AL\r
        TEST     DL, DL\r
\r
        MOV      EDX, [EBX].fStyle\r
        JZ       @@set_thick\r
\r
        OR       EDX, WS_THICKFRAME\r
        JMP      @@set_style\r
\r
@@set_thick:\r
        AND      EDX, not WS_THICKFRAME\r
\r
@@set_style:\r
        MOV      EAX, EBX\r
        CALL     SetStyle\r
\r
        MOV      EAX, EBX\r
        CALL     GetWindowHandle\r
\r
        MOV      EAX, EBX\r
        CALL     GetWidth\r
        MOV      [EBX].FFixWidth, EAX\r
\r
        MOV      EAX, EBX\r
        CALL     GetHeight\r
        MOV      [EBX].FFixHeight, EAX\r
\r
        XCHG     EAX, EBX\r
        MOV      EDX, offset[WndProcCanResize]\r
        CALL     TControl.AttachProc\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetCanResize( const Value: Boolean );\r
begin\r
  if Value = CanResize then Exit;\r
  fPreventResize := not Value;\r
  if Value then\r
    Style := Style or WS_THICKFRAME\r
  else\r
    Style := Style and not WS_THICKFRAME;\r
  GetWindowHandle;\r
  FFixWidth := Width;\r
  FFixHeight := Height;\r
  AttachProc( WndProcCanResize );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetStayOnTop]\r
function TControl.GetStayOnTop: Boolean;\r
asm\r
        CALL     UpdateWndStyles\r
        TEST     byte ptr [EAX].fExStyle, WS_EX_TOPMOST\r
        SETNZ    AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetStayOnTop: Boolean;\r
begin\r
  UpdateWndStyles;\r
  Result := LongBool( fExStyle and WS_EX_TOPMOST);\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetStayOnTop]\r
procedure TControl.SetStayOnTop(const Value: Boolean);\r
asm\r
        PUSH     EAX\r
          PUSH     EDX\r
\r
            CALL     GetStayOnTop\r
          POP      ECX\r
          MOVZX    ECX, CL\r
          CMP      AL, CL\r
\r
        POP      EAX\r
        JZ       @@exit   // Value = StayOnTop\r
\r
        MOV      EDX, [EAX].fHandle\r
        TEST     EDX, EDX\r
        JZ       @@1\r
\r
        PUSH     SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE\r
        XOR      EAX, EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EAX\r
        DEC      ECX\r
        DEC      ECX\r
        PUSH     ECX\r
\r
        PUSH     EDX\r
        CALL     SetWindowPos\r
        RET\r
\r
@@1:\r
        JECXZ    @@1and\r
\r
        OR       byte ptr [EAX].fExStyle, WS_EX_TOPMOST\r
        RET\r
\r
@@1and: AND      byte ptr [EAX].fExStyle, not WS_EX_TOPMOST\r
\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetStayOnTop(const Value: Boolean);\r
begin\r
  if Value = GetStayOnTop then Exit;\r
  if fHandle <> 0 then\r
  if Value then\r
     SetWindowPos( fHandle, HWND_TOPMOST, 0,0,0,0,\r
                   SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )\r
  else\r
     SetWindowPos( fHandle, HWND_NOTOPMOST, 0,0,0,0,\r
                   SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )\r
           else\r
  if Value then fExStyle := fExStyle or WS_EX_TOPMOST\r
           else fExStyle := fExStyle and not WS_EX_TOPMOST;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.UpdateWndStyles]\r
function TControl.UpdateWndStyles: PControl;\r
asm\r
        MOV      ECX, [EAX].fHandle\r
        JECXZ    @@exit\r
\r
        PUSH     EBX\r
\r
        XCHG     EBX, EAX\r
          PUSH     GCL_STYLE\r
          PUSH     ECX\r
\r
          PUSH     GWL_EXSTYLE\r
          PUSH     ECX\r
\r
          PUSH     GWL_STYLE\r
          PUSH     ECX\r
\r
          CALL     GetWindowLong\r
          MOV      [EBX].fStyle, EAX\r
\r
          CALL     GetWindowLong\r
          MOV      [EBX].fExStyle, EAX\r
\r
          CALL     GetClassLong\r
          MOV      [EBX].fClsStyle, EAX\r
        XCHG     EAX, EBX\r
        POP      EBX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.UpdateWndStyles: PControl;\r
begin\r
  Result := @Self;\r
  if fHandle = 0 then Exit;\r
  fStyle := GetWindowLong( fHandle, GWL_STYLE );\r
  fExStyle := GetWindowLong( fHandle, GWL_EXSTYLE );\r
  fClsStyle := GetClassLong( fHandle, GCL_STYLE );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetChecked]\r
function TControl.GetChecked: Boolean;\r
asm\r
        TEST     [EAX].fBitBtnOptions, 8 //1 shl Ord(bboFixed)\r
        JZ       @@1\r
        MOV      AL, [EAX].fChecked\r
        RET\r
@@1:\r
        PUSH     0\r
        PUSH     0\r
        PUSH     BM_GETCHECK\r
        PUSH     EAX\r
        CALL     Perform\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetChecked: Boolean;\r
begin\r
  if bboFixed in fBitBtnOptions then\r
    Result := fChecked\r
  else\r
    Result := LongBool( Perform( BM_GETCHECK, 0, 0 ) ) ; //= BST_CHECKED;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.Set_Checked]\r
procedure TControl.Set_Checked(const Value: Boolean);\r
asm\r
        TEST     [EAX].fBitBtnOptions, 8 //1 shl Ord(bboFixed)\r
        JZ       @@1\r
        MOV      [EAX].fChecked, DL\r
        JMP      Invalidate\r
@@1:\r
        PUSH     0\r
        MOVZX    EDX, DL\r
        PUSH     EDX\r
        PUSH     BM_SETCHECK\r
        PUSH     EAX\r
        Call     Perform\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.Set_Checked(const Value: Boolean);\r
begin\r
  if bboFixed in fBitBtnOptions then\r
  begin\r
    fChecked := //not fChecked;\r
                Value;\r
    Invalidate;\r
  end\r
  else\r
    Perform( BM_SETCHECK, Integer( Value ), 0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TControl.SetChecked]\r
function TControl.SetChecked(const Value: Boolean): PControl;\r
begin\r
  Perform( BM_SETCHECK, Integer( Value ), 0 );\r
  Result := @Self;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.SetRadioCheckedOld]\r
function TControl.SetRadioCheckedOld: PControl;\r
asm\r
        PUSH     EAX\r
        MOV      ECX, [EAX].fParent\r
        JECXZ    @@exit\r
\r
        PUSH     [EAX].fMenu\r
        PUSH     [ECX].fRadioLast\r
        PUSH     [ECX].fRadio1st\r
        MOV      EAX, ECX\r
        CALL     GetWindowHandle\r
        PUSH     EAX\r
        CALL     CheckRadioButton\r
@@exit:\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.SetRadioCheckedOld: PControl;\r
begin\r
  Result := @Self;\r
  if fParent = nil then Exit;\r
  CheckRadioButton( fParent.GetWindowHandle,\r
                    fParent.fRadio1st,\r
                    fParent.fRadioLast,\r
                    fMenu );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[function TControl.SetRadioChecked]\r
function TControl.SetRadioChecked: PControl;\r
begin\r
  Click;\r
  Result := @Self;\r
end;\r
\r
//*\r
//[procedure TControl.Click]\r
procedure TControl.Click;\r
begin\r
  if (fCommandActions.aClick <> 0) or\r
     (fCommandActions.aEnter = BN_SETFOCUS) then\r
    Perform( WM_COMMAND, (fCommandActions.aClick shl 16) or fMenu,\r
             GetWindowHandle )\r
  else\r
  begin\r
    Perform( WM_LBUTTONDOWN, MK_LBUTTON, 0 );\r
    Perform( WM_LBUTTONUP, MK_LBUTTON, 0 );\r
  end;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetSelStart]\r
function TControl.GetSelStart: Integer;\r
asm\r
         MOVZX    ECX, [EAX].fCommandActions.aGetSelRange\r
         JECXZ    @@1\r
\r
         XOR      EDX, EDX\r
         PUSH     EDX\r
         PUSH     EDX\r
         PUSH     ECX\r
         PUSH     EAX\r
         CALL     Perform\r
         CWDE\r
         RET\r
\r
@@1:\r
         MOVZX    ECX, [EAX].fCommandActions.aExGetSelRange\r
         JECXZ    @@exit\r
         XCHG     EAX, ECX\r
         CDQ\r
         PUSH     EDX\r
         PUSH     EDX\r
         PUSH     ESP\r
         PUSH     EDX\r
         PUSH     EAX\r
         PUSH     ECX\r
         CALL     Perform\r
         POP      ECX\r
         POP      EDX\r
\r
@@exit:\r
         XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetSelStart: Integer;\r
var SR: TCharRange;\r
begin\r
  Result := 0;\r
  if fCommandActions.aGetSelRange <> 0 then\r
    Result := LoWord( Perform( fCommandActions.aGetSelRange, 0, 0 ) )\r
  else\r
  if fCommandActions.aExGetSelRange <> 0 then\r
  begin\r
    Perform( fCommandActions.aExGetSelRange, 0, Integer( @SR ) );\r
    Result := SR.cpMin;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.SetSelStart]\r
procedure TControl.SetSelStart(const Value: Integer);\r
begin\r
  ItemSelected[ Value ] := True;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetSelLength]\r
function TControl.GetSelLength: Integer;\r
asm\r
        XOR       EDX, EDX\r
        MOVZX     ECX, word ptr[EAX].fCommandActions.aGetSelCount\r
        JECXZ     @@check_ex\r
\r
        PUSH      ECX\r
        AND       CH, $7F\r
        PUSH      EDX\r
        PUSH      EDX\r
        PUSH      ECX\r
        PUSH      EAX\r
        CALL      Perform\r
        POP       ECX\r
        SHL       CH, 1\r
        JC        @@fin_EAX\r
\r
        CMP       EAX, 32768\r
        JL        @@2\r
\r
        PUSH      EAX\r
        POP       DX\r
        POP       AX\r
        SUB       AX, DX\r
        MOVZX     EAX, AX\r
@@fin_EAX:\r
        RET\r
\r
@@check_ex:\r
        MOVZX     ECX, [EAX].fCommandActions.aExGetSelRange\r
        JECXZ     @@ret_0\r
        PUSH      EDX\r
        PUSH      EDX\r
        PUSH      ESP\r
        PUSH      EDX\r
        PUSH      ECX\r
        PUSH      EAX\r
        CALL      Perform\r
        POP       EDX\r
        POP       EAX\r
        SUB       EAX, EDX\r
        RET\r
\r
@@ret_0:\r
        XOR       EAX, EAX\r
        //RET\r
\r
@@2:    TEST      EAX, EAX\r
        JL        @@ret_0\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetSelLength: Integer;\r
var SR: TCharRange;\r
begin\r
  Result := 0;\r
  if fCommandActions.aGetSelCount <> 0 then\r
  begin\r
    Result := Perform( fCommandActions.aGetSelCount and $7FFF, 0, 0 );\r
    if (fCommandActions.aGetSelCount and $8000) = 0 then\r
      if Result >= 32768 then\r
        Result := HiWord( Result ) - LoWord( Result )\r
      else\r
      if Result < 0 then\r
        Result := 0;\r
  end\r
     else\r
  if fCommandActions.aExGetSelRange <> 0 then\r
  begin\r
    Perform( fCommandActions.aExGetSelRange, 0, Integer( @SR ) );\r
    Result := SR.cpMax - SR.cpMin;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetSelLength]\r
procedure TControl.SetSelLength(const Value: Integer);\r
asm\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
        PUSH     EAX\r
        PUSH     EDX\r
        CALL     GetSelStart\r
        POP      ECX\r
        POP      EDX\r
        ADD      ECX, EAX\r
        PUSH     ECX\r
        MOVZX    ECX, [EDX].fCommandActions.aSetSelRange\r
        JECXZ    @@check_ex\r
        PUSH     EAX\r
        JMP      @@perform\r
\r
@@check_ex:\r
        MOVZX    ECX, [EDX].fCommandActions.aExSetSelRange\r
        JECXZ    @@exit\r
        PUSH     EAX\r
        PUSH     ESP\r
        PUSH     0\r
@@perform:\r
        PUSH     ECX\r
        PUSH     EDX\r
        CALL     Perform\r
@@exit: MOV      ESP, EBP\r
        POP      EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetSelLength(const Value: Integer);\r
var\r
    SR: TCharRange;\r
begin\r
  SR.cpMin := GetSelStart;\r
  SR.cpMax := SR.cpMin + Value;\r
  if Value < 0 then\r
    SR.cpMax := -1;\r
  if fCommandActions.aSetSelRange <> 0 then\r
     Perform( fCommandActions.aSetSelRange, SR.cpMin, SR.cpMax )\r
  else\r
  if fCommandActions.aExSetSelRange <> 0 then\r
     Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );\r
  // Preform( EM_SCROLLCARET, 0, 0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetItems]\r
function TControl.GetItems(Idx: Integer): String;\r
asm\r
        PUSH     ESI\r
        PUSH     EDI\r
        PUSH     EBX\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
\r
        MOV      EBX, EAX       // @Self\r
        MOV      ESI, EDX       // Idx\r
        MOV      EDI, ECX       // @Result\r
\r
        CALL     Item2Pos\r
        PUSH     0              // push  0\r
        PUSH     EAX            // store Pos\r
\r
        XCHG     EDX, EAX\r
        MOV      EAX, EBX\r
        CALL     Pos2Item       // EAX = Idx'\r
        XCHG     ESI, EAX       // ESI = Idx'\r
\r
        XOR      EAX, EAX\r
        MOVZX    ECX, [EBX].fCommandActions.aGetItemLength\r
        JECXZ    @@ret_empty\r
\r
        PUSH     ECX            // push aGetItemLength\r
\r
        PUSH     EBX\r
        CALL     Perform\r
\r
        TEST     EAX, EAX\r
        JZ       @@ret_empty\r
\r
        PUSH     EAX              // save L\r
        ADD      EAX, 4\r
\r
        CALL     System.@GetMem   // GetMem( L+4 )\r
        POP      EDX              // restore L\r
        MOV      byte ptr [EAX], 0\r
        MOVZX    ECX, [EBX].fCommandActions.aGetItemText\r
        JECXZ    @@ret_buf\r
\r
        PUSH     EDX              // save L\r
        MOV      word ptr [EAX], DX\r
\r
        PUSH     EAX\r
          PUSH     EAX            // push Buf\r
          PUSH     ESI            // push Idx\r
\r
          PUSH     ECX            // push aGetItemText\r
          PUSH     EBX\r
          CALL     Perform\r
        POP      EAX\r
\r
        POP      EDX\r
@@ret_buf:\r
        MOV      byte ptr [EAX + EDX], 0   // Buf[ L ] := #0\r
\r
@@ret_empty:     // EAX = 0\r
        XCHG     EDX, EAX\r
        MOV      EAX, EDI\r
        PUSH     EDX\r
        CALL     System.@LStrFromPChar\r
        POP      ECX\r
        JECXZ    @@exit\r
        XCHG     EAX, ECX\r
        CALL     System.@FreeMem\r
\r
@@exit:\r
        MOV      ESP, EBP\r
        POP      EBP\r
        POP      EBX\r
        POP      EDI\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetItems(Idx: Integer): String;\r
var L, Pos: Integer;\r
    Buf: PChar;\r
begin\r
  Result := '';\r
  Pos := Item2Pos( Idx );\r
  Idx := Pos2Item( Pos );\r
  if fCommandActions.aGetItemLength <> 0 then\r
    L := Perform( fCommandActions.aGetItemLength, Pos, 0 )\r
  else\r
    Exit;\r
  if L = 0 then Exit;\r
  GetMem( Buf, L + 4 );\r
  PWORD( Buf )^ := L + 1;\r
  if fCommandActions.aGetItemText <> 0 then\r
    Perform( fCommandActions.aGetItemText, Idx, Integer( Buf ) );\r
  Buf[ L ] := #0;\r
  Result := Buf;\r
  FreeMem( Buf );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetItems]\r
procedure TControl.SetItems(Idx: Integer; const Value: String);\r
asm\r
        PUSH     EDI\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        XCHG     EDI, EDX       // EDI = Idx\r
        CALL     ECX2PChar\r
        PUSH     ECX       // @Value[1]\r
\r
        MOVZX    ECX, [EBX].fCommandActions.aSetItemText\r
        JECXZ    @@1\r
\r
        PUSH     0\r
        PUSH     ECX\r
\r
        MOV      EDX, EDI\r
        MOV      EAX, EBX\r
        CALL     Item2Pos\r
        PUSH     EAX            // store Strt\r
\r
        MOV      EDX, EDI\r
        INC      EDX\r
        MOV      EAX, EBX\r
        CALL     Item2Pos\r
        POP      EDX            // EDX = Strt\r
\r
        SUB      EAX, EDX\r
        PUSH     EAX            // store L\r
\r
        MOV      EAX, EBX\r
        CALL     SetSelStart\r
\r
        POP      EDX            // EDX = L\r
        PUSH     EBX            // prepare @Self for Perform\r
        XCHG     EAX, EBX\r
        CALL     SetSelLength\r
\r
        // @Value[1] already in stack,\r
        // 0 already in stack\r
        // aSetItemText already in stack\r
        // @Self already in stack\r
\r
        CALL     Perform\r
        JMP      @@exit\r
\r
@@1:    // @Value[1] in stack already\r
        POP      EDX\r
        MOVZX    ECX, [EBX].fCommandActions.aDeleteItem\r
        JECXZ    @@exit\r
\r
        {$IFNDEF  NOT_FIX_CURINDEX}\r
        PUSH     ESI\r
        PUSH     EBP\r
\r
        PUSH     EDX\r
\r
        MOV      EAX, EBX               // +AK\r
        CALL     GetCurIndex            // +AK\r
        XCHG     ESI, EAX    // ESI = TmpCurIdx\r
\r
        MOV      EAX, EBX\r
        MOV      EDX, EDI\r
        CALL     GetItemData\r
        XCHG     EBP, EAX   // EBP = TmpData\r
\r
        MOV      EDX, EDI\r
        MOV      EAX, EBX\r
        CALL     Delete\r
\r
        MOV      EAX, EBX               // *AK\r
        MOV      EDX, EDI\r
        POP      ECX\r
        CALL     Insert\r
\r
        MOV      ECX, EBP // ECX = TmpData\r
        MOV      EDX, EDI\r
        MOV      EAX, EBX\r
        CALL     SetItemData\r
\r
        XCHG     EAX, EBX               // +AK\r
        MOV      EDX, ESI               // +AK\r
        CALL     SetCurIndex            // +AK\r
\r
        POP      EBP\r
        POP      ESI\r
        {$ELSE NOT_FIX_CURINDEX}\r
        PUSH     EDX\r
\r
        MOV      EDX, EDI\r
        MOV      EAX, EBX\r
        CALL     Delete\r
\r
        XCHG     EAX, EBX\r
        XCHG     EDX, EDI\r
\r
        POP      ECX\r
        CALL     Insert\r
        {$ENDIF NOT_FIX_CURINDEX}\r
\r
@@exit:\r
        POP      EBX\r
        POP      EDI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetItems(Idx: Integer; const Value: String);\r
var Strt, L : Integer;\r
    {$IFNDEF NOT_FIX_CURINDEX}\r
    TmpCurIdx: Integer; // AK - Andrzey Kubasek\r
    TmpData: DWORD;\r
    {$ENDIF NOT_FIX_CURINDEX}\r
begin\r
  if fCommandActions.aSetItemText <> 0 then\r
  begin\r
    Strt := Item2Pos( Idx );\r
    L := Item2Pos( Idx + 1 ) - Strt;\r
    SelStart := Strt;\r
    SelLength := L;\r
    Perform( fCommandActions.aSetItemText, 0, Integer( PChar( Value ) ) );\r
  end\r
     else\r
  if fCommandActions.aDeleteItem <> 0 then\r
  begin\r
    {$IFNDEF NOT_FIX_CURINDEX}\r
    TmpCurIdx := CurIndex; // +AK\r
    TmpData := ItemData[ Idx ];\r
    {$ENDIF}\r
    Delete( Idx );\r
    Insert( Idx, Value );\r
    {$IFNDEF NOT_FIX_CURINDEX}\r
    CurIndex := TmpCurIdx; //+AK\r
    ItemData[ Idx ] := TmpData;\r
    {$ENDIF}\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetItemsCount]\r
function TControl.GetItemsCount: Integer;\r
asm\r
        PUSH     0\r
        MOVZX    ECX, [EAX].fCommandActions.aGetCount\r
        JECXZ    @@ret_0\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     Perform\r
        PUSH     EAX\r
\r
@@ret_0:\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetItemsCount: Integer;\r
begin\r
  Result := 0;\r
  {$IFDEF DEBUG}\r
  try\r
  {$ENDIF}\r
  if fCommandActions.aGetCount = 0 then Exit;\r
  Result := Perform( fCommandActions.aGetCount, 0, 0 );\r
  {$IFDEF DEBUG}\r
  except\r
    asm\r
      int 3\r
    end;\r
  end;\r
  {$ENDIF}\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[procedure TControl.SetItemsCount]\r
procedure TControl.SetItemsCount(const Value: Integer);\r
begin\r
  if fCommandActions.aSetCount = 0 then Exit;\r
  Perform( fCommandActions.aSetCount, Value, 0 );\r
end;\r
\r
//[PROCEDURE HelpConvertItem2Pos]\r
{$IFDEF ASM_VERSION}\r
procedure HelpConvertItem2Pos;\r
asm\r
        JECXZ     @@exit\r
        PUSH      0\r
        PUSH      EDX\r
        PUSH      ECX\r
        PUSH      EAX\r
        CALL      TControl.Perform\r
        XOR       EDX, EDX\r
        TEST      EAX, EAX\r
        JL        @@exit\r
        RET\r
@@exit:\r
        MOV       EAX, EDX\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END HelpConvertItem2Pos]\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Item2Pos]\r
function TControl.Item2Pos(ItemIdx: Integer): Integer;\r
asm\r
        MOVZX     ECX, [EAX].fCommandActions.aItem2Pos\r
        JMP       HelpConvertItem2Pos\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Item2Pos(ItemIdx: Integer): Integer;\r
begin\r
  Result := ItemIdx;\r
  if fCommandActions.aItem2Pos <> 0 then\r
  begin\r
    Result := Perform( fCommandActions.aItem2Pos, ItemIdx, 0 );\r
    if Result < 0 then Result := 0;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Pos2Item]\r
function TControl.Pos2Item(Pos: Integer): Integer;\r
asm\r
        MOVZX     ECX, [EAX].fCommandActions.aPos2Item\r
        JMP       HelpConvertItem2Pos\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Pos2Item(Pos: Integer): Integer;\r
begin\r
  Result := Pos;\r
  if fCommandActions.aPos2Item <> 0 then\r
  Result := Perform( fCommandActions.aPos2Item, Pos, 0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function WndProcTabChar]\r
function WndProcTabChar( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  if M.message = WM_CHAR then\r
  begin\r
    if M.wParam = 9 then\r
    begin\r
      //M.wParam := 0;\r
      Sender.ReplaceSelection( #9, TRUE );\r
    end;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[function TControl.EditTabChar]\r
function TControl.EditTabChar: PControl;\r
begin\r
  AttachProc( WndProcTabChar );\r
  Result := @Self;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Add]\r
function TControl.Add(const S: String): Integer;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX               // EBX = @Self\r
\r
        MOVZX    ECX, [EBX].fCommandActions.aAddItem   // ECX = aAddItem\r
        JECXZ    @@chk_addtext\r
\r
        CALL     EDX2PChar\r
        PUSH     EDX\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     EBX\r
        CALL     Perform\r
        PUSH     EAX\r
\r
        MOV      EAX, EBX\r
        CALL     TControl.GetItemsCount\r
        XCHG     EAX, ECX\r
        LOOP     @@ret_EAX\r
\r
        XCHG     EAX, EBX\r
        INC      ECX\r
        XOR      EDX, EDX\r
        CALL     TControl.SetItemSelected\r
@@ret_EAX:\r
        POP      EAX\r
        JMP      @@exit\r
\r
@@chk_addtext:\r
        MOV      ECX, [EBX].fCommandActions.aAddText\r
        JECXZ    @@add_text_simple\r
\r
        CALL     ECX\r
        JMP      @@exit_0\r
\r
@@add_text_simple:\r
        PUSH     EDX\r
        PUSH     0\r
        MOV      EDX, ESP\r
        CALL     GetCaption\r
        POP      EAX\r
        POP      EDX\r
        PUSH     EAX\r
        MOV      EAX, ESP\r
        CALL     System.@LStrCat\r
        MOV      EAX, EBX\r
        POP      EDX\r
        PUSH     EDX\r
        CALL     SetCaption\r
        CALL     RemoveStr\r
@@exit_0:\r
        XOR      EAX, EAX\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Add(const S: String): Integer;\r
begin\r
  if fCommandActions.aAddItem <> 0 then\r
  begin\r
    Result := Perform( fCommandActions.aAddItem, 0, Integer( PChar( S ) ) );\r
    if Count = 1 then\r
      ItemSelected[ 0 ] := True;\r
  end\r
    else\r
  begin\r
    if assigned( fCommandActions.aAddText ) then\r
      fCommandActions.aAddText( @Self, S )\r
    else\r
      Text := Text + S;\r
    Result := 0;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.Delete]\r
procedure TControl.Delete(Idx: Integer);\r
asm\r
        MOVZX    ECX, [EAX].fCommandActions.aDeleteItem\r
        JECXZ    @@exit\r
\r
        PUSH     0\r
        PUSH     EDX\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     Perform\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.Delete(Idx: Integer);\r
begin\r
  if fCommandActions.aDeleteItem <> 0 then\r
    Perform( fCommandActions.aDeleteItem, Idx, 0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Insert]\r
function TControl.Insert(Idx: Integer; const S: String): Integer;\r
asm\r
         CALL    ECX2PChar\r
         PUSH    ECX\r
         MOVZX   ECX, [EAX].fCommandActions.aInsertItem\r
         JECXZ   @@exit_1\r
\r
         PUSH    EDX\r
         PUSH    ECX\r
         PUSH    EAX\r
         CALL    Perform\r
         RET\r
\r
@@exit_1:OR      EAX, -1\r
         POP     ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Insert(Idx: Integer; const S: String): Integer;\r
begin\r
  if fCommandActions.aInsertItem <> 0 then\r
    Result := Perform( fCommandActions.aInsertItem, Idx, Integer( PChar( S ) ) )\r
  else\r
    Result := -1;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetItemSelected]\r
function TControl.GetItemSelected(ItemIdx: Integer): Boolean;\r
asm\r
        MOVZX    ECX, [EAX].fCommandActions.aGetSelected\r
        JECXZ    @@check_range\r
\r
        PUSH     0\r
        PUSH     EDX\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     Perform\r
        TEST     EAX, EAX\r
        SETG     AL\r
        RET\r
\r
@@check_range:\r
        MOVZX    ECX, [EAX].fCommandActions.aGetSelRange\r
        JECXZ    @@check_ex\r
\r
          PUSH     EDX\r
        PUSH     0\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     Perform\r
          POP      EDX\r
        TEST     EAX, EAX\r
        JL       @@ret_false\r
\r
        CMP      DX, AX\r
        JL       @@ret_false\r
\r
        SHR      EAX, 16\r
        SUB      EDX, EAX\r
        SETL     AL\r
        RET\r
\r
@@check_ex:\r
        MOVZX    ECX, [EAX].fCommandActions.aExGetSelRange\r
        JECXZ    @@ret_false\r
          PUSH     EDX\r
        PUSH     EDX\r
        PUSH     EDX\r
        PUSH     ESP\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     Perform\r
        POP      ECX\r
        POP      EDX\r
          POP      EAX\r
\r
        SUB      EAX, EDX\r
        CMP      EAX, ECX\r
        SETB     AL\r
        RET\r
\r
@@ret_false:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetItemSelected(ItemIdx: Integer): Boolean;\r
var SR: TCharRange;\r
begin\r
  Result := False;\r
  if fCommandActions.aGetSelected <> 0 then\r
    Result := 0 < Perform( fCommandActions.aGetSelected, ItemIdx, 0 )\r
  else if fCommandActions.aGetSelRange <> 0 then\r
  begin\r
    Perform( fCommandActions.aGetSelRange, Integer( @SR.cpMin ), Integer( @SR.cpMax ) );\r
    Result := (SR.cpMin <= ItemIdx) and (ItemIdx < SR.cpMax);\r
  end\r
  else if fCommandActions.aExGetSelRange <> 0 then\r
  begin\r
    Perform( fCommandActions.aExGetSelRange, 0, Integer( @SR ) );\r
    Result := (SR.cpMin <= ItemIdx) and (ItemIdx < SR.cpMax);\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetItemSelected]\r
procedure TControl.SetItemSelected(ItemIdx: Integer; const Value: Boolean);\r
asm\r
        PUSH     EDX\r
        PUSH     ECX\r
        MOVZX    ECX, [EAX].fCommandActions.aSetSelected\r
        JECXZ    @@chk_aSetCurrent\r
\r
@@0:\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     Perform\r
        RET\r
\r
@@chk_aSetCurrent:\r
        POP      ECX\r
        MOVZX    ECX, [EAX].fCommandActions.aSetCurrent\r
        JECXZ    @@chk_aSetSelRange\r
\r
        POP      EDX\r
        PUSH     0\r
        JMP      @@3\r
\r
@@chk_aSetSelRange:\r
        MOVZX    ECX, [EAX].fCommandActions.aSetSelRange\r
        JECXZ    @@chk_aExSetSelRange\r
@@3:\r
        PUSH     EDX\r
        JMP      @@0\r
\r
@@else: MOV      [EAX].FCurIndex, EDX\r
        CALL     Invalidate\r
        JMP      @@exit\r
\r
@@chk_aExSetSelRange:\r
        MOVZX    ECX, [EAX].fCommandActions.aExSetSelRange\r
        JECXZ    @@else\r
\r
        PUSH     EDX\r
        PUSH     ESP\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     Perform\r
        POP      ECX\r
\r
@@exit:\r
        POP      ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetItemSelected(ItemIdx: Integer; const Value: Boolean);\r
var SR: TCharRange;\r
begin\r
  if fCommandActions.aSetSelected <> 0 then\r
    Perform( fCommandActions.aSetSelected, Integer( Value ), ItemIdx )\r
  else\r
  if fCommandActions.aSetCurrent <> 0 then\r
    Perform( fCommandActions.aSetCurrent, ItemIdx, 0 )\r
  else\r
  if fCommandActions.aSetSelRange <> 0 then\r
    Perform( fCommandActions.aSetSelRange, ItemIdx, ItemIdx )\r
  else\r
  if fCommandActions.aExSetSelRange <> 0 then\r
  begin\r
    SR.cpMin := ItemIdx;\r
    SR.cpMax := ItemIdx;\r
    Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );\r
  end\r
    else\r
  begin // for ImageShow: set the index and invalidate the control\r
    FCurIndex := ItemIdx;\r
    Invalidate;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetCtl3D]\r
procedure TControl.SetCtl3D(const Value: Boolean);\r
asm\r
        MOV      [EAX].fCtl3Dchild, DL\r
        CMP      [EAX].fCtl3D, DL\r
        JE       @@exit\r
        MOV      [EAX].fCtl3D, DL\r
        PUSHAD\r
        CALL     UpdateWndStyles\r
        POPAD\r
        MOV      ECX, [EAX].fExStyle\r
        DEC      DL\r
        MOV      EDX, [EAX].fStyle\r
        JNZ      @@1\r
        AND      EDX, not WS_BORDER\r
        OR       CH, WS_EX_CLIENTEDGE shr 8\r
        JMP      @@2\r
@@1:\r
        OR       EDX, WS_BORDER\r
        AND      CH, not(WS_EX_CLIENTEDGE shr 8)\r
@@2:\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     SetStyle\r
        POP      EAX\r
        POP      EDX\r
        JMP      SetExStyle\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetCtl3D(const Value: Boolean);\r
begin\r
  fCtl3Dchild := Value;\r
  if fCtl3D = Value then Exit;\r
  fCtl3D := Value;\r
  UpdateWndStyles;\r
  if Value then\r
  begin\r
    ExStyle := fExStyle or WS_EX_CLIENTEDGE;\r
    Style := fStyle and not WS_BORDER;\r
  end\r
     else\r
  begin\r
    ExStyle := fExStyle and not WS_EX_CLIENTEDGE;\r
    Style := fStyle or WS_BORDER;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Shift]\r
function TControl.Shift(dX, dY: Integer): PControl;\r
asm\r
        PUSHAD\r
        ADD      EDX, [EAX].fBoundsRect.TRect.Left\r
        CALL     SetLeft\r
        POPAD\r
        PUSH     EAX\r
        MOV      EDX, [EAX].fBoundsRect.TRect.Top\r
        ADD      EDX, ECX\r
        CALL     SetTop\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Shift(dX, dY: Integer): PControl;\r
begin\r
  Left := fBoundsRect.Left + dX;\r
  Top := fBoundsRect.Top + dY;\r
  Result := @Self;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure SetKeyEvent]\r
procedure SetKeyEvent( Self_: PControl );\r
begin\r
  Self_.fWndProcKeybd := WndProcKeybd;\r
  //Self_.AttachProc( WndProcKeyBd );\r
end;\r
\r
//[procedure TControl.SetOnChar]\r
procedure TControl.SetOnChar(const Value: TOnChar);\r
begin\r
  fOnChar := Value;\r
  SetKeyEvent( @Self );\r
end;\r
\r
//[procedure TControl.SetOnKeyDown]\r
procedure TControl.SetOnKeyDown(const Value: TOnKey);\r
begin\r
  fOnKeyDown := Value;\r
  SetKeyEvent( @Self );\r
end;\r
\r
//[procedure TControl.SetOnKeyUp]\r
procedure TControl.SetOnKeyUp(const Value: TOnKey);\r
begin\r
  fOnKeyUp := Value;\r
  SetKeyEvent( @Self );\r
end;\r
\r
//[FUNCTION CollectTabControls]\r
{$IFDEF ASM_VERSION}\r
function CollectTabControls( Form: PControl ): PList;\r
asm\r
        PUSH     EDI\r
        PUSH     EAX\r
        CALL     NewList\r
        XCHG     EDI, EAX\r
        POP      EAX\r
        CALL     @@collecttab\r
        XCHG     EAX, EDI\r
        POP      EDI\r
        RET\r
@@collecttab:\r
        { <- EDI = Result:PList\r
             EAX = Form (or Control)\r
        }\r
        PUSH     ESI\r
        PUSH     EBX\r
        MOV      EDX, [EAX].TControl.fChildren\r
        MOV      ECX, [EDX].TList.fCount\r
        MOV      ESI, [EDX].TList.fItems\r
        JECXZ    @@e_loop\r
@@loo:  PUSH     ECX\r
        LODSD\r
\r
          PUSH     EAX\r
\r
        TEST     byte ptr [EAX].TControl.fStyle+2, WS_TABSTOP shr 16\r
        JZ       @@call_recur\r
\r
        MOV      DL, [EAX].TControl.fTabStop\r
        AND      DL, [EAX].TControl.fEnabled\r
        JZ       @@call_recur\r
\r
        CALL     TControl.GetToBeVisible\r
        TEST     AL, AL\r
        POP      EAX\r
        JZ       @@next\r
        PUSH     EAX\r
\r
          XCHG     EDX, EAX\r
          PUSH     ESI\r
          MOV      ECX, [EDI].TList.fCount\r
          MOV      ESI, [EDI].TList.fItems\r
          XOR      EBX, EBX\r
          JECXZ    @@e_loo2\r
@@loo2:   LODSD\r
          MOV      EAX, [EAX].TControl.fTabOrder\r
          CMP      EAX, [EDX].TControl.fTabOrder\r
          JLE      @@next2\r
          POP      ESI\r
          MOV      ECX, EDX\r
          MOV      EDX, EBX\r
          MOV      EAX, EDI\r
          CALL     TList.Insert\r
          JMP      @@call_recur\r
\r
@@next2:  INC      EBX\r
          LOOP     @@loo2\r
@@e_loo2:\r
          POP      ESI\r
          MOV      EAX, EDI\r
          CALL     TList.Add\r
\r
@@call_recur:\r
          POP      EAX\r
          MOVZX    ECX, [EAX].TControl.fEnabled\r
          JECXZ    @@next\r
          CALL     @@collecttab\r
\r
@@next: POP      ECX\r
        LOOP     @@loo\r
\r
@@e_loop:\r
        POP      EBX\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CollectTabControls( Form: PControl ): PList;\r
var R: PList;\r
  procedure CollectTab( P: PControl );\r
  var I, J: Integer;\r
      C, D: PControl;\r
  begin\r
    for I := 0 to P.fChildren.fCount - 1 do\r
    begin\r
      C := P.fChildren.fItems[ I ];\r
      if C.fTabstop and C.fEnabled and C.ToBeVisible and\r
         (C.fStyle and WS_TABSTOP <> 0) then\r
      begin\r
        D := nil;\r
        for J := 0 to R.fCount - 1 do\r
        begin\r
          D := R.fItems[ J ];\r
          if D.fTabOrder > C.fTabOrder then\r
          begin\r
            R.Insert( J, C );\r
            break;\r
          end\r
             else\r
            D := nil;\r
        end;\r
        if D = nil then\r
           R.Add( C );\r
      end;\r
      if C.fEnabled then\r
        CollectTab( C );\r
    end;\r
  end;\r
begin\r
  R := NewList;\r
  CollectTab( Form );\r
  Result := R;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CollectTabControls]\r
\r
//[PROCEDURE Tabulate2Next]\r
{$IFDEF ASM_VERSION}\r
procedure Tabulate2Next( Form: PControl; Dir: Integer );\r
asm\r
        PUSHAD\r
        PUSH     EAX      // save Form\r
        MOV      EBX, EAX\r
        MOV      EBP, EDX // EBP = Dir (direction <0 or >0)\r
        CALL     CollectTabControls\r
        XCHG     EDI, EAX // EDI = CL (list of controls)\r
\r
        MOV      ECX, [EBX].TControl.fCurrentControl // C := Form.fCurrentControl\r
        XOR      EBX, EBX // I = 0\r
        JECXZ    @@1\r
        MOV      EBX, [ECX].TControl.fTabOrder // I = C.fTabOrder\r
@@1:\r
        MOV      ECX, [EDI].TList.fCount\r
        MOV      ESI, [EDI].TList.fItems\r
        XOR      EDX, EDX\r
        PUSH     EDX      // Ctrl1 = nil\r
        PUSH     EDX      // Ctrl2 = nil\r
        //JECXZ    @@e_loop\r
        TEST     ECX, ECX\r
        JZ       @@e_loop\r
\r
@@loop: PUSH     ECX\r
        LODSD\r
        CMP      [EAX].TControl.fTabOrder, EBX\r
        JZ       @@next\r
\r
        MOV      ECX, [ESP+8] // ECX = Ctrl1\r
        JECXZ    @@c1nil\r
        MOV      ECX, [ECX].TControl.fTabOrder // ECX = Ctrl1.fTabOrder\r
        TEST     EBP, EBP\r
        JGE      @@c1ge\r
\r
        CMP      [EAX].TControl.fTabOrder, EBX\r
        JGE      @@2\r
        CMP      [EAX].TControl.fTabOrder, ECX\r
        JLE      @@2\r
\r
@@c1new:\r
        MOV      [ESP+8], EAX // Ctrl1 := C\r
        JMP      @@2\r
\r
@@c1ge: CMP      [EAX].TControl.fTabOrder, EBX\r
        JLE      @@2\r
        CMP      [EAX].TControl.fTabOrder, ECX\r
        JL       @@c1new\r
        JMP      @@2\r
\r
@@c1nil:\r
        TEST     EBP, EBP\r
        JL       @@c1nil_dirL\r
        CMP      [EAX].TControl.fTabOrder, EBX\r
        JG       @@c1new\r
        JMP      @@2\r
\r
@@c1nil_dirL:\r
        CMP      [EAX].TControl.fTabOrder, EBX\r
        JL       @@c1new\r
\r
@@2:\r
        MOV      ECX, [ESP+4] // ECX = Ctrl2\r
        JECXZ    @@c2new\r
        MOV      ECX, [ECX].TControl.fTabOrder\r
\r
        TEST     EBP, EBP\r
        JL       @@c2dirL\r
        CMP      [EAX].TControl.fTabOrder, ECX\r
        JGE      @@next\r
        JMP      @@c2new\r
\r
@@c2dirL:\r
        CMP      [EAX].TControl.fTabOrder, ECX\r
        JLE      @@next\r
@@c2new:\r
        MOV      [ESP+4], EAX\r
\r
@@next: POP      ECX\r
        DEC      ECX\r
        JNZ      @@loop\r
        //LOOP     @@loop\r
@@e_loop:\r
\r
        POP      EDX // Ctrl2\r
        POP      ECX // Ctrl1\r
        INC      ECX\r
        LOOP     @@3\r
        MOV      ECX, EDX\r
@@3:\r
        POP      EBX // EBX = Form\r
        JECXZ    @@exit\r
\r
        XCHG     EAX, ECX\r
        MOV      ECX, [EAX].TControl.fHandle\r
        JECXZ    @@no_handle\r
\r
        INC      [EAX].TControl.fClickDisabled\r
        PUSH     EAX\r
        PUSH     ECX\r
        CALL     Windows.SetFocus\r
        POP      EAX\r
        DEC      [EAX].TControl.fClickDisabled\r
\r
@@no_handle:\r
        MOV      [EBX].TControl.fCurrentControl, EAX\r
\r
@@exit:\r
        XCHG     EAX, EDI\r
        CALL     TObj.Free\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure Tabulate2Next( Form: PControl; Dir: Integer );\r
var CL : PList;\r
    I, J : Integer;\r
    Ctrl1, Ctrl2, C : PControl;\r
begin\r
  CL := CollectTabControls( Form );\r
\r
  I := 0;\r
  C := Form.fCurrentControl;\r
  if C <> nil then\r
    I := C.fTabOrder;\r
  Ctrl2 := nil;\r
  Ctrl1 := nil;\r
  for J := 0 to CL.fCount - 1 do\r
  begin\r
    C := CL.fItems[ J ];\r
    if C.fTabOrder = I then continue;\r
    if (Ctrl1 = nil)\r
       and (    (Dir >= 0) and (C.fTabOrder > I)\r
             or (Dir < 0) and (C.fTabOrder < I)  )\r
    or (Dir >= 0)\r
       and (C.fTabOrder > I) and (C.fTabOrder < Ctrl1.fTabOrder)\r
    or (Dir < 0)\r
       and (C.fTabOrder < I) and (C.fTabOrder > Ctrl1.fTabOrder)\r
    then Ctrl1 := C;\r
    if (Ctrl2 = nil)\r
    or (Dir >= 0) and (C.fTabOrder < Ctrl2.fTabOrder)\r
    or (Dir < 0) and (C.fTabOrder > Ctrl2.fTabOrder)\r
    then Ctrl2 := C;\r
  end;\r
  if Ctrl1 = nil then\r
    Ctrl1 := Ctrl2;\r
  if Ctrl1 <> nil then\r
  begin\r
    if Ctrl1.fHandle <> 0 then\r
    begin\r
      Inc( Ctrl1.fClickDisabled );\r
      SetFocus( Ctrl1.fHandle );\r
      Dec( Ctrl1.fClickDisabled );\r
    end;\r
    Form.fCurrentControl := Ctrl1;\r
  end;\r
  CL.Free;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Tabulate2Next]\r
\r
//[FUNCTION Tabulate2Control]\r
{$IFDEF ASM_VERSION}\r
function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;\r
const tk_Tab = 1;\r
      tk_LR  = 2;\r
      tk_UD  = 4;\r
      tk_PuPd= 8;\r
asm\r
        PUSH     ESI\r
        MOV      ESI, offset[@@data]\r
        PUSH     EAX\r
        MOV      AH, 9\r
@@loop:\r
        LODSB\r
        CMP      DL, AL\r
        JE       @@1\r
        LODSB\r
        CMP      DL, AL\r
        JE       @@2\r
        ADD      AH, AH\r
        JNB      @@loop\r
        POP      EAX\r
@@exit0:\r
        XOR      EAX, EAX\r
        JMP      @@exit\r
\r
@@data:\r
        DB       -1, VK_TAB, VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT\r
\r
@@1:\r
        OR       EDX, -1\r
        JMP      @@3\r
@@2:\r
        XOR      EDX, EDX\r
        TEST     AH, 1\r
        JZ       @@3\r
\r
          PUSH     ECX\r
        PUSH     EAX\r
        PUSH     VK_SHIFT\r
        CALL     GetAsyncKeyState\r
        CDQ\r
        POP      EAX\r
          POP      ECX\r
@@3:\r
        POP      ESI\r
        //////////////////////////////////////////////////\r
        MOV      AL, AH\r
        {$IFDEF PARANOIA}\r
        DB $24, 1\r
        {$ELSE}\r
        AND      AL, 1\r
        {$ENDIF}\r
        TEST     byte ptr [ESI].TControl.fLookTabKeys, AL\r
        //////////////////////////////////////////////////\r
        JZ       @@exit0\r
\r
        TEST     CL, CL\r
        JNZ      @@exit\r
\r
        PUSH     EDX\r
        MOV      EAX, ESI\r
        CALL     TControl.ParentForm\r
        POP      EDX\r
        CALL     Tabulate2Next\r
@@exit:\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;\r
var Form: PControl;\r
begin\r
  Result := False;\r
  case Key of\r
  VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit;\r
  VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit;\r
  VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit;\r
  VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then exit;\r
  else Exit;\r
  end;\r
\r
  Result := True;\r
  if checkOnly then Exit;\r
\r
  Form := Self_.ParentForm;\r
  case Key of\r
  VK_TAB:\r
    if GetKeyState( VK_SHIFT ) < 0 then\r
      Tabulate2Next( Form, -1 )\r
    else\r
      Tabulate2Next( Form, 1 );\r
  VK_RIGHT, VK_DOWN, VK_NEXT: Tabulate2Next( Form, 1 );\r
  VK_LEFT, VK_UP, VK_PRIOR:   Tabulate2Next( Form, -1 );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Tabulate2Control]\r
\r
//[FUNCTION Tabulate2ControlEx]\r
{$IFDEF ASM_VERSION}\r
function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;\r
asm\r
        PUSH     EDI\r
        MOVZX    EDI, CL\r
        TEST     byte ptr [EAX].TControl.fLookTabKeys, 1\r
        JZ       @@1\r
@@0:\r
        MOV      ECX, EDX\r
        AND      CL, 7Fh\r
        CMP      CL, VK_TAB\r
        JNE      @@1\r
\r
        PUSH     EDX\r
        CALL     TControl.ParentForm\r
        POP      EDX\r
        MOVSX    EDX, DL\r
        TEST     EDX, EDX\r
        JS       @@tab\r
\r
        PUSH     EAX\r
\r
        PUSH     VK_SHIFT\r
        CALL     GetAsyncKeyState\r
        SAR      EAX, 31\r
        {$IFDEF PARANOIA}\r
        DB $0C, $01\r
        {$ELSE}\r
        OR       AL, 1\r
        {$ENDIF}\r
        MOV      EDX, EAX\r
\r
        POP      EAX\r
@@tab:\r
        TEST     EDI, EDI\r
        POP      EDI\r
        JNZ      @@no_tab\r
        CALL     Tabulate2Next\r
@@no_tab:\r
        MOV      AL, 1\r
        RET\r
\r
@@data: DB VK_LEFT, VK_LEFT\r
        DD offset[@@left]\r
        DB VK_UP, 2\r
        DB VK_RIGHT, VK_RIGHT\r
        DD offset[@@right]\r
        DB VK_DOWN, 2\r
        DB VK_UP, VK_PRIOR\r
        DD offset[@@up]\r
        DB VK_TAB or 80h, $C\r
        DB VK_DOWN, VK_NEXT\r
        DD offset[@@down]\r
        DB VK_TAB, $C\r
\r
@@1:\r
        {\r
          EAX <- Self_:PControl\r
           DL <- Key\r
        }\r
        PUSH     ESI\r
        MOV      ESI, offset[@@data]-6\r
        MOV      DH, 9\r
        PUSH     EAX\r
@@loop:\r
        ADD      DH, DH\r
        JNB      @@l1\r
        JMP      @@abort\r
@@fault1:\r
        POP      EDI\r
        POPAD\r
        PUSH     EAX\r
@@abort:\r
        POP      EAX\r
@@abort1:\r
        POP      ESI\r
        POP      EDI\r
        XOR      EAX, EAX\r
        RET\r
\r
@@right:\r
        MOV      EAX, [ESP].TRect.Left\r
        SUB      EAX, [ESP+16].TRect.Left\r
@@left_right:\r
        JL       @@next1\r
        MOV      EDX, [ESP].TRect.Bottom\r
        SUB      EDX, [ESP+16].TRect.Top\r
        JL       @@next1\r
        MOV      EDX, [ESP].TRect.Top\r
        SUB      EDX, [ESP+16].TRect.Bottom\r
        JGE      @@next1\r
@@chk_dist:\r
        CMP      EAX, EDI\r
        JA       @@next1\r
        MOV      EDI, EAX\r
        MOV      EAX, [EBX+ECX*4-4]\r
        MOV      [ESP+36], EAX     // Found = Ctrl\r
        JMP      @@next1\r
\r
@@l1:\r
        LODSD\r
        LODSW\r
        LODSW\r
        CMP      AL, DL\r
        JE       @@2\r
        CMP      AH, DL\r
        JNE      @@loop\r
\r
@@2:\r
        PUSH     ESI\r
        LODSD\r
        LODSW\r
        POP      ESI\r
        XCHG     EDX, EAX\r
        POP      EAX\r
        TEST     [EAX].TControl.fLookTabKeys, DH      \r
        JZ       @@abort1\r
\r
        PUSHAD\r
        PUSH     EDI\r
        CALL     TControl.ParentForm\r
        MOV      ECX, [EAX].TControl.fCurrentControl\r
        JECXZ    @@fault1\r
        MOV      EBP, ECX           // EBP = CurCtrl\r
\r
        PUSH     EAX                // save Form\r
        MOV      EBX, EAX\r
        CALL     CollectTabControls\r
        PUSH     0                  // save Found = nil\r
        PUSH     EAX                // save CollectedList\r
        MOV      EDI, EAX\r
\r
        MOV      EBX, [EDI].TList.fItems\r
        ADD      ESP, -16\r
        PUSH     ESP\r
        PUSH     [EBP].TControl.fHandle\r
        CALL     GetWindowRect\r
\r
        MOV      ECX, [EDI].TList.fCount\r
        OR       EDI, -1            // EDI = minDist\r
@@loop1:\r
        MOV      EAX, [EBX+ECX*4-4]\r
        CMP      EAX, EBP\r
        JE       @@next\r
        {}\r
        MOV      DL, [EAX].TControl.fEnabled\r
        AND      DL, [EAX].TControl.fTabstop\r
        JZ       @@next\r
        {}\r
        ADD      ESP, -16\r
        MOV      EDX, ESP\r
        PUSH     ECX\r
\r
        //CALL     TControl.ControlRect\r
        PUSH     EDX\r
        PUSH     [EAX].TControl.fHandle\r
        CALL     GetWindowRect\r
\r
        POP      ECX\r
        JMP      dword ptr [ESI]\r
\r
@@left:\r
        MOV      EAX, [ESP+16].TRect.Left\r
        SUB      EAX, [ESP].TRect.Left\r
        JMP      @@left_right\r
\r
@@not_found:\r
        POP      EDI\r
        POPAD\r
        MOV      DL, [ESI+4]\r
        POP      ESI\r
        JMP      @@0\r
\r
@@up:\r
        MOV      EAX, [ESP+16].TRect.Top\r
        SUB      EAX, [ESP].TRect.Top\r
        JMP      @@up_down\r
@@down:\r
        MOV      EAX, [ESP].TRect.Top\r
        SUB      EAX, [ESP+16].TRect.Top\r
@@up_down:\r
        JL       @@next1\r
        MOV      EDX, [ESP].TRect.Right\r
        SUB      EDX, [ESP+16].TRect.Left\r
        JL       @@next1\r
        MOV      EDX, [ESP].TRect.Left\r
        SUB      EDX, [ESP+16].TRect.Right\r
        JL       @@chk_dist\r
\r
@@next1:\r
        ADD      ESP, 16\r
@@next:\r
        LOOP     @@loop1\r
        ADD      ESP, 16\r
        POP      EAX       // pop CollectedList\r
        CALL     TObj.Free\r
        POP      ECX       // pop Found\r
        POP      EAX       // pop Form\r
        JECXZ    @@not_found\r
\r
        POP      EDI\r
        TEST     EDI, EDI\r
        JNZ      @@no_go\r
\r
        MOV      [EAX].TControl.fCurrentControl, ECX\r
        INC      [ECX].TControl.fClickDisabled\r
        PUSH     ECX\r
        MOV      ECX, [ECX].TControl.fHandle\r
        JECXZ    @@4\r
        PUSH     ECX\r
        CALL     Windows.SetFocus\r
@@4:    POP      ECX\r
        DEC      [ECX].TControl.fClickDisabled\r
@@no_go:\r
        POPAD\r
        POP      ESI\r
        POP      EDI\r
        MOV      AL, 1      // Result = True\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;\r
label search_tabcontrol;\r
var Form: PControl;\r
    CL : PList;\r
    I : Integer;\r
    CurCtrl, Ctrl, Found : PControl;\r
    MinDist, Dist: Integer;\r
    R, R1 : TRect;\r
begin\r
  Result := False;\r
  case Key of\r
  VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit;\r
  VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit;\r
  VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit;\r
  VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then exit;\r
  else exit;\r
  end;\r
\r
  Result := True;\r
  if checkOnly then Exit;\r
\r
  Form := Self_.ParentForm;\r
  if Key = VK_TAB then\r
    if GetKeyState( VK_SHIFT ) < 0 then\r
      Tabulate2Next( Form, -1 )\r
    else\r
      Tabulate2Next( Form, 1 )\r
  else\r
  begin\r
    CL := CollectTabControls( Form );\r
    I := CL.IndexOf( Form.fCurrentControl );\r
    Found := nil;\r
    if I >= 0 then\r
    begin\r
      CurCtrl := CL.fItems[ I ];\r
      //R := CurCtrl.ControlRect;\r
      GetWindowRect( CurCtrl.Handle, R );\r
    search_tabcontrol:\r
      MinDist := MaxInt;\r
      for I := CL.fCount - 1 downto 0 do\r
      begin\r
        Ctrl := CL.fItems[ I ];\r
        if Ctrl = CurCtrl then continue;\r
        if not (Ctrl.fEnabled and Ctrl.fTabstop) then continue;\r
        //R1 := Ctrl.ControlRect;\r
        GetWindowRect( Ctrl.Handle, R1 );\r
        Dist := MaxInt;\r
        case Key of\r
          VK_LEFT:\r
            begin\r
              if (R1.Bottom < R.Top)\r
              or (R1.Top >= R.Bottom)\r
              or (R1.Left > R.Left) then continue;\r
              Dist := R.Left - R1.Left;\r
            end;\r
          VK_RIGHT:\r
            begin\r
              if (R1.Bottom < R.Top)\r
              or (R1.Top >= R.Bottom)\r
              or (R1.Left < R.Left) then continue;\r
              Dist := R1.Left - R.Left;\r
            end;\r
          VK_UP, VK_PRIOR:\r
            begin\r
              if (R1.Right < R.Left)\r
              or (R1.Left >= R.Right)\r
              or (R1.Top > R.Top) then continue;\r
              Dist := R.Top - R1.Top;\r
            end;\r
          VK_DOWN, VK_NEXT:\r
            begin\r
              if (R1.Right < R.Left)\r
              or (R1.Left >= R.Right)\r
              or (R1.Top < R.Bottom) then continue;\r
              Dist := R1.Top - R.Top;\r
            end;\r
        end;\r
        if Dist < MinDist then\r
        begin\r
          Found := Ctrl;\r
          MinDist := Dist;\r
        end;\r
      end;\r
      if Found = nil then\r
      begin\r
        case Key of\r
          VK_LEFT:\r
            begin\r
              Key := VK_UP; goto search_tabcontrol;\r
            end;\r
          VK_RIGHT:\r
            begin\r
              Key := VK_DOWN; goto search_tabcontrol;\r
            end;\r
          VK_UP, VK_PRIOR:\r
            Tabulate2Next( Form, -1 );\r
          VK_DOWN, VK_NEXT:\r
            Tabulate2Next( Form, 1 );\r
        end;\r
      end\r
         else\r
      begin\r
        if Found.fHandle <> 0 then\r
        begin\r
          Inc( Found.fClickDisabled );\r
          SetFocus( Found.fHandle );\r
          Dec( Found.fClickDisabled );\r
        end;\r
        Form.fCurrentControl := Found;\r
      end;\r
    end;\r
    CL.Free;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Tabulate2ControlEx]\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Tabulate]\r
function TControl.Tabulate: PControl;\r
asm\r
        PUSH     EAX\r
        CALL     ParentForm\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        MOV      [EAX].fGotoControl, offset[Tabulate2Control]\r
@@exit: POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Tabulate: PControl;\r
var F : PControl;\r
begin\r
  Result := @Self;\r
  F := ParentForm;\r
  if F = nil then Exit;\r
  F.fGotoControl := Tabulate2Control;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.TabulateEx]\r
function TControl.TabulateEx: PControl;\r
asm\r
        PUSH     EAX\r
        CALL     ParentForm\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        MOV      [EAX].fGotoControl, offset[Tabulate2ControlEx]\r
@@exit: POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TabulateEx: PControl;\r
var F : PControl;\r
begin\r
  Result := @Self;\r
  F := ParentForm;\r
  if F = nil then Exit;\r
  F.fGotoControl := Tabulate2ControlEx;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[procedure TControl.GotoControl]\r
procedure TControl.GotoControl(Key: DWORD);\r
var Form: PControl;\r
begin\r
  Form := ParentForm;\r
  if Form <> nil then\r
  if assigned( Form.fGotoControl ) then\r
     Form.fGotoControl( Form.fCurrentControl, Key, false );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetCurIndex]\r
function TControl.GetCurIndex: Integer;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].fCurIndex\r
        MOVZX    ECX, [EBX].fCommandActions.aGetCurrent\r
        JECXZ    @@exit\r
        XOR      EAX, EAX\r
        CDQ\r
        CMP      CX, LVM_GETNEXTITEM\r
        JNE      @@0\r
        INC      EAX\r
        INC      EAX\r
        JMP      @@1\r
@@0:\r
        CMP      CL, EM_LINEINDEX and $FF\r
        JNZ      @@2\r
@@1:\r
        DEC      EDX\r
@@2:\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     ECX\r
        PUSH     EBX\r
        CALL     Perform\r
\r
@@exit: POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetCurIndex: Integer;\r
var I, J: Integer;\r
begin\r
  Result := fCurIndex;\r
  if fCommandActions.aGetCurrent = 0 then\r
    Exit;\r
  I := 0;\r
  if fCommandActions.aGetCurrent = EM_LINEINDEX then\r
     Dec( I );\r
  J := 0;\r
  if fCommandActions.aGetCurrent = LVM_GETNEXTITEM then\r
  begin\r
     J := 2 {LVNI_SELECTED};\r
     Dec( I );\r
  end;\r
  Result := Perform( fCommandActions.aGetCurrent, I, J );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetCurIndex]\r
procedure TControl.SetCurIndex(const Value: Integer);\r
asm\r
        MOVZX    ECX, [EAX].fCommandActions.aSetCurrent\r
        JECXZ    @@set_item_sel\r
        PUSHAD\r
        PUSH     0\r
        PUSH     EDX\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     Perform\r
        POPAD\r
        CMP      CX, TCM_SETCURSEL\r
        JNE      @@exit\r
        PUSH     TCN_SELCHANGE\r
        PUSH     EAX // idfrom doesn't matter\r
        PUSH     [EAX].fHandle\r
        PUSH     ESP\r
        PUSH     0\r
        PUSH     WM_NOTIFY\r
        PUSH     EAX\r
        CALL     Perform\r
        POP      ECX\r
        POP      ECX\r
        POP      ECX\r
@@exit:\r
        RET\r
@@set_item_sel:\r
        INC      ECX\r
        CALL     SetItemSelected\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetCurIndex(const Value: Integer);\r
var NMHdr: TNMHdr;\r
begin\r
  if fCommandActions.aSetCurrent <> 0 then\r
  begin\r
     Perform( fCommandActions.aSetCurrent, Value, 0 );\r
     if fCommandActions.aSetCurrent = TCM_SETCURSEL then\r
     begin\r
       NMHdr.code := TCN_SELCHANGE;\r
       NMHdr.hwndFrom := fHandle;\r
       Perform( WM_NOTIFY, 0, Integer( @NMHdr ) );\r
     end;\r
  end\r
  else\r
     ItemSelected[ Value ] := True;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetTextAlign]\r
function TControl.GetTextAlign: TTextAlign;\r
asm\r
        PUSH     EAX\r
        CALL     UpdateWndStyles\r
        MOV      ECX, [EAX].fStyle\r
        MOV      EDX, dword ptr [EAX].fCommandActions.aTextAlignRight\r
        XOR      EAX, EAX\r
        AND      DX, CX\r
        JNZ      @@ret_1\r
        SHR      EDX, 16\r
        AND      ECX, EDX\r
        JNZ      @@ret_2\r
        POP      EAX\r
        MOVZX    EAX, [EAX].fTextAlign\r
        RET\r
\r
@@ret_2:INC      EAX\r
@@ret_1:INC      EAX\r
@@ret_0:POP      ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetTextAlign: TTextAlign;\r
begin\r
  UpdateWndStyles;\r
  if (fStyle and fCommandActions.aTextAlignRight) = fCommandActions.aTextAlignRight then\r
     Result := taRight\r
  else\r
  if (fStyle and fCommandActions.aTextAlignCenter) = fCommandActions.aTextAlignCenter then\r
     Result := taCenter\r
  else\r
     Result := fTextAlign;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetVerticalAlign]\r
function TControl.GetVerticalAlign: TVerticalAlign;\r
asm\r
        PUSH     EAX\r
        CALL     UpdateWndStyles\r
        MOV      EDX, dword ptr [EAX].fCommandActions.aVertAlignCenter\r
        MOV      ECX, [EAX].fStyle\r
        XOR      EAX, EAX\r
        MOV      DH, DL\r
        AND      DL, CH\r
        JZ       @@1\r
        CMP      DL, DH\r
        JE       @@ret_0\r
@@1:    SHR      EDX, 16\r
        MOV      DH, DL\r
        AND      DL, CH\r
        JZ       @@2\r
        CMP      DL, DH\r
        JE       @@ret_2\r
@@2:    POP      EAX\r
        MOVZX    EAX, [EAX].fVerticalAlign\r
        RET\r
@@ret_2:INC      EAX\r
@@ret_1:INC      EAX\r
@@ret_0:POP      ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetVerticalAlign: TVerticalAlign;\r
begin\r
  UpdateWndStyles;\r
  if (fStyle and (fCommandActions.aVertAlignCenter shl 8)) = (fCommandActions.aVertAlignCenter shl 8) then\r
     Result := vaCenter\r
  else\r
  if (fStyle and (fCommandActions.aVertAlignBottom shl 8)) = (fCommandActions.aVertAlignBottom shl 8) then\r
     Result := vaBottom\r
  else\r
     Result := fVerticalAlign;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetTextAlign]\r
procedure TControl.SetTextAlign(const Value: TTextAlign);\r
asm\r
        MOV      [EAX].fTextAlign, DL\r
        XOR      ECX, ECX\r
        MOV      CX, [EAX].fCommandActions.aTextAlignLeft\r
        OR       CX, [EAX].fCommandActions.aTextAlignCenter\r
        OR       CX, [EAX].fCommandActions.aTextAlignRight\r
        NOT      ECX\r
        AND      ECX, [EAX].fStyle\r
\r
        AND      EDX, 3\r
        OR       CX, [EAX + EDX * 2].fCommandActions.aTextAlignLeft\r
\r
        MOV      DL, [EAX].fCommandActions.aTextAlignMask\r
        NOT      EDX\r
        AND      EDX, ECX\r
        CALL     SetStyle\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetTextAlign(const Value: TTextAlign);\r
var NewStyle: DWORD;\r
begin\r
  fTextAlign := Value;\r
  NewStyle := 0;\r
  with fCommandActions do\r
  case Value of\r
  taLeft: NewStyle := fStyle and not DWORD(aTextAlignCenter or aTextAlignRight)\r
                          or aTextAlignLeft;\r
  taRight: NewStyle := fStyle and not DWORD(aTextAlignLeft or aTextAlignCenter)\r
                          or aTextAlignRight;\r
  taCenter: NewStyle := fStyle and not DWORD(aTextAlignLeft or aTextAlignRight)\r
                          or aTextAlignCenter;\r
  end;\r
  NewStyle := NewStyle and not DWORD(fCommandActions.aTextAlignMask);\r
  Style := NewStyle;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_noVERSION}\r
//[procedure TControl.SetVerticalAlign]\r
procedure TControl.SetVerticalAlign(const Value: TVerticalAlign);\r
asm\r
        MOV      [EAX].fVerticalAlign, DL\r
        XOR      ECX, ECX\r
        MOV      CX, word ptr [EAX].fCommandActions.aVertAlignTop\r
        OR       CH, CL\r
        MOV      CL, 0\r
        NOT      ECX\r
        AND      ECX, [EAX].fStyle\r
        AND      EDX, 3\r
        MOV      DH, [EAX + EDX].fCommandActions.aVertAlignCenter\r
        MOV      DL, 0\r
        OR       EDX, ECX\r
        CALL     SetStyle\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetVerticalAlign(const Value: TVerticalAlign);\r
var NewStyle: DWORD;\r
begin\r
  fVerticalAlign := Value;\r
  with fCommandActions do\r
  begin\r
    NewStyle := fStyle and not DWORD((aVertAlignTop or aVertAlignCenter or aVertAlignBottom) shl 8);\r
    case Value of\r
    vaCenter: NewStyle := NewStyle or (aVertAlignCenter shl 8);\r
    vaTop:    NewStyle := NewStyle or (aVertAlignTop shl 8);\r
    vaBottom: NewStyle := NewStyle or (aVertAlignBottom shl 8);\r
    end;\r
  end;\r
  Style := NewStyle;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TControl.Dc2Canvas]\r
function TControl.Dc2Canvas( Sender: PCanvas ): HDC;\r
asm\r
        MOV      ECX, [EAX].fPaintDC\r
        JECXZ    @@chk_fHandle\r
        PUSH     ECX\r
        XCHG     EAX, EDX // EAX <= Sender\r
        MOV      EDX, ECX // EDX <= fPaintDC\r
        PUSH     EAX\r
        CALL     TCanvas.SetHandle\r
        POP      EAX\r
        MOV      [EAX].TCanvas.fIsPaintDC, 1\r
        POP      ECX\r
@@ret_ECX:\r
        XCHG     EAX, ECX\r
        RET\r
@@chk_fHandle:\r
        MOV      ECX, [EDX].TCanvas.fHandle\r
        INC      ECX\r
        LOOP     @@ret_ECX\r
        CALL     GetWindowHandle\r
        PUSH     EAX\r
        CALL     GetDC\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Dc2Canvas( Sender: PCanvas ): HDC;\r
begin\r
  if fPaintDC <> 0 then\r
  begin\r
     Result := fPaintDC;\r
     Sender.SetHandle( Result );\r
     Sender.fIsPaintDC := True;\r
  end\r
    else\r
  begin\r
    if Sender.fHandle <> 0 then\r
       Result := Sender.fHandle\r
    else\r
       Result := GetDC( GetWindowHandle );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetCanvas]\r
function TControl.GetCanvas: PCanvas;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        XCHG     EBX, EAX\r
\r
        MOV      ESI, [EBX].fCanvas\r
        TEST     ESI, ESI\r
        JNZ      @@exit\r
\r
        XOR      EAX, EAX\r
        CALL     NewCanvas\r
        MOV      [EBX].fCanvas, EAX\r
        MOV      [EAX].TCanvas.fOwnerControl, EBX\r
        MOV      [EAX].TCanvas.fOnGetHandle.TMethod.Code, offset[ DC2Canvas ]\r
        MOV      [EAX].TCanvas.fOnGetHandle.TMethod.Data, EBX\r
        XCHG     ESI, EAX\r
\r
        MOV      ECX, [EBX].fFont\r
        JECXZ    @@exit\r
\r
        MOV      EAX, [ESI].TCanvas.fFont\r
        MOV      EDX, ECX\r
        CALL     TGraphicTool.Assign\r
        MOV      [ESI].TCanvas.fFont, EAX\r
\r
        MOV      ECX, [EBX].fBrush\r
        JECXZ    @@exit\r
\r
        MOV      EAX, [ESI].TCanvas.fBrush\r
        MOV      EDX, ECX\r
        CALL     TGraphicTool.Assign\r
        MOV      [ESI].TCanvas.fBrush, EAX\r
\r
@@exit: XCHG     EAX, ESI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetCanvas: PCanvas;\r
begin\r
  if not assigned( fCanvas ) then\r
  begin\r
    fCanvas := NewCanvas( 0 );\r
    fCanvas.OnGetHandle := Dc2Canvas;\r
    fCanvas.fOwnerControl := @Self;\r
    if assigned( fFont ) then\r
      fCanvas.fFont := fCanvas.fFont.Assign( fFont );\r
    if assigned( fBrush ) then\r
      fCanvas.fBrush := fCanvas.fBrush.Assign( fBrush );\r
  end;\r
  Result := fCanvas;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TControl.DblBufTopParent]\r
function TControl.DblBufTopParent: PControl;\r
var Ctl: PControl;\r
begin\r
  Result := nil;\r
  Ctl := @ Self;\r
  while Ctl <> nil do\r
  begin\r
    if Ctl.fDoubleBuffered then\r
      Result := Ctl;\r
    Ctl := Ctl.fParent;\r
  end;\r
end;\r
\r
//[procedure InvalidateDblBufParent]\r
procedure InvalidateDblBufParent( Sender: PControl );\r
var C: PControl;\r
begin\r
  C := Sender.DblBufTopParent;\r
  if C <> nil then\r
    InvalidateRect( C.fHandle, nil, TRUE );\r
end;\r
\r
//[function WndFuncPreventDraw]\r
function WndFuncPreventDraw( W: HWnd; Msg: Cardinal; wParam, lParam: Integer ): Integer; stdcall;\r
var C: PControl;\r
    PrntW: HWnd;\r
//********************************************************** Added By M.Gerasimov\r
//*\r
    PrevProc:Pointer;\r
//*\r
//********************************************************** Added By M.Gerasimov\r
begin\r
  //if not AppletTerminated then\r
  case Msg of\r
  WM_NCPAINT,\r
  //WM_PAINT,\r
  WM_ERASEBKGND:\r
    begin\r
      C := Pointer( GetProp( W, ID_SELF ) );\r
      if C = nil then\r
      begin\r
        PrntW := GetParent( W );\r
        if PrntW <> 0 then\r
        begin\r
          C := Pointer( GetProp( PrntW, ID_SELF ) );\r
          if (C <> nil) and not C.fCannotDoubleBuf and\r
             (C.DblBufTopParent <> nil) and\r
             (not C.DblBufTopParent.fDblBufPainting) then\r
          begin\r
            case Msg of\r
            WM_NCPAINT: Result := 0;\r
            WM_PAINT:   Result := 0;\r
            else Result := 1;\r
            end;\r
            Exit;\r
          end;\r
        end;\r
      end;\r
    end;\r
  end;\r
//********************************************************** By M.Gerasimov\r
//*\r
      PrevProc:=Pointer(GetProp( W, ID_PREVPROC ));\r
      if PrevProc <> Nil then\r
       Result := CallWindowProc( PrevProc , W, Msg, wParam, lParam )\r
      else\r
       Result:=0;\r
//*\r
//********************************************************** Remarked By M.Gerasimov\r
//Result := CallWindowProc( Pointer( GetProp( W, 'PREV_PROC' ) ),\r
//       W, Msg, wParam, lParam );\r
//******************************************************************************\r
end;\r
\r
//[procedure DblBufCreateWndProc]\r
procedure DblBufCreateWndProc( Sender: PControl );\r
var Chld: HWnd;\r
    PrevProc: DWORD;\r
begin\r
  Chld := GetWindow( Sender.fHandle, GW_CHILD );\r
  while Chld <> 0 do\r
  begin\r
//********************************************************** Changed By M.Gerasimov\r
//  if GetProp( Chld, 'PREV_PROC' ) = 0 then\r
//**********************************************************\r
    if GetProp( Chld, ID_PREVPROC ) = 0 then              //\r
//**********************************************************\r
    begin\r
      PrevProc :=\r
        SetWindowLong( Chld, GWL_WNDPROC, Longint( @WndFuncPreventDraw ) );\r
//********************************************************** Changed By M.Gerasimov\r
//    SetProp( Chld, 'PREV_PROC', PrevProc );\r
//**********************************************************\r
      SetProp( Chld, ID_PREVPROC, PrevProc );             //\r
//**********************************************************\r
     end;\r
    Chld := GetWindow( Chld, GW_HWNDNEXT );\r
  end;\r
end;\r
\r
//[procedure TControl.SetDoubleBuffered]\r
procedure TControl.SetDoubleBuffered(const Value: Boolean);\r
begin\r
  if CannotDoubleBuf then Exit;\r
  fDoubleBuffered := Value;\r
  Global_OnBufferedDraw := WndProcBufferedDraw;\r
  Global_Invalidate := @ InvalidateDblBufParent;\r
  Global_DblBufCreateWnd := @ DblBufCreateWndProc;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetTransparent]\r
procedure TControl.SetTransparent(const Value: Boolean);\r
asm\r
        CMP      [EAX].fTransparent, DL\r
        JZ       @@exit\r
        MOV      [EAX].fTransparent, DL\r
        TEST     DL, DL\r
        JZ       @@exit\r
        MOV      ECX, [EAX].fParent\r
        JECXZ    @@exit\r
        XCHG     EAX, ECX\r
        CALL     SetDoubleBuffered\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetTransparent(const Value: Boolean);\r
begin\r
  if fTransparent = Value then Exit;\r
  fTransparent := Value;\r
  //ExStyle := ExStyle or WS_EX_TRANSPARENT;\r
  if fParent = nil then Exit;\r
  if Value then\r
    fParent.DoubleBuffered := True;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TControl.SetBorder]\r
function TControl.SetBorder( Value: Integer ): PControl;\r
begin\r
  fMargin := Value;\r
  Result := @ Self;\r
end;\r
\r
{ TTrayIcon }\r
\r
var FTrayItems: PList;\r
\r
//[FUNCTION WndProcTray]\r
{$IFDEF ASM_noVERSION}\r
function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;\r
asm\r
        PUSH     ECX\r
        MOV      ECX, [EDX].TMsg.message\r
        CMP      CX, CM_TRAYICON\r
        JNE      @@1\r
\r
          MOV      ECX, [EDX].TMsg.lParam\r
          MOV      EDX, [EDX].TMsg.wParam\r
          MOV      EAX, [EDX].TTrayIcon.fOnMouse.TMethod.Data\r
          CMP      word ptr [EDX].TTrayIcon.fOnMouse.TMethod.Code+2, 0\r
          JE       @@no_on\r
\r
          CALL     [EDX].TTrayIcon.fOnMouse.TMethod.Code\r
@@no_on:\r
          POP      ECX\r
          XOR      EAX, EAX\r
          MOV      [ECX], EAX\r
          INC      EAX\r
          RET\r
\r
@@1:\r
        SUB      ECX, WM_CLOSE\r
        JNE      @@exit_0\r
@@2:\r
\r
          POP      ECX\r
          PUSH     EBX\r
          XCHG     EBX, EAX\r
\r
          MOV      EAX, [EBX].TControl.fHandle\r
          CMP      EAX, [EDX].TMsg.hwnd\r
          JNE      @@otherwin\r
\r
          MOV      EDX, [FTrayItems]\r
          MOV      ECX, [EDX].TList.fCount\r
          MOV      EDX, [EDX].TList.fItems\r
@@loop:\r
          MOV      EAX, [EDX + ECX*4 - 4]\r
          CMP      [EAX].TTray.FNoAutoDeactivate, 0\r
          JNZ      @@3\r
          CMP      [EAX].TTrayIcon.fControl, EBX\r
          JNE      @@3\r
          PUSHAD\r
          XOR      EDX, EDX\r
          CALL     TTrayIcon.SetActive\r
          POPAD\r
@@3:      LOOP     @@loop\r
\r
@@otherwin:\r
          POP      EBX\r
          PUSH     ECX\r
\r
@@exit_0:\r
        XOR      EAX, EAX\r
        POP      ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;\r
var Self_: PTrayIcon;\r
    I : Integer;\r
begin\r
  Result := False;\r
  case Msg.message of\r
  CM_TRAYICON:\r
    begin\r
      Self_ := Pointer( Msg.wParam );\r
      if Assigned( Self_.FOnMouse ) then\r
         Self_.FOnMouse( @Self_, Msg.lParam );\r
      Rslt := 0;\r
      Result := True;\r
    end;\r
  WM_CLOSE:\r
    if Msg.hwnd = Control.fHandle then\r
    begin\r
      if FTrayItems <> nil then // ?????????????????\r
      for I := FTrayItems.Count - 1 downto 0 do\r
      begin\r
        Self_ := FTrayItems.Items[ I ];\r
        if not Self_.FNoAutoDeactivate then\r
        if Self_.FControl = Control then\r
           Self_.Active := False;\r
      end;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcTray]\r
\r
//[FUNCTION _NewTrayIcon]\r
{$IFDEF ASM_VERSION}\r
function _NewTrayIcon: PTrayIcon;\r
begin\r
  New(Result,Create);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _NewTrayIcon]\r
\r
function WndProcTrayIconWnd( Wnd: HWnd; Msg: DWORD; wParam, lParam: Integer ): Integer;\r
         stdcall;\r
var PrevProc: function ( Wnd: HWnd; Msg: DWORD;\r
                         wParam, lParam: Integer ): Integer; stdcall;\r
var Tr: PTrayIcon;\r
begin\r
  PrevProc := Pointer( GetProp( Wnd, 'TRAYSAVEPROC' ) );\r
  if Msg = CM_TRAYICON then\r
  begin\r
    Tr := Pointer( wParam );\r
    if Assigned( Tr.FOnMouse ) then\r
       Tr.FOnMouse( Tr, lParam );\r
    Result := 0;\r
    Exit;\r
  end\r
    else\r
  if Msg = WM_CLOSE then\r
  begin\r
    if Assigned( PrevProc ) then\r
    begin\r
      SetWindowLong( Wnd, GWL_WNDPROC, Integer( @ PrevProc ) );\r
      RemoveProp( Wnd, 'TRAYSAVEPROC' );\r
      PostMessage( Wnd, WM_CLOSE, wParam, lParam );\r
      Result := 0;\r
      Exit;\r
      //Wnd := 0;\r
    end;\r
  end;\r
  if (Wnd <> 0) and IsWindow( Wnd ) and Assigned( PrevProc ) then\r
    Result := PrevProc( Wnd, Msg, wParam, lParam )\r
  else\r
    Result := DefWindowProc( Wnd, Msg, wParam, lParam );\r
end;\r
\r
//[PROCEDURE TTrayIcon.AttachProc2Wnd]\r
procedure TTrayIcon.AttachProc2Wnd;\r
begin\r
  if FWnd = 0 then Exit;\r
  if GetProp( FWnd, 'TRAYSAVEPROC' ) <> 0 then Exit; // already attached\r
  SetProp( FWnd, 'TRAYSAVEPROC', GetWindowLong( FWnd, GWL_WNDPROC ) );\r
  SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ WndProcTrayIconWnd ) );\r
end;\r
// [END TTrayIcon.AttachProc2Wnd]\r
\r
// [PROCEDURE TTrayIcon.DetachProc2Wnd]\r
procedure TTrayIcon.DetachProc2Wnd;\r
var OldProc: function ( Wnd: HWnd; Msg: DWORD;\r
             wParam, lParam: Integer ): Integer; stdcall;\r
begin\r
  if FWnd = 0 then Exit;\r
  OldProc := Pointer( GetProp( FWnd, 'TRAYSAVEPROC' ) );\r
  if not Assigned( OldProc ) then Exit; // not attached\r
  SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ OldProc ) );\r
  RemoveProp( FWnd, 'TRAYSAVEPROC' );\r
end;\r
// [END TTrayIcon.DetachProc2Wnd]\r
\r
//[FUNCTION NewTrayIcon]\r
{$IFDEF ASM_VERSION}\r
function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon;\r
asm\r
        PUSH     EBX\r
        PUSH     EDX // push Icon\r
        PUSH     EAX // push Wnd\r
        CALL     _NewTrayIcon\r
        XCHG     EBX, EAX\r
\r
        MOV      EAX, [FTrayItems]\r
        TEST     EAX, EAX\r
        JNZ      @@1\r
        CALL     NewList\r
        MOV      [FTrayItems], EAX\r
@@1:\r
        MOV      EDX, EBX\r
        CALL     TList.Add\r
\r
        POP      EAX //Wnd\r
        MOV      [EBX].TTrayIcon.fControl, EAX\r
        POP      [EBX].TTrayIcon.fIcon //Icon\r
\r
        MOV      EDX, offset[WndProcTray]\r
        TEST     EAX, EAX\r
        JZ       @@2\r
        CALL     TControl.AttachProc\r
@@2:\r
        MOV      DL, 1\r
        MOV      EAX, EBX\r
        CALL     TTrayIcon.SetActive\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon;\r
begin\r
  if FTrayItems = nil then\r
     FTrayItems := NewList;\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PTrayIcon.Create;*){--}\r
  FTrayItems.Add( Result );\r
  if Wnd <> nil then\r
    Wnd.AttachProc( WndProcTray );\r
  Result.FControl := Wnd;\r
  Result.FIcon := Icon;\r
  Result.Active := True;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewTrayIcon]\r
\r
var fRecreateMsg: DWORD;\r
\r
//[FUNCTION WndProcRecreateTrayIcons]\r
{$IFDEF ASM_VERSION}\r
function WndProcRecreateTrayIcons( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm     //cmd    //opd\r
        MOV      ECX, [fRecreateMsg]\r
        CMP      word ptr [EDX].TMsg.message, CX\r
        JNE      @@ret_false\r
        PUSH     ESI\r
        MOV      ESI, [FTrayItems]\r
        MOV      ECX, [ESI].TList.fCount\r
        MOV      ESI, [ESI].TList.fItems\r
        //JECXZ    @@e_loo\r
@@loo:  PUSH     ECX\r
        LODSD\r
        MOV      DL, [EAX].TTrayIcon.fAutoRecreate\r
        AND      DL, [EAX].TTrayIcon.fActive\r
        JZ       @@nx\r
        DEC      [EAX].TTrayIcon.fActive\r
        CALL     TTrayIcon.SetActive\r
@@nx:   POP      ECX\r
        LOOP     @@loo\r
@@e_loo:POP      ESI\r
@@ret_false:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcRecreateTrayIcons( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var I: Integer;\r
    TI: PTrayIcon;\r
begin\r
  if Msg.message = fRecreateMsg then\r
  begin\r
    for I := 0 to FTrayItems.fCount - 1 do\r
    begin\r
      TI := FTrayItems.Items[ I ];\r
      if TI.fAutoRecreate then\r
      if TI.fActive then\r
      begin\r
        TI.fActive := False;\r
        TI.Active := True;\r
      end;\r
    end;\r
  end;\r
  Result := False;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcRecreateTrayIcons]\r
\r
const\r
  TaskbarCreatedMsg: array[ 0..14 ] of Char = ('T','a','s','k','b','a','r',\r
                     'C','r','e','a','t','e','d',#0);\r
{$IFDEF ASM_VERSION}\r
//[procedure TTrayIcon.SetAutoRecreate]\r
procedure TTrayIcon.SetAutoRecreate(const Value: Boolean);\r
asm     //cmd    //opd\r
        MOV      [EAX].fAutoRecreate, DL\r
        MOV      EAX, [EAX].FControl\r
        CALL     TControl.ParentForm\r
        MOV      EDX, offset[WndProcRecreateTrayIcons]\r
        CALL     TControl.AttachProc\r
        PUSH     offset[TaskbarCreatedMsg]\r
        CALL     RegisterWindowMessage\r
        MOV      [fRecreateMsg], EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TTrayIcon.SetAutoRecreate(const Value: Boolean);\r
begin\r
  fAutoRecreate := Value;\r
  FControl.ParentForm.AttachProc( WndProcRecreateTrayIcons );\r
  fRecreateMsg := RegisterWindowMessage( TaskbarCreatedMsg );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TTrayIcon.Destroy]\r
destructor TTrayIcon.Destroy;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, EAX\r
        XOR      EDX, EDX\r
        CALL     SetActive\r
\r
        MOV      ECX, [EBX].fIcon\r
        JECXZ    @@icon_destroyed\r
        PUSH     ECX\r
        CALL     DestroyIcon\r
@@icon_destroyed:\r
\r
        MOV      EDX, EBX\r
        MOV      ESI, [FTrayItems]\r
        MOV      EAX, ESI\r
        CALL     TList.IndexOf\r
        TEST     EAX, EAX\r
        JL       @@fin\r
          XCHG     EDX, EAX\r
          MOV      EAX, ESI\r
          CALL     TList.Delete\r
          MOV      EAX, [ESI].TList.fCount\r
          TEST     EAX, EAX\r
          JNZ      @@fin\r
          XCHG     EAX, [FTrayItems]\r
          CALL     TObj.Free\r
@@fin:  LEA      EAX, [EBX].FTooltip\r
        CALL     System.@LStrClr\r
        XCHG     EAX, EBX\r
        CALL     TObj.Destroy\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TTrayIcon.Destroy;\r
begin\r
  Active := False;\r
\r
  if fIcon <> 0 then\r
    DestroyIcon( fIcon );\r
\r
  FTrayItems.Remove( @ Self );\r
  if FTrayItems.Count = 0 then\r
    Free_And_Nil( FTrayItems );\r
  FTooltip := '';\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TTrayIcon.SetActive]\r
procedure TTrayIcon.SetActive(const Value: Boolean);\r
asm\r
        CMP      [EAX].fActive, DL\r
        JE       @@exit\r
        MOV      ECX, [EAX].fIcon\r
        JECXZ    @@exit\r
        PUSH     EDX\r
        PUSH     EAX\r
          MOV      ECX, [EAX].FWnd\r
          INC      ECX\r
          LOOP     @@1\r
          MOV      ECX, [EAX].fControl\r
          XOR      EAX, EAX\r
          JECXZ    @@1\r
          XCHG     EAX, ECX\r
          CALL     TControl.GetWindowHandle\r
@@1:\r
        POP      ECX\r
        POP      EDX\r
        XCHG     EAX, ECX\r
        JECXZ    @@exit\r
        MOV      [EAX].fActive, DL\r
        MOVZX    EDX, DL\r
        XOR      DL, 1\r
        ADD      EDX, EDX\r
        CALL     SetTrayIcon\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TTrayIcon.SetActive(const Value: Boolean);\r
begin\r
  if FActive = Value then Exit;\r
  if FIcon = 0 then Exit;\r
  if (Wnd = 0) and ((FControl = nil) or (FControl.GetWindowHandle = 0)) then Exit;\r
  FActive := Value;\r
  if Value then\r
     SetTrayIcon( NIM_ADD )\r
  else\r
     SetTrayIcon( NIM_DELETE );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TTrayIcon.SetIcon]\r
procedure TTrayIcon.SetIcon(const Value: HIcon);\r
asm\r
        MOV      ECX, [EAX].fIcon\r
        CMP      ECX, EDX\r
        JE       @@exit\r
        MOV      [EAX].fIcon, EDX\r
        XOR      EDX, EDX\r
        JECXZ    @@nim_add\r
        INC      EDX      // NIM_MODIFY = 1\r
@@nim_add:\r
        MOVZX    ECX, [EAX].fActive\r
        JECXZ    @@exit\r
        CALL     SetTrayIcon\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TTrayIcon.SetIcon(const Value: HIcon);\r
var Cmd : DWORD;\r
begin\r
  if FIcon = Value then Exit;\r
  // Previous icon is not destroying. This is normal for\r
  // icons, loaded from resources using LoadIcon. For icons,\r
  // created using CreateIconIndirect, You have to call\r
  // DestroyIcon manually.\r
  Cmd := NIM_MODIFY;\r
  if FIcon = 0 then\r
     Cmd := NIM_ADD;\r
  FIcon := Value;\r
  if FActive then\r
     SetTrayIcon( Cmd );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TTrayIcon.SetTooltip]\r
procedure TTrayIcon.SetTooltip(const Value: String);\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].fTooltip\r
        PUSH     EDX\r
        CALL     System.@LStrCmp\r
        POP      EDX\r
        JE       @@exit\r
        LEA      EAX, [EBX].fTooltip\r
        CALL     System.@LStrAsg\r
        CMP      [EBX].fActive, 0\r
        JE       @@exit\r
        XOR      EDX, EDX\r
        INC      EDX     // EDX = NIM_MODIFY\r
        XCHG     EAX, EBX\r
        CALL     SetTrayIcon\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TTrayIcon.SetTooltip(const Value: String);\r
begin\r
  if FTooltip = Value then Exit;\r
  FTooltip := Value;\r
  if Active then\r
     SetTrayIcon( NIM_MODIFY );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TTrayIcon.SetTrayIcon]\r
procedure TTrayIcon.SetTrayIcon(const Value: DWORD);\r
const sz_tid = sizeof( TNotifyIconData );\r
asm\r
        //MOV      ECX, [EAX].fIcon\r
        //JECXZ    @@exit\r
\r
        CMP      [AppletTerminated], 0\r
        JE       @@1\r
        MOV      DL, NIM_DELETE\r
@@1:\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      ESI, EAX\r
        MOV      EBX, EDX\r
\r
        XOR      ECX, ECX\r
        PUSH     ECX\r
        ADD      ESP, -60\r
        MOV      EDX, [ESI].fToolTip\r
        CALL     EDX2PChar\r
        MOV      EAX, ESP\r
        MOV      CL, 63\r
        CALL     StrLCopy\r
\r
        PUSH     [ESI].fIcon\r
        PUSH     CM_TRAYICON\r
        XOR      EDX, EDX\r
        CMP      BL, NIM_DELETE\r
        JE       @@2\r
        MOV      DL, NIF_ICON or NIF_MESSAGE or NIF_TIP\r
@@2:    PUSH     EDX\r
        PUSH     ESI\r
        MOV      EAX, [ESI].FWnd\r
        TEST     EAX, EAX\r
        JNZ      @@3\r
        MOV      EAX, [ESI].fControl\r
        MOV      EAX, [EAX].TControl.fHandle\r
@@3:\r
        PUSH     EAX\r
        PUSH     sz_tid\r
\r
        PUSH     ESP\r
        PUSH     EBX\r
        CALL     Shell_NotifyIcon\r
\r
        ADD      ESP, sz_tid\r
        POP      ESI\r
        POP      EBX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TTrayIcon.SetTrayIcon(const Value: DWORD);\r
var NID : TNotifyIconData;\r
    L : Integer;\r
    V : DWORD;\r
begin\r
  //if FIcon = 0 then Exit; - already tested\r
  V := Value;\r
  if AppletTerminated then\r
    V := NIM_DELETE;\r
  if Wnd <> 0 then\r
    NID.Wnd := Wnd\r
  else\r
    NID.Wnd := FControl.fHandle;\r
\r
  NID.cbSize := Sizeof( NID );\r
  NID.uID := DWORD( @Self );\r
  NID.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;\r
  if V = NIM_DELETE then\r
     NID.uFlags := 0;\r
  NID.uCallbackMessage := CM_TRAYICON;\r
  NID.hIcon := FIcon;\r
  L := Length( FToolTip );\r
  if L > 63 then L := 63;\r
  Move( FTooltip[1], NID.szTip[0], Min( 63, L ) );\r
  NID.szTip[ L ] := #0;\r
\r
  Shell_NotifyIcon( V, @NID );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{ -- JustOne -- }\r
\r
var JustOneMutex: THandle;\r
\r
//[FUNCTION WndProcJustOne]\r
{$IFDEF ASM_VERSION}\r
function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;\r
asm\r
        MOV      ECX, [EDX].TMsg.message\r
        SUB      ECX, WM_CLOSE\r
        JE       @@1\r
        SUB      ECX, WM_NCDESTROY - WM_CLOSE\r
        JNE      @@exit\r
@@1:\r
        XCHG     ECX, [JustOneMutex]\r
        JECXZ    @@exit\r
        PUSH     ECX\r
        PUSH     ECX\r
        CALL     ReleaseMutex\r
        CALL     CloseHandle\r
\r
@@exit:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;\r
begin\r
  Result := False;\r
  case Msg.message of\r
  WM_CLOSE, WM_NCDESTROY:\r
      if LongBool( JustOneMutex ) then\r
      begin\r
        ReleaseMutex( JustOneMutex );\r
        CloseHandle( JustOneMutex );\r
        JustOneMutex := 0;\r
      end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcJustOne]\r
\r
//[FUNCTION JustOne]\r
{$IFDEF ASM_VERSION}\r
function JustOne( Wnd: PControl; const Identifier : String ) : Boolean;\r
const JOcs: PChar = 'KOL.Just1.CrtSec';\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        XOR      ESI, ESI\r
        PUSH     EDI\r
        XCHG     EBX, EAX\r
\r
        CALL     EDX2PChar\r
        PUSH     EDX\r
\r
        PUSH     [JOcs]\r
        PUSH     1\r
        PUSH     ESI\r
        MOV      EDI, offset[CreateMutex]\r
        CALL     EDI\r
\r
        POP      EDX\r
        TEST     EAX, EAX\r
        JZ       @@exit     //\r
        PUSH     EAX\r
        PUSH     EAX\r
\r
        PUSH     EDX\r
        PUSH     ESI\r
        PUSH     ESI\r
        CALL     EDI\r
        MOV      [JustOneMutex], EAX\r
        TEST     EAX, EAX\r
        JE       @@1        //\r
\r
        PUSH     ESI\r
        PUSH     EAX\r
        CALL     WaitForSingleObject\r
        SUB      EAX, WAIT_TIMEOUT\r
        JE       @@1\r
\r
        INC      ESI\r
@@1:\r
        //MOV      [EBX].TControl.fWndProcJustOne, offset[WndProcJustOne]\r
        XCHG     EAX, EBX\r
        MOV      EDX, offset[WndProcJustOne]\r
        CALL     TControl.AttachProc\r
\r
        CALL     ReleaseMutex\r
        CALL     CloseHandle\r
\r
@@exit:\r
        XCHG     EAX, ESI\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function JustOne( Wnd: PControl; const Identifier : String ) : Boolean;\r
var CritSecMutex : THandle;\r
    DW : Longint;\r
begin\r
   Result := False;\r
   CritSecMutex := CreateMutex( nil, True, PChar( 'KOL.Just1.CrtSec' ) );\r
   if CritSecMutex = 0 then Exit;\r
\r
   JustOneMutex := CreateMutex( nil, False, PChar( Identifier ) );\r
   if JustOneMutex <> 0 then\r
   begin\r
     DW := WaitForSingleObject( JustOneMutex, 0 );\r
     Result := (DW <> WAIT_TIMEOUT);\r
   end;\r
\r
   //Wnd.fWndProcJustOne := WndProcJustOne;\r
   Wnd.AttachProc( WndProcJustOne );\r
\r
   ReleaseMutex( CritSecMutex );\r
   CloseHandle( CritSecMutex );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END JustOne]\r
\r
{ JustOneNotify }\r
\r
var\r
  OnAnotherInstance: TOnAnotherInstance;\r
  JustOneMsg: DWORD;\r
\r
//[FUNCTION WndProcJustOneNotify]\r
{$IFDEF ASM_VERSION}\r
function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;\r
asm\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
        PUSHAD\r
        CALL     WndProcJustOne\r
        POPAD\r
        XOR      EAX, EAX\r
        PUSH     ECX\r
          MOV      ECX, [EDX].TMsg.message\r
          SUB      ECX, [JustOneMsg]\r
        POP      ECX\r
        JNE      @@exit\r
        MOV      [ECX], EAX\r
        CMP      [OnAnotherInstance].TMethod.Code, EAX\r
        JE       @@exit_1\r
\r
        //MOV      EAX, (MAX_PATH + 3) and 0FFFFCh\r
        MOV      AH, 2\r
        SUB      ESP, EAX\r
\r
        MOV      ECX, ESP\r
        PUSH     EAX\r
        PUSH     ECX\r
        PUSH     [EDX].TMsg.lParam\r
        CALL     GetWindowText\r
\r
        MOV      EDX, ESP\r
        PUSH     0\r
        MOV      EAX, ESP\r
        CALL     System.@LStrFromPChar\r
\r
        MOV      EDX, [ESP]\r
        MOV      EAX, [OnAnotherInstance].TMethod.Data\r
        CALL     [OnAnotherInstance].TMethod.Code\r
\r
        MOV      EAX, ESP\r
        CALL     System.@LStrClr\r
@@exit_1:\r
        MOV      AL, 1\r
@@exit:\r
        MOV      ESP, EBP\r
        POP      EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;\r
var Buf : array[0..MAX_PATH] of Char;\r
begin\r
  WndProcJustOne( Control, Msg, Rslt );\r
  Result := False;\r
  if Msg.message = JustOneMsg then\r
  begin\r
    Result := True;\r
    if assigned( OnAnotherInstance ) then\r
    begin\r
      GetWindowText( Msg.lParam, Buf, MAX_PATH );\r
      OnAnotherInstance( Buf );\r
    end;\r
    Rslt := 0;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcJustOneNotify]\r
\r
// Redefine here incorrectly declared BroadcastSystemMessage API function.\r
// It should not refer to BroadcastSystemMessageA, which is not present in\r
// earlier versions of Windows95, but to BroadcastSystemMessage, which is\r
// present in all Windows95/98/Me and NT/2K/XP.\r
//[API BroadcastSystemMessage]\r
function BroadcastSystemMessage(Flags: DWORD; Recipients: PDWORD;\r
  uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall;\r
external user32 name 'BroadcastSystemMessage';\r
\r
//[FUNCTION JustOneNotify]\r
{$IFDEF ASM_VERSION}\r
function JustOneNotify( Wnd: PControl; const Identifier : String;\r
                        const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;\r
asm\r
        PUSHAD\r
        MOV      EBP, ESP\r
\r
        XCHG     EAX, EDX\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        POP      EDX\r
        ADD      EAX, EAX\r
        SUB      ESP, EAX\r
        MOV      EAX, ESP\r
        CALL     StrPCopy\r
        PUSH     '.ega'\r
        PUSH     'sseM'\r
        PUSH     ESP\r
        CALL     RegisterWindowMessage\r
        MOV      [JustOneMsg], EAX\r
        TEST     EAX, EAX\r
\r
        MOV      ESP, EBP\r
        POPAD\r
        JE       @@exit_f\r
\r
        PUSHAD\r
        CALL     JustOne\r
        DEC      AL\r
        POPAD\r
        JZ       @@exit_t\r
\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        XOR      EDX, EDX\r
        XCHG     [EBX].TControl.fCaption, EDX\r
        PUSH     EDX\r
\r
        CALL     GetCommandLine\r
        XCHG     EDX, EAX\r
        MOV      EAX, EBX\r
        CALL     TControl.SetCaption\r
        MOV      EAX, EBX\r
        CALL     TControl.GetWindowHandle\r
        TEST     EAX, EAX\r
        JZ       @@rest_cap\r
\r
        PUSH     BSM_APPLICATIONS\r
        MOV      EDX, ESP\r
\r
        PUSH     EAX\r
        PUSH     0\r
        PUSH     [JustOneMsg]\r
        PUSH     EDX\r
        PUSH     BSF_QUERY or BSF_IGNORECURRENTTASK\r
        CALL     BroadcastSystemMessage\r
\r
        POP      EDX\r
@@rest_cap:\r
        XOR      EDX, EDX\r
        MOV      EAX, EBX\r
        CALL     TControl.SetCaption\r
        POP      EDX\r
        MOV      [EBX].TControl.fCaption, EDX\r
        PUSH     EDX\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     SetWindowText\r
        POP      EBX\r
@@exit_f:\r
        XOR      EAX, EAX\r
          POP      EBP  // because compiler inserts PUSH EBP;MOV EBP,ESP at the BEGIN\r
        RET\r
\r
@@exit_t:\r
        PUSHAD\r
        LEA      ESI, [aOnAnotherInstance]\r
        LEA      EDI, [OnAnotherInstance]\r
        MOVSD\r
        MOVSD\r
        //MOV      [EAX].TControl.fWndProcJustOne, offset[WndProcJustOneNotify]\r
        MOV      EDX, offset[WndProcJustOneNotify]\r
        CALL     TControl.AttachProc\r
\r
        POPAD\r
        MOV      AL, 1\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function JustOneNotify( Wnd: PControl; const Identifier : String;\r
                        const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;\r
var Recipients : DWord;\r
    OldCap: String;\r
begin\r
   Result := False;\r
   JustOneMsg := RegisterWindowMessage( PChar( 'Message.' + Identifier ) );\r
   if JustOneMsg = 0 then Exit;\r
\r
   Result := JustOne( Wnd, Identifier );\r
   if not Result then\r
   begin\r
      // Send a message to the first instance of applet\r
\r
      //Wnd.CreateVisible := False;\r
      OldCap := Wnd.Caption;\r
      Wnd.Caption := GetCommandLine;\r
      if Wnd.GetWindowHandle <> 0 then\r
      begin\r
         Recipients := BSM_APPLICATIONS;\r
         BroadcastSystemMessage( BSF_QUERY or BSF_IGNORECURRENTTASK, @Recipients,\r
                                 JustOneMsg, 0, Wnd.fHandle );\r
      end;\r
      Wnd.Caption := OldCap;\r
   end\r
      else\r
   begin\r
      // Store event handler to notify this instance about another\r
      // instance staring:\r
      OnAnotherInstance := aOnAnotherInstance;\r
      //Wnd.fWndProcJustOne := WndProcJustOneNotify;\r
      Wnd.AttachProc( WndProcJustOneNotify );\r
\r
      {\r
      if JustOneNotifier = nil then\r
         JustOneNotifier := ZJustOneNotifier.Create;\r
      }\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END JustOneNotify]\r
\r
\r
///////////////////////////////////////// STRING LIST OBJECT /////////////////\r
\r
{ TStrList }\r
\r
//[function NewStrList]\r
function NewStrList: PStrList;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}\r
  {++}(*\r
  Result := PStrList.Create;\r
  *){--}\r
end;\r
//[END NewStrList]\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TStrList.Destroy]\r
destructor TStrList.Destroy;\r
asm\r
        PUSH     EAX\r
        CALL     Clear\r
        POP      EAX\r
        CALL     TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TStrList.Destroy;\r
begin\r
  Clear;\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TStrList.Init]\r
procedure TStrList.Init;\r
begin\r
  //inherited;\r
  fNameDelim := DefaultNameDelimiter;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStrList.Add]\r
function TStrList.Add(const S: string): integer;\r
asm\r
        MOV      ECX, EDX\r
        MOV      EDX, [EAX].fCount\r
        PUSH     EDX\r
        CALL     Insert\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStrList.Add(const S: string): integer;\r
begin\r
  Result := fCount;\r
  Insert( Result, S );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.AddStrings]\r
procedure TStrList.AddStrings(Strings: PStrList);\r
asm\r
        PUSH     EAX\r
        XCHG     EAX, EDX\r
        PUSH     0\r
        MOV      EDX, ESP\r
        CALL     GetTextStr\r
        POP      EDX\r
        POP      EAX\r
        MOV      CL, 1\r
        PUSH     EDX\r
        CALL     SetText\r
        CALL     RemoveStr\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.AddStrings(Strings: PStrList);\r
begin\r
  SetText( Strings.Text, True );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStrList.AppendToFile]\r
function TStrList.AppendToFile(const FileName: string): Boolean;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EDX\r
        PUSH     0\r
        MOV      EDX, ESP\r
        CALL     GetTextStr\r
        XCHG     EAX, EBX\r
        MOV      EDX, ofOpenWrite or ofOpenAlways\r
        CALL     FileCreate\r
        MOV      EBX, EAX\r
        INC      EAX\r
        JZ       @@exit\r
        DEC      EAX\r
        XOR      EDX, EDX\r
        XOR      ECX, ECX\r
        MOV      CL, spEnd\r
        CALL     FileSeek\r
        POP      EAX\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        XCHG     ECX, EAX\r
        MOV      EAX, EBX\r
        POP      EDX\r
        PUSH     EDX\r
        CALL     FileWrite\r
        XCHG     EAX, EBX\r
        CALL     FileClose\r
@@exit:\r
        CALL     RemoveStr\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStrList.AppendToFile(const FileName: string): Boolean;\r
var F: HFile;\r
    Buf: String;\r
    L: Integer;\r
begin\r
  F := FileCreate( FileName, ofOpenWrite or ofOpenAlways );\r
  Result := F <> INVALID_HANDLE_VALUE;\r
  if Result then\r
  begin\r
    FileSeek( F, 0, spEnd );\r
    Buf := Text;\r
    L := Length( Buf );\r
    FileWrite( F, Buf[ 1 ], L );\r
    FileClose( F );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.Assign]\r
procedure TStrList.Assign(Strings: PStrList);\r
asm\r
        PUSHAD\r
        CALL     Clear\r
        POPAD\r
        JMP      AddStrings\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.Assign(Strings: PStrList);\r
begin\r
  Clear;\r
  AddStrings( Strings );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.Clear]\r
procedure TStrList.Clear;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EDX, [EBX].fCount\r
@@loo:  DEC      EDX\r
        JL       @@eloo\r
        PUSH     EDX\r
        MOV      EAX, EBX\r
        CALL     Delete\r
        POP      EDX\r
        JMP      @@loo\r
@@eloo:\r
        XOR      EAX, EAX\r
        MOV      [EBX].fTextSiz, EAX\r
        XCHG     EAX, [EBX].fTextBuf\r
        TEST     EAX, EAX\r
        JZ       @@1\r
        CALL     System.@FreeMem\r
        //XOR      EAX, EAX // not needed: if OK, EAX = 0\r
@@1:    XCHG     EAX, [EBX].fList\r
        CALL     TObj.Free\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.Clear;\r
var I: Integer;\r
begin\r
  if fCount > 0 then\r
  for I := fList.Count - 1 downto 0 do\r
    Delete( I );\r
  fList.Free;\r
  fList := nil;\r
  fCount := 0;\r
  if fTextBuf <> nil then\r
  begin\r
    FreeMem( fTextBuf );\r
    fTextBuf := nil;\r
    fTextSiz := 0;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.Delete]\r
procedure TStrList.Delete(Idx: integer);\r
asm\r
        DEC      [EAX].fCount\r
        PUSH     EAX\r
        MOV      EAX, [EAX].fList\r
        MOV      ECX, [EAX].TList.fItems\r
        PUSH     dword ptr [ECX+EDX*4]\r
        CALL     TList.Delete\r
        POP      EAX\r
        POP      EDX\r
        MOV      ECX, [EDX].fTextSiz\r
        JECXZ    @@fremem\r
        CMP      EAX, [EDX].fTextBuf\r
        JB       @@fremem\r
        ADD      ECX, [EDX].fTextBuf\r
        CMP      EAX, ECX\r
        JB       @@exit\r
@@fremem:\r
        CALL     System.@FreeMem\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.Delete(Idx: integer);\r
var P: DWORD;\r
    El:Pointer;\r
begin\r
  P := DWORD( fList.fItems[ Idx ] );\r
  if (fTextBuf <> nil) and ( P >= DWORD( fTextBuf )) and\r
     ( P < DWORD( fTextBuf ) + fTextSiz ) then\r
  else\r
  begin\r
    El := FList.Items[ Idx ];\r
    FreeMem( El );\r
  end;\r
  fList.Delete( Idx );\r
  Dec( fCount );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStrList.Get]\r
function TStrList.Get(Idx: integer): string;\r
asm\r
        PUSH     ECX\r
        MOV      EAX, [EAX].fList\r
        TEST     EAX, EAX\r
        JZ       @@1\r
        CALL     TList.Get\r
@@1:    XCHG     EDX, EAX\r
        POP      EAX\r
        JMP      System.@LStrFromPChar\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStrList.Get(Idx: integer): string;\r
begin\r
  if fList <> nil then\r
    Result := PChar( fList.Items[ Idx ] )\r
  else Result := '';\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStrList.GetPChars]\r
function TStrList.GetPChars(Idx: Integer): PChar;\r
asm\r
        MOV      EAX, [EAX].fList\r
        MOV      EAX, [EAX].TList.fItems\r
        MOV      EAX, [EAX+EDX*4]\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStrList.GetPChars(Idx: Integer): PChar;\r
begin\r
  Result := PChar( fList.fItems[ Idx ] );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStrList.GetTextStr]\r
function TStrList.GetTextStr: string;\r
asm\r
        PUSH     ESI\r
        PUSH     EDI\r
        MOV      ECX, [EAX].fCount\r
        MOV      EAX, [EAX].fList\r
        PUSH     ECX\r
        JECXZ    @@1\r
        MOV      ESI, [EAX].TList.fItems\r
@@1:    PUSH     ESI\r
        XCHG     EAX, EDX\r
        XOR      EDX, EDX\r
        JECXZ    @@10\r
        PUSH     EAX\r
@@loo1:\r
        PUSH     ECX\r
        PUSH     EDX\r
        LODSD\r
        CALL     StrLen\r
        POP      EDX\r
        LEA      EDX, [EDX+EAX+2]\r
        POP      ECX\r
        LOOP     @@loo1\r
\r
        POP      EAX\r
        POP      ESI\r
        XCHG     ECX, EDX\r
        PUSH     EAX\r
@@10:\r
        {$IFDEF _D2}\r
        CALL     _LStrFromPCharLen\r
        {$ELSE}\r
        CALL     System.@LStrFromPCharLen\r
        {$ENDIF}\r
\r
        POP      EDI\r
        POP      ECX\r
        JECXZ    @@exit\r
        MOV      EDI, [EDI]\r
\r
@@loo2: PUSH     ECX\r
        LODSD\r
        PUSH     EAX\r
        CALL     StrLen\r
        XCHG     ECX, EAX\r
        POP      EAX\r
        XCHG     EAX, ESI\r
        REP      MOVSB\r
        XCHG     ESI, EAX\r
        MOV      AX, $0A0D\r
        STOSW\r
        POP      ECX\r
        LOOP     @@loo2\r
\r
        XCHG     EAX, ECX\r
        STOSB\r
@@exit:\r
        POP      EDI\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStrList.GetTextStr: string;\r
var\r
   I, Len, Size: integer;\r
   P: PChar;\r
begin\r
     Size := 0;\r
\r
     for I := 0 to fCount - 1 do\r
       Inc(Size, StrLen( PChar(fList.fItems[I]) ) + 2);\r
\r
     SetString(Result, nil, Size);\r
\r
     P := Pointer(Result);\r
     for I := 0 to Count - 1 do\r
     begin\r
       Len := StrLen(PChar(fList.fItems[I]));\r
       if (Len > 0) then\r
       begin\r
         System.Move(PChar(fList.fItems[I])^, P^, Len);\r
         Inc(P, Len);\r
       end;\r
       P^ := #13;\r
       Inc(P);\r
       P^ := #10;\r
       Inc(P);\r
     end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStrList.IndexOf]\r
function TStrList.IndexOf(const S: string): integer;\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        OR       EBX, -1\r
        MOV      ECX, [EAX].fCount\r
        JECXZ    @@exit\r
        MOV      ESI, [EAX].fList\r
        MOV      ESI, [ESI].TList.fItems\r
@@loo:  LODSD\r
        INC      EBX\r
        CMP      EAX, EDX\r
        JE       @@exit\r
        OR       EDX, EDX\r
        JZ       @@1\r
        PUSH     EDX\r
        PUSH     ECX\r
        CALL     StrComp\r
        POP      ECX\r
        POP      EDX\r
        JE       @@exit\r
@@1:    LOOP     @@loo\r
        OR       EBX, -1\r
@@exit: XCHG     EAX, EBX\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStrList.IndexOf(const S: string): integer;\r
begin\r
  for Result := 0 to fCount - 1 do\r
    if (S = PChar( fList.Items[Result] )) then Exit;\r
  Result := -1;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TStrList.IndexOf]\r
function TStrList.IndexOf_NoCase(const S: string): integer;\r
begin\r
  for Result := 0 to fCount - 1 do\r
    if StrComp_NoCase( PChar( S ), PChar( fList.Items[Result] ) ) = 0 then Exit;\r
  Result := -1;\r
end;\r
\r
function TStrList.IndexOfStrL_NoCase( Str: PChar; L: Integer ): integer;\r
begin\r
  for Result := 0 to fCount - 1 do\r
    if (StrLen( PChar( fList.fItems[ Result ] ) ) = DWORD( L )) and\r
       (StrLComp_NoCase( Str, PChar( fList.fItems[ Result ] ), L ) = 0) then Exit;\r
  Result := -1;\r
end;\r
\r
//[function TStrList.Find]\r
function TStrList.Find(const S: String; var Index: Integer): Boolean;\r
var\r
  L, H, I, C: Integer;\r
begin\r
  Result := FALSE;\r
  L := 0;\r
  H := FCount - 1;\r
  while L <= H do\r
  begin\r
    I := (L + H) shr 1;\r
    C := AnsiCompareStr( PChar( fList.Items[ I ] ), S );\r
    if C < 0 then L := I + 1 else\r
    begin\r
      H := I - 1;\r
      if C = 0 then\r
      begin\r
        Result := TRUE;\r
        L := I;\r
        //break;\r
        //if Duplicates <> dupAccept then L := I;\r
      end;\r
    end;\r
  end;\r
  Index := L;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.Insert]\r
procedure TStrList.Insert(Idx: integer; const S: string);\r
asm\r
        PUSH     EBX\r
        PUSH     EDX\r
        PUSH     ECX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].fList\r
        TEST     EAX, EAX\r
        JNZ      @@1\r
        CALL     NewList\r
        MOV      [EBX].fList, EAX\r
@@1:\r
        POP      EAX\r
        PUSH     EAX          // push S\r
        CALL     System.@LStrLen\r
        INC      EAX\r
        PUSH     EAX          // push L\r
        CALL     System.@GetMem\r
        MOV      byte ptr[EAX], 0\r
        XCHG     EDX, EAX\r
        POP      ECX\r
        POP      EAX\r
        PUSH     EDX          // push Mem\r
        TEST     EAX, EAX\r
        JE       @@2\r
        CALL     System.Move\r
@@2:    POP      ECX\r
        POP      EDX\r
        MOV      EAX, [EBX].fList\r
        CALL     TList.Insert\r
        INC      [EBX].fCount\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.Insert(Idx: integer; const S: string);\r
var Mem: PChar;\r
    L: Integer;\r
begin\r
  if fList = nil then\r
     fList := NewList;\r
  L := Length( S ) + 1;\r
  GetMem( Mem, L );\r
  Mem[0] := #0;\r
  if L > 1 then\r
     System.Move( S[1], Mem[0], L );\r
  fList.Insert( Idx, Mem );\r
  Inc( fCount );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStrList.LoadFromFile]\r
function TStrList.LoadFromFile(const FileName: string): Boolean;\r
asm\r
      PUSH     EAX\r
        XCHG     EAX, EDX\r
        MOV      EDX, ofOpenRead or ofShareDenyWrite or ofOpenExisting\r
        CALL     FileCreate\r
        INC      EAX\r
        JZ       @@exit\r
        DEC      EAX\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        PUSH     0\r
        PUSH     EBX\r
        CALL     GetFileSize\r
        XOR      EDX, EDX\r
        PUSH     EDX\r
        XCHG     ECX, EAX\r
        MOV      EAX, ESP\r
        PUSH     ECX\r
        {$IFDEF _D2}\r
        CALL     _LStrFromPCharLen\r
        {$ELSE}\r
        CALL     System.@LStrFromPCharLen\r
        {$ENDIF}\r
        POP      ECX\r
        MOV      EAX, EBX\r
        POP      EDX\r
        PUSH     EDX\r
        CALL     FileRead\r
        XCHG     EAX, EBX\r
        CALL     FileClose\r
        POP      EDX\r
        POP      EBX\r
      POP      EAX\r
        PUSH     EDX\r
        XOR      ECX, ECX\r
        CALL     SetText\r
        CALL     RemoveStr\r
        PUSH     EDX\r
        MOV      AL, 1\r
@@exit: POP      EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStrList.LoadFromFile(const FileName: string): Boolean;\r
var Buf: String;\r
    F: HFile;\r
    Sz: Integer;\r
begin\r
  F := FileCreate( FileName, ofOpenRead or ofShareDenyWrite or ofOpenExisting );\r
  Result := F <> INVALID_HANDLE_VALUE;\r
  if Result then\r
  begin\r
    Sz := GetFileSize( F, nil );\r
    SetString( Buf, nil, Sz );\r
    FileRead( F, Buf[1], Sz );\r
    FileClose( F );\r
\r
    SetText( Buf, False );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.LoadFromStream]\r
procedure TStrList.LoadFromStream(Stream: PStream; Append2List: boolean);\r
asm\r
        PUSH     EAX\r
        PUSH     ECX\r
        PUSH     EBX\r
        XCHG     EAX, EDX\r
        MOV      EBX, EAX\r
        CALL     TStream.GetSize\r
        PUSH     EAX\r
        MOV      EAX, EBX\r
        CALL     TStream.GetPosition\r
        POP      ECX\r
        SUB      ECX, EAX\r
        XOR      EDX, EDX\r
        PUSH     EDX\r
        MOV      EAX, ESP\r
        PUSH     ECX\r
        {$IFDEF _D2}\r
        CALL     _LStrFromPCharLen\r
        {$ELSE}\r
        CALL     System.@LStrFromPCharLen\r
        {$ENDIF}\r
        POP      ECX\r
        POP      EDX\r
        XCHG     EAX, EBX\r
        PUSH     EDX\r
        CALL     TStream.Read\r
        POP      EDX\r
        POP      EBX\r
        POP      ECX\r
        POP      EAX\r
        PUSH     EDX\r
        CALL     SetText\r
        CALL     RemoveStr\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.LoadFromStream(Stream: PStream; Append2List: boolean);\r
var Buf: String;\r
    Sz: Integer;\r
begin\r
  Sz := Stream.Size - Stream.Position;\r
  SetString( Buf, nil, Sz );\r
  Stream.Read( Buf[1], Sz );\r
  SetText( Buf, Append2List );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.MergeFromFile]\r
procedure TStrList.MergeFromFile(const FileName: string);\r
asm\r
        PUSH     EAX\r
        XCHG     EAX, EDX\r
        CALL     NewReadFileStream\r
        XCHG     EDX, EAX\r
        POP      EAX\r
        MOV      CL, 1\r
        PUSH     EDX\r
        CALL     LoadFromStream\r
        POP      EAX\r
        JMP      TObj.Free\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.MergeFromFile(const FileName: string);\r
var TmpStream: PStream;\r
begin\r
  TmpStream := NewReadFileStream( FileName );\r
  LoadFromStream( TmpStream, True );\r
  TmpStream.Free;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TStrList.Move]\r
procedure TStrList.Move(CurIndex, NewIndex: integer);\r
begin\r
  fList.MoveItem( CurIndex, NewIndex );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.Put]\r
procedure TStrList.Put(Idx: integer; const Value: string);\r
asm\r
        PUSH     EAX\r
        PUSH     EDX\r
        CALL     Insert\r
        POP      EDX\r
        POP      EAX\r
        INC      EDX\r
        JMP      Delete\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.Put(Idx: integer; const Value: string);\r
begin\r
  Delete( Idx );\r
  Insert( Idx, Value );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TStrList.SaveToFile]\r
function TStrList.SaveToFile(const FileName: string): Boolean;\r
asm\r
        PUSH     EBX\r
        PUSH     EAX\r
        XCHG     EAX, EDX\r
        MOV      EDX, ofOpenWrite or ofOpenAlways\r
        CALL     FileCreate\r
        INC      EAX\r
        JZ       @@exit\r
        DEC      EAX\r
        XCHG     EBX, EAX\r
        POP      EAX\r
        PUSH     0\r
        MOV      EDX, ESP\r
        CALL     GetTextStr\r
        POP      EAX\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        XCHG     ECX, EAX\r
        POP      EDX\r
        PUSH     EDX\r
        MOV      EAX, EBX\r
        CALL     FileWrite\r
        PUSH     EBX\r
        CALL     SetEndOfFile\r
        XCHG     EAX, EBX\r
        CALL     FileClose\r
        CALL     RemoveStr\r
        PUSH     EDX\r
        INC      EAX\r
@@exit:\r
        POP      EDX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TStrList.SaveToFile(const FileName: string): Boolean;\r
var F: HFile;\r
    Buf: String;\r
begin\r
  F := FileCreate( FileName, ofOpenWrite or ofOpenAlways );\r
  Result := F <> INVALID_HANDLE_VALUE;\r
  if Result then\r
  begin\r
    Buf := Text;\r
    FileWrite( F, Buf[ 1 ], Length( Buf ) );\r
    SetEndOfFile( F ); // necessary! - V.K.\r
    FileClose( F );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.SaveToStream]\r
procedure TStrList.SaveToStream(Stream: PStream);\r
asm\r
        PUSH     EDX\r
        PUSH     0\r
        MOV      EDX, ESP\r
        CALL     GetTextStr\r
        POP      EAX\r
        PUSH     EAX\r
        CALL     System.@LStrLen\r
        XCHG     ECX, EAX\r
        POP      EDX\r
        POP      EAX\r
        PUSH     EDX\r
        JECXZ    @@1\r
        CALL     TStream.Write\r
@@1:\r
        CALL     RemoveStr\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.SaveToStream(Stream: PStream);\r
var S: string;\r
    L: Integer;\r
begin\r
   S := GetTextStr;\r
   L := Length( S );\r
   if L <> 0 then\r
   Stream.Write( S[1], L );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.SetText]\r
procedure TStrList.SetText(const S: string; Append2List: boolean);\r
asm\r
        DEC      CL\r
        JZ       @@1\r
        PUSHAD\r
        CALL     Clear\r
        POPAD\r
@@1:    CALL     EDX2PChar\r
        JZ       @@exit\r
\r
        PUSH     EBX\r
        PUSH     EDI\r
        MOV      EBX, EAX\r
        MOV      EDI, [EBX].fTextSiz\r
\r
        MOV      EAX, [EDX-4] // EAX = Length(S)\r
        INC      EAX\r
        PUSH     EAX\r
\r
        // add S to text buffer\r
        //CMP      byte ptr [EDX], 0\r
        //JZ       @@eatb\r
\r
        PUSH     EDX\r
        PUSH     [EBX].fTextBuf\r
        ADD      EAX, [EBX].fTextSiz\r
        CALL     System.@GetMem\r
        MOV      [EBX].fTextBuf, EAX\r
\r
        MOV      ECX, EDI\r
        XCHG     EDX, EAX\r
        POP      EAX\r
        JECXZ    @@atb_fin\r
        PUSH     EAX\r
        CALL     System.Move\r
\r
        POP      EDX\r
        PUSH     EDX\r
\r
        PUSH     ESI\r
        MOV      ESI, [EBX].fList\r
        MOV      ESI, [ESI].TList.fItems\r
        MOV      ECX, [EBX].fCount\r
\r
@@atb_loo:\r
        LODSD\r
        SUB      EAX, EDX\r
        CMP      EAX, [EBX].fTextSiz\r
        JAE      @@atb_nxt\r
\r
        ADD      EAX, [EBX].fTextBuf\r
        MOV      [ESI-4], EAX\r
\r
@@atb_nxt: LOOP  @@atb_loo\r
\r
        POP      ESI\r
        POP      EAX\r
        CALL     System.@FreeMem\r
@@atb_fin:\r
        POP      EAX\r
\r
        MOV      EDX, EDI\r
        ADD      EDX, [EBX].fTextBuf\r
        POP      ECX\r
        PUSH     ECX\r
        ADD      [EBX].fTextSiz, ECX\r
\r
        CALL     System.Move\r
\r
@@eatb:\r
        ADD      EDI, [EBX].fTextBuf // EDI ~ P\r
\r
        MOV      ECX, [EBX].fList\r
        INC      ECX\r
        LOOP     @@2\r
        CALL     NewList\r
        MOV      [EBX].fList, EAX\r
@@2:\r
        POP      ECX\r
        MOV      EDX, [EBX].fCount\r
\r
        PUSH     EDI\r
        PUSH     ECX\r
        MOV      AL, $0D\r
\r
@@loo1: CMP      byte ptr [EDI], 0\r
        JZ       @@eloo1\r
\r
        INC      EDX\r
        REPNZ    SCASB\r
        JNZ      @@eloo1\r
\r
        CMP      byte ptr [EDI], $0A\r
        JNZ      @@loo1\r
        INC      EDI\r
        LOOP     @@loo1\r
\r
@@eloo1:\r
        MOV      [EBX].fCount, EDX\r
        MOV      EAX, [EBX].fList\r
        PUSH     EDX\r
        PUSH     EAX\r
        CMP      EDX, [EAX].TList.fCapacity\r
        JLE      @@3\r
        CALL     TList.SetCapacity\r
@@3:    POP      EAX\r
        POP      ECX\r
\r
        XCHG     ECX, [EAX].TList.fCount\r
        MOV      EDX, [EAX].TList.fItems\r
        LEA      EDX, [EDX+ECX*4]\r
\r
        POP      ECX\r
        POP      EDI\r
\r
        MOV      EAX, $0D\r
@@loo2: CMP      byte ptr [EDI], AH\r
        JZ       @@eloo2\r
\r
        MOV      [EDX], EDI\r
        ADD      EDX, 4\r
\r
        REPNZ    SCASB\r
        JNZ      @@eloo2\r
\r
        MOV      [EDI-1], AH\r
\r
        CMP      byte ptr [EDI], $0A\r
        JNZ      @@loo2\r
        INC      EDI\r
        LOOP     @@loo2\r
@@eloo2:\r
\r
        POP      EDI\r
        POP      EBX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
//[procedure TStrList.SetText]\r
procedure TStrList.SetText(const S: string; Append2List: boolean);\r
var\r
  P, TheLast : PChar;\r
  L, I : Integer;\r
\r
  procedure AddTextBuf(Src: PChar; Len: DWORD);\r
  var OldTextBuf, P: PChar;\r
      I : Integer;\r
  begin\r
    if Src <> nil then\r
    begin\r
      OldTextBuf := fTextBuf;\r
      GetMem( fTextBuf, fTextSiz + Len );\r
      if fTextSiz <> 0 then\r
      begin\r
        System.Move( OldTextBuf^, fTextBuf^, fTextSiz );\r
        for I := 0 to fCount - 1 do\r
        begin\r
          P := fList.fItems[ I ];\r
          if (DWORD( P ) >= DWORD( OldTextBuf )) and\r
             (DWORD( P ) < DWORD( OldTextBuf ) + fTextSiz) then\r
            fList.fItems[ I ] := Pointer( DWORD( P ) - DWORD( OldTextBuf ) + DWORD( fTextBuf ) );\r
        end;\r
        FreeMem( OldTextBuf );\r
      end;\r
      System.Move( Src^, fTextBuf[ fTextSiz ], Len );\r
      Inc( fTextSiz, Len );\r
    end;\r
  end;\r
\r
begin\r
     if not Append2List then Clear;\r
     if S = '' then Exit;\r
\r
     L := fTextSiz;\r
     AddTextBuf( PChar( S ), Length( S ) + 1 );\r
\r
     P := PChar( DWORD( fTextBuf ) + DWORD( L ) );\r
     if fList = nil then\r
       fList := NewList;\r
\r
     I := 0;\r
     TheLast := P + Length( S );\r
     while P^ <> #0 do\r
     begin\r
       Inc( I );\r
       P := StrScanLen( P, #13, TheLast - P );\r
       if P^ = #10 then\r
         Inc( P );\r
     end;\r
\r
     Inc( fCount, I );\r
     if fList.fCapacity < fCount  then\r
        fList.Capacity := fCount;\r
\r
     P := PChar( DWORD( fTextBuf ) + DWORD( L ) );\r
     while P^ <> #0 do\r
     begin\r
       fList.Add( P );\r
       P := StrScanLen( P, #13, TheLast - P );\r
       if PChar( P - 1 )^ = #13 then\r
         PChar( P - 1 )^ := #0;\r
       if P^ = #10 then Inc(P);\r
     end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TStrList.SetUnixText]\r
procedure TStrList.SetUnixText(const S: String; Append2List: Boolean);\r
var S1: String;\r
begin\r
  S1 := S;\r
  NormalizeUnixText( S1 );\r
  SetText( S1, Append2List );\r
end;\r
\r
//[procedure TStrList.SetTextStr]\r
procedure TStrList.SetTextStr(const Value: string);\r
begin\r
  SetText( Value, False );\r
end;\r
\r
//[PROCEDURE LowerCaseStrFromPCharEDX]\r
{$IFDEF ASM_VERSION}\r
procedure LowerCaseStrFromPCharEDX;\r
asm\r
          { <- EDX = PChar string\r
            -> [ESP] = LowerCase( PChar( EDX ) ),\r
               EAX, EDX, ECX - ?\r
          }\r
        POP      EAX\r
        PUSH     0\r
        PUSH     EAX\r
        LEA      EAX, [ESP+4]\r
        PUSH     EAX\r
        CALL     System.@LStrFromPChar\r
        POP      EDX\r
        MOV      EAX, [EDX]\r
        JMP      LowerCase\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END LowerCaseStrFromPCharEDX]\r
\r
//[FUNCTION CompareStrListItems]\r
{$IFDEF ASM_VERSION}\r
function CompareStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;\r
asm\r
        CMP      [EAX].TStrList.fCaseSensitiveSort, 0\r
        MOV      EAX, [EAX].TStrList.fList\r
        MOV      EAX, [EAX].TList.fItems\r
        MOV      EDX, [EAX+EDX*4]\r
        MOV      EAX, [EAX+ECX*4]\r
        XCHG     EAX, EDX\r
        JNZ      StrComp\r
        PUSH     EBX\r
\r
        XCHG     EBX, EAX\r
        CALL     LowerCaseStrFromPCharEDX\r
\r
        MOV      EDX, EBX\r
        CALL     LowerCaseStrFromPCharEDX\r
\r
        POP      EAX\r
        POP      EDX\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     EAX2PChar\r
        CALL     EDX2PChar\r
        CALL     StrComp\r
        XCHG     EBX, EAX\r
\r
        CALL     RemoveStr\r
        CALL     RemoveStr\r
\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CompareStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;\r
var S1, S2 : PChar;\r
begin\r
  S1 := PStrList( Sender ).fList.Items[ e1 ];\r
  S2 := PStrList( Sender ).fList.Items[ e2 ];\r
  if PStrList( Sender ).fCaseSensitiveSort then\r
    Result := StrComp( S1, S2 )\r
  else\r
    Result := StrComp( PChar( LowerCase( S1 ) ), PChar( LowerCase( S2 ) ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CompareStrListItems]\r
\r
//[FUNCTION CompareAnsiStrListItems]\r
{$IFDEF ASM_VERSION}\r
function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;\r
asm\r
        CMP      byte ptr [EAX].TStrList.fCaseSensitiveSort, 0\r
        MOV      EAX, [EAX].TStrList.fList\r
        MOV      EAX, [EAX].TList.fItems\r
        MOV      EDX, [EAX+EDX*4]\r
        MOV      EAX, [EAX+ECX*4]\r
        XCHG     EAX, EDX\r
        JZ       _AnsiCompareStrNoCase\r
        JMP      _AnsiCompareStr\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;\r
var S1, S2 : PChar;\r
begin\r
  S1 := PStrList( Sender ).fList.Items[ e1 ];\r
  S2 := PStrList( Sender ).fList.Items[ e2 ];\r
  if PStrList( Sender ).fCaseSensitiveSort then\r
    Result := _AnsiCompareStr( S1, S2 )\r
  else\r
    Result := _AnsiCompareStrNoCase( S1, S2 );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CompareAnsiStrListItems]\r
\r
{$IFNDEF ASM_VERSION}\r
//[procedure SwapStrListItems]\r
procedure SwapStrListItems( const Sender: Pointer; const e1, e2: DWORD );\r
begin\r
  PStrList( Sender ).Swap( e1, e2 );\r
end;\r
{$ENDIF}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.Sort]\r
procedure TStrList.Sort(CaseSensitive: Boolean);\r
asm\r
        MOV      [EAX].fCaseSensitiveSort, DL\r
        PUSH     Offset[TStrList.Swap]\r
        MOV      ECX, Offset[CompareStrListItems]\r
        MOV      EDX, [EAX].fCount\r
        CALL     SortData\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.Sort(CaseSensitive: Boolean);\r
begin\r
  fCaseSensitiveSort := CaseSensitive;\r
  SortData( @Self, fCount, @CompareStrListItems, @SwapStrListItems );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TStrList.AnsiSort]\r
procedure TStrList.AnsiSort(CaseSensitive: Boolean);\r
asm\r
        MOV      [EAX].fCaseSensitiveSort, DL\r
        PUSH     Offset[TStrList.Swap]\r
        MOV      ECX, Offset[CompareAnsiStrListItems]\r
        MOV      EDX, [EAX].fCount\r
        CALL     SortData\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TStrList.AnsiSort(CaseSensitive: Boolean);\r
begin\r
  fCaseSensitiveSort := CaseSensitive;\r
  SortData( @Self, fCount, @CompareAnsiStrListItems, @SwapStrListItems );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TStrList.Swap]\r
procedure TStrList.Swap(Idx1, Idx2: Integer);\r
begin\r
  fList.Swap( Idx1, Idx2 );\r
end;\r
\r
//[function TStrList.Last]\r
function TStrList.Last: String;\r
begin\r
  if Count = 0 then\r
    Result := ''\r
  else\r
    Result := Items[ Count - 1 ];\r
end;\r
\r
//-- code by Dod:\r
//[function TStrList.IndexOfName]\r
function TStrList.IndexOfName(Name: string): Integer;\r
var\r
  i: Integer;\r
  L: Integer;\r
begin\r
  Result:=-1;\r
  // Do not start search if empty string\r
  L := Length( Name );\r
  if L > 0 then\r
  begin\r
    Name := LowerCase( Name ) + fNameDelim;\r
    Inc( L );\r
    for i := 0 to fCount - 1 do\r
    begin\r
      // For optimization, check only list entry that begin with same letter as searched name\r
      if StrLComp( PChar( LowerCase( ItemPtrs[ i ] ) ), PChar( Name ), L ) = 0 then\r
      begin\r
        Result:=i;\r
        exit;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//-- code by Dod:\r
//[function TStrList.GetValue]\r
function TStrList.GetValue(const Name: string): string;\r
var\r
  i: Integer;\r
begin\r
  I := IndexOfName(Name);\r
  if I >= 0\r
  then Result := Copy(Items[i], Length(Name) + 2, Length(Items[i])-Length(Name)-1)\r
  else Result := '';\r
end;\r
\r
//-- code by Dod:\r
//[procedure TStrList.SetValue]\r
procedure TStrList.SetValue(const Name, Value: string);\r
var\r
  I: Integer;\r
begin\r
  I := IndexOfName(Name);\r
  if i=-1\r
  then Add( Name + fNameDelim + Value )\r
  else Items[i] := Name + fNameDelim + Value;\r
end;\r
\r
//[function TStrList.GetLineName]\r
function TStrList.GetLineName(Idx: Integer): string;\r
begin\r
  Result := Items[ Idx ];\r
  Result := Parse( Result, fNameDelim );\r
end;\r
\r
//[procedure TStrList.SetLineName]\r
procedure TStrList.SetLineName(Idx: Integer; const NV: string);\r
begin\r
  Items[ Idx ] := NV + fNameDelim + LineValue[ Idx ];\r
end;\r
\r
//[function TStrList.GetLineValue]\r
function TStrList.GetLineValue(Idx: Integer): string;\r
begin\r
  Result := Items[ Idx ];\r
  Parse( Result, fNameDelim );\r
end;\r
\r
//[procedure TStrList.SetLineValue]\r
procedure TStrList.SetLineValue(Idx: Integer; const Value: string);\r
begin\r
  Items[ Idx ] := LineName[ Idx ] + fNameDelim + Value;\r
end;\r
\r
////////////////////////////////// EXTENDED STRING LIST OBJECT ////////////////\r
\r
{ TStrListEx }\r
\r
//[function NewStrListEx]\r
function NewStrListEx: PStrListEx;\r
begin\r
  {-}\r
  new( Result, Create );\r
  {+}\r
  {++}(*\r
  Result := PStrListEx.Create;\r
  *){--}\r
end;\r
//[END NewStrListEx]\r
\r
//[destructor TStrListEx.Destroy]\r
destructor TStrListEx.Destroy;\r
var Obj: PList;\r
begin\r
  Obj := FObjects;\r
  inherited;\r
  Obj.Free;\r
end;\r
\r
//[function TStrListEx.GetObjects]\r
function TStrListEx.GetObjects(Idx: Integer): DWORD;\r
begin\r
  Result := DWORD( FObjects.Items[ Idx ] );\r
end;\r
\r
//[procedure TStrListEx.SetObjects]\r
procedure TStrListEx.SetObjects(Idx: Integer; const Value: DWORD);\r
begin\r
  ProvideObjCapacity( Idx + 1 );\r
  FObjects.Items[ Idx ] := Pointer( Value );\r
end;\r
\r
//[procedure TStrListEx.Init]\r
procedure TStrListEx.Init;\r
begin\r
  FObjects := NewList;\r
end;\r
\r
//[procedure SwapStrListExItems]\r
procedure SwapStrListExItems( const Sender: Pointer; const e1, e2: DWORD );\r
begin\r
  PStrListEx( Sender ).Swap( e1, e2 );\r
end;\r
\r
//[procedure TStrListEx.AnsiSort]\r
procedure TStrListEx.AnsiSort(CaseSensitive: Boolean);\r
begin\r
  fCaseSensitiveSort := CaseSensitive;\r
  SortData( @Self, fCount, @CompareAnsiStrListItems, @SwapStrListExItems );\r
end;\r
\r
//[procedure TStrListEx.Sort]\r
procedure TStrListEx.Sort(CaseSensitive: Boolean);\r
begin\r
  fCaseSensitiveSort := CaseSensitive;\r
  SortData( @Self, fCount, @CompareStrListItems, @SwapStrListExItems );\r
end;\r
\r
//[procedure TStrListEx.Move]\r
procedure TStrListEx.Move(CurIndex, NewIndex: integer);\r
begin\r
  // move string\r
  fList.MoveItem( CurIndex, NewIndex );\r
  // move object\r
  if FObjects.fCount >= Min( CurIndex, NewIndex ) then\r
  begin\r
    ProvideObjCapacity( max( CurIndex, NewIndex ) + 1 );\r
    FObjects.MoveItem( CurIndex, NewIndex );\r
  end;\r
end;\r
\r
//[procedure TStrListEx.Swap]\r
procedure TStrListEx.Swap(Idx1, Idx2: Integer);\r
begin\r
  // swap strings\r
  fList.Swap( Idx1, Idx2 );\r
  // swap objects\r
  if FObjects.fCount >= Min( Idx1, Idx2 ) then\r
  begin\r
    ProvideObjCapacity( max( Idx1, Idx2 ) + 1 );\r
    FObjects.Swap( Idx1, Idx2 );\r
  end;\r
end;\r
\r
//[procedure TStrListEx.ProvideObjCapacity]\r
procedure TStrListEx.ProvideObjCapacity(NewCap: Integer);\r
begin\r
  if FObjects.FCount < NewCap then\r
  begin\r
    FObjects.Capacity := NewCap;\r
    FillChar( FObjects.FItems[ FObjects.FCount ],\r
              (FObjects.Capacity - FObjects.Count) * sizeof( Pointer ), 0 );\r
    FObjects.FCount := NewCap;\r
  end;\r
end;\r
\r
//[procedure TStrListEx.AddStrings]\r
procedure TStrListEx.AddStrings(Strings: PStrListEx);\r
var I: Integer;\r
begin\r
  I := Count;\r
  if Strings.FObjects.fCount > 0 then\r
    ProvideObjCapacity( Count );\r
  inherited AddStrings( Strings );\r
  if Strings.FObjects.fCount > 0 then\r
  begin\r
    ProvideObjCapacity( I + Strings.FObjects.fCount );\r
    System.Move( Strings.FObjects.FItems[ 0 ],\r
                 FObjects.FItems[ I ],\r
                 Sizeof( Pointer ) * Strings.FObjects.fCount );\r
  end;\r
end;\r
\r
//[procedure TStrListEx.Assign]\r
procedure TStrListEx.Assign(Strings: PStrListEx);\r
begin\r
  inherited Assign( Strings );\r
  FObjects.Assign( Strings.FObjects );\r
end;\r
\r
//[procedure TStrListEx.Clear]\r
procedure TStrListEx.Clear;\r
begin\r
  inherited;\r
  FObjects.Clear;\r
end;\r
\r
//[procedure TStrListEx.Delete]\r
procedure TStrListEx.Delete(Idx: integer);\r
begin\r
  inherited;\r
  if FObjects.fCount > Idx then // mdw: '>=' -> '>'\r
    FObjects.Delete( Idx );\r
end;\r
\r
//[function TStrListEx.LastObj]\r
function TStrListEx.LastObj: DWORD;\r
begin\r
  if Count = 0 then\r
    Result := 0\r
  else\r
    Result := Objects[ Count - 1 ];\r
end;\r
\r
//[function TStrListEx.AddObject]\r
function TStrListEx.AddObject(const S: String; Obj: DWORD): Integer;\r
begin\r
  Result := Count;\r
  InsertObject( Count, S, Obj );\r
end;\r
\r
//[procedure TStrListEx.InsertObject]\r
procedure TStrListEx.InsertObject(Before: Integer; const S: String; Obj: DWORD);\r
begin\r
  Insert( Before, S );\r
  FObjects.Insert( Before, Pointer( Obj ) );\r
end;\r
\r
//[function TStrListEx.IndexOfObj]\r
function TStrListEx.IndexOfObj( Obj: Pointer ): Integer;\r
begin\r
  Result := FObjects.IndexOf( Obj );\r
end;\r
\r
{-}\r
//[function WStrLen]\r
function WStrLen( W: PWideChar ): Integer;\r
asm\r
         XCHG     EDI, EAX\r
         XCHG     EDX, EAX\r
         OR       ECX, -1\r
         XOR      EAX, EAX\r
         CMP      EAX, EDI\r
         JE       @@exit0\r
         REPNE    SCASW\r
         DEC      EAX\r
         DEC      EAX\r
         SUB      EAX, ECX\r
@@exit0:\r
         MOV      EDI, EDX\r
end;\r
\r
//[procedure WStrCopy]\r
procedure WStrCopy( Dest, Src: PWideChar );\r
asm\r
        PUSH    EDI\r
        PUSH    ESI\r
        MOV     ESI,EAX\r
        MOV     EDI,EDX\r
        OR      ECX, -1\r
        XOR     EAX, EAX\r
        REPNE   SCASW\r
        NOT     ECX\r
        MOV     EDI,ESI\r
        MOV     ESI,EDX\r
        REP     MOVSW\r
        POP     ESI\r
        POP     EDI\r
end;\r
\r
//[function WStrCmp]\r
function WStrCmp( W1, W2: PWideChar ): Integer;\r
asm\r
         PUSH     ESI\r
         PUSH     EDI\r
         XCHG     ESI, EAX\r
         MOV      EDI, EDX\r
         XOR      EAX, EAX\r
         CWDE\r
@@loop:  LODSW\r
         MOV      DX, [EDI]\r
         INC      EDI\r
         INC      EDI\r
         CMP      EAX, EDX\r
         JNE      @@exit\r
         TEST     EAX, EAX\r
         JNZ      @@loop\r
@@exit:  SUB      EAX, EDX\r
         POP      EDI\r
         POP      ESI\r
end;\r
\r
{$IFNDEF _D2}\r
\r
//[function NewWStrList]\r
function NewWStrList: PWStrList;\r
begin\r
  new( Result, Create );\r
end;\r
\r
{ TWStrList }\r
\r
//[function TWStrList.Add]\r
function TWStrList.Add(const W: WideString): Integer;\r
begin\r
  Result := Count;\r
  Insert( Result, W );\r
end;\r
\r
//[procedure TWStrList.AddWStrings]\r
procedure TWStrList.AddWStrings(WL: PWStrList);\r
begin\r
  Text := Text + WL.Text;\r
end;\r
\r
//[function TWStrList.AppendToFile]\r
function TWStrList.AppendToFile(const Filename: String): Boolean;\r
var Strm: PStream;\r
begin\r
  Strm := NewReadWriteFileStream( Filename );\r
  Result := Strm.Handle <> INVALID_HANDLE_VALUE;\r
  if Result then\r
  begin\r
    Strm.Position := Strm.Size;\r
    SaveToStream( Strm );\r
  end;\r
  Strm.Free;\r
end;\r
\r
//[procedure TWStrList.Assign]\r
procedure TWStrList.Assign(WL: PWStrList);\r
begin\r
  Text := WL.Text;\r
end;\r
\r
//[procedure TWStrList.Clear]\r
procedure TWStrList.Clear;\r
var I: Integer;\r
    P: Pointer;\r
begin\r
  for I := 0 to Count-1 do\r
  begin\r
    P := fList.Items[ I ];\r
    if P <> nil then\r
    if not( (P >= fText) and (P <= fText + fTextBufSz) ) then\r
      FreeMem( P );\r
  end;\r
  if fText <> nil then\r
    FreeMem( fText );\r
  fText := nil;\r
  fTextBufSz := 0;\r
  fList.Clear;\r
end;\r
\r
//[procedure TWStrList.Delete]\r
procedure TWStrList.Delete(Idx: Integer);\r
var P: Pointer;\r
begin\r
  P := fList.Items[ Idx ];\r
  if P <> nil then\r
  if not( (P >= fText) and (P <= fText + fTextBufSz) ) then\r
    FreeMem( P );\r
  fList.Delete( Idx );\r
end;\r
\r
//[destructor TWStrList.Destroy]\r
destructor TWStrList.Destroy;\r
begin\r
  Clear;\r
  fList.Free;\r
  inherited;\r
end;\r
\r
//[function TWStrList.GetCount]\r
function TWStrList.GetCount: Integer;\r
begin\r
  Result := fList.Count;\r
end;\r
\r
//[function TWStrList.GetItems]\r
function TWStrList.GetItems(Idx: Integer): WideString;\r
begin\r
  Result := PWideChar( fList.Items[ Idx ] );\r
end;\r
\r
//[function TWStrList.GetPtrs]\r
function TWStrList.GetPtrs(Idx: Integer): PWideChar;\r
begin\r
  Result := fList.Items[ Idx ];\r
end;\r
\r
//[function TWStrList.GetText]\r
function TWStrList.GetText: WideString;\r
const\r
    EoL: array[ 0..5 ] of Char = ( #13, #0, #10, #0, #0, #0 );\r
var L, I: Integer;\r
    P, Dest: Pointer;\r
begin\r
  L := 0;\r
  for I := 0 to Count-1 do\r
  begin\r
    P := fList.Items[ I ];\r
    if P <> nil then\r
      L := L + WStrLen( P ) + 2\r
    else\r
      L := L + 2;\r
  end;\r
  SetLength( Result, L );\r
  Dest := PWideChar( Result );\r
  for I := 0 to Count-1 do\r
  begin\r
    P := fList.Items[ I ];\r
    if P <> nil then\r
    begin\r
      WStrCopy( Dest, P );\r
      Dest := Pointer( Integer( Dest ) + WStrLen( P ) * 2 );\r
    end;\r
    WStrCopy( Dest, Pointer( @ EoL[ 0 ] ) );\r
    Dest := Pointer( Integer( Dest ) + 4 );\r
  end;\r
end;\r
\r
//[procedure TWStrList.Init]\r
procedure TWStrList.Init;\r
begin\r
  fList := NewList;\r
end;\r
\r
//[procedure TWStrList.Insert]\r
procedure TWStrList.Insert(Idx: Integer; const W: WideString);\r
var P: Pointer;\r
begin\r
  while Idx < Count-2 do\r
    fList.Add( nil );\r
  GetMem( P, (Length( W ) + 1) * 2 );\r
  fList.Insert( Idx, P );\r
  WStrCopy( P, PWideChar( W ) );\r
end;\r
\r
//[function TWStrList.LoadFromFile]\r
function TWStrList.LoadFromFile(const Filename: String): Boolean;\r
begin\r
  Clear;\r
  Result := MergeFromFile( Filename );\r
end;\r
\r
//[procedure TWStrList.LoadFromStream]\r
procedure TWStrList.LoadFromStream(Strm: PStream);\r
begin\r
  Clear;\r
  MergeFromStream( Strm );\r
end;\r
\r
//[function TWStrList.MergeFromFile]\r
function TWStrList.MergeFromFile(const Filename: String): Boolean;\r
var Strm: PStream;\r
begin\r
  Strm := NewReadFileStream( Filename );\r
  Result := Strm.Handle <> INVALID_HANDLE_VALUE;\r
  if Result then\r
    MergeFromStream( Strm );\r
  Strm.Free;\r
end;\r
\r
//[procedure TWStrList.MergeFromStream]\r
procedure TWStrList.MergeFromStream(Strm: PStream);\r
var Buf: WideString;\r
    L: Integer;\r
begin\r
  L := Strm.Size - Strm.Position;\r
  Assert( L mod 1 = 0, 'Wide strings streams must be of even length in bytes.' );\r
  if L = 0 then Exit;\r
  SetLength( Buf, L div 2 );\r
  Strm.Read( Buf[ 1 ], L );\r
  Text := Text + Buf;\r
end;\r
\r
//[procedure TWStrList.Move]\r
procedure TWStrList.Move(IdxOld, IdxNew: Integer);\r
begin\r
  fList.MoveItem( IdxOld, IdxNew );\r
end;\r
\r
//[function TWStrList.SaveToFile]\r
function TWStrList.SaveToFile(const Filename: String): Boolean;\r
var Strm: PStream;\r
begin\r
  Strm := NewWriteFileStream( Filename );\r
  Result := Strm.Handle <> INVALID_HANDLE_VALUE;\r
  if Result then\r
    SaveToStream( Strm );\r
  Strm.Free;\r
end;\r
\r
//[procedure TWStrList.SaveToStream]\r
procedure TWStrList.SaveToStream(Strm: PStream);\r
var Buf, Dest: PWideChar;\r
    I, L, Sz: Integer;\r
    P: Pointer;\r
begin\r
  Sz := 0;\r
  for I := 0 to Count-1 do\r
  begin\r
    P := fList.Items[ I ];\r
    if P <> nil then\r
      Sz := Sz + WStrLen( P ) * 2 + 4\r
    else\r
      Sz := Sz + 4;\r
  end;\r
  GetMem( Buf, Sz );\r
  Dest := Buf;\r
  for I := 0 to Count-1 do\r
  begin\r
    P := fList.Items[ I ];\r
    if P <> nil then\r
    begin\r
      L := WStrLen( P );\r
      System.Move( P^, Dest^, L * 2 );\r
      Inc( Dest, L );\r
    end;\r
    Dest^ := #13;\r
    Inc( Dest );\r
    Dest^ := #10;\r
    Inc( Dest );\r
  end;\r
  Strm.Write( Buf^, Sz );\r
  FreeMem( Buf );\r
end;\r
\r
//[procedure TWStrList.SetItems]\r
procedure TWStrList.SetItems(Idx: Integer; const Value: WideString);\r
var P: Pointer;\r
begin\r
  while Idx > Count-1 do\r
    fList.Add( nil );\r
  if WStrLen( ItemPtrs[ Idx ] ) <= Length( Value ) then\r
    WStrCopy( ItemPtrs[ Idx ], PWideChar( Value ) )\r
  else\r
  begin\r
    P := fList.Items[ Idx ];\r
    if P <> nil then\r
    if not ((P >= fText) and (P <= fText + fTextBufSz)) then\r
      FreeMem( P );\r
    GetMem( P, (Length( Value ) + 1) * 2 );\r
    fList.Items[ Idx ] := P;\r
    WStrCopy( P, PWideChar( Value ) );\r
  end;\r
end;\r
\r
//[procedure TWStrList.SetText]\r
procedure TWStrList.SetText(const Value: WideString);\r
var L, N: Integer;\r
    P: PWideChar;\r
begin\r
  Clear;\r
  if Value = '' then Exit;\r
  L := (Length( Value ) + 1) * 2;\r
  GetMem( fText, L );\r
  System.Move( Value[ 1 ], fText^, L );\r
  fTextBufSz := Length( Value );\r
  N := 0;\r
  P := fText;\r
  while Word( P^ ) <> 0 do\r
  begin\r
    if (Word( P^ ) = 13) then\r
    begin\r
      Inc( N );\r
      PWord( P )^ := 0;\r
      if Word( P[ 1 ] ) = 10 then\r
        Inc( P );\r
    end\r
      else\r
    if (Word( P^ ) = 10) and ((P = fText) or (Word( P[ -1 ] ) <> 0)) then\r
    begin\r
      Inc( N );\r
      PWord( P )^ := 0;\r
    end;\r
    Inc( P );\r
  end;\r
  fList.Capacity := N;\r
  P := fText;\r
  while P < fText + fTextBufSz do\r
  begin\r
    fList.Add( P );\r
    while Word( P^ ) <> 0 do Inc( P );\r
    Inc( P );\r
    if Word( P^ ) = 10 then Inc( P );\r
  end;\r
end;\r
\r
//[function CompareWStrListItems]\r
function CompareWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;\r
var WL: PWStrList;\r
begin\r
  WL := Sender;\r
  Result := WStrCmp( WL.fList.Items[ Idx1 ], WL.fList.Items[ Idx2 ] );\r
end;\r
\r
//[function CompareWStrListItems_UpperCase]\r
function CompareWStrListItems_UpperCase( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;\r
var WL: PWStrList;\r
    L1, L2: Integer;\r
begin\r
  WL := Sender;\r
  L1 := WStrLen( WL.fList.Items[ Idx1 ] );\r
  L2 := WStrLen( WL.fList.Items[ Idx2 ] );\r
  if Length( WL.fTmp1 ) < L1 then\r
    SetLength( WL.fTmp1, L1 + 1 );\r
  if Length( WL.fTmp2 ) < L2 then\r
    SetLength( WL.fTmp2, L2 + 1 );\r
  if L1 > 0 then\r
    Move( WL.fList.Items[ Idx1 ]^, WL.fTmp1[ 1 ], (L1 + 1) * 2 )\r
  else\r
    WL.fTmp1[ 1 ] := #0;\r
  if L2 > 0 then\r
    Move( WL.fList.Items[ Idx2 ]^, WL.fTmp2[ 1 ], (L2 + 1) * 2 )\r
  else\r
    WL.fTmp2[ 1 ] := #0;\r
  CharUpperBuffW( PWideChar( WL.fTmp1 ), L1 );\r
  CharUpperBuffW( PWideChar( WL.fTmp2 ), L2 );\r
  Result := WStrCmp( PWideChar( WL.fTmp1 ), PWideChar( WL.fTmp2 ) );\r
end;\r
\r
//[procedure SwapWStrListItems]\r
procedure SwapWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD );\r
var WL: PWStrList;\r
begin\r
  WL := Sender;\r
  WL.Swap( Idx1, Idx2 );\r
end;\r
\r
//[procedure TWStrList.Sort]\r
procedure TWStrList.Sort( CaseSensitive: Boolean );\r
begin\r
  if CaseSensitive then\r
    SortData( @ Self, Count, @CompareWStrListItems, @SwapWStrListItems )\r
  else\r
  begin\r
    SortData( @ Self, Count, @CompareWStrListItems_UpperCase, @SwapWStrListItems );\r
    fTmp1 := '';\r
    fTmp2 := '';\r
  end;\r
end;\r
\r
//[procedure TWStrList.Swap]\r
procedure TWStrList.Swap(Idx1, Idx2: Integer);\r
begin\r
  fList.Swap( Idx1, Idx2 );\r
end;\r
\r
//[function NewWStrListEx]\r
function NewWStrListEx: PWStrListEx;\r
begin\r
  new( Result, Create );\r
end;\r
\r
{ TWStrListEx }\r
\r
//[function TWStrListEx.AddObject]\r
function TWStrListEx.AddObject(const S: WideString; Obj: DWORD): Integer;\r
begin\r
  Result := Count;\r
  InsertObject( Count, S, Obj );\r
end;\r
\r
//[procedure TWStrListEx.AddWStrings]\r
procedure TWStrListEx.AddWStrings(WL: PWStrListEx);\r
var I: Integer;\r
begin\r
  I := Count;\r
  if WL.FObjects.Count > 0 then\r
    ProvideObjectsCapacity( Count );\r
  inherited AddWStrings( WL );\r
  if WL.FObjects.Count > 0 then\r
  begin\r
    ProvideObjectsCapacity( I + WL.FObjects.Count );\r
    System.Move( WL.FObjects.FItems[ 0 ],\r
                 FObjects.FItems[ I ],\r
                 Sizeof( Pointer ) * WL.FObjects.Count );\r
  end;\r
end;\r
\r
//[procedure TWStrListEx.Assign]\r
procedure TWStrListEx.Assign(WL: PWStrListEx);\r
begin\r
  inherited Assign( WL );\r
  FObjects.Assign( WL.FObjects );\r
end;\r
\r
//[procedure TWStrListEx.Clear]\r
procedure TWStrListEx.Clear;\r
begin\r
  inherited Clear;\r
  FObjects.Clear;\r
end;\r
\r
//[procedure TWStrListEx.Delete]\r
procedure TWStrListEx.Delete(Idx: Integer);\r
begin\r
  inherited Delete( Idx );\r
  if FObjects.FCount >= Idx then\r
    FObjects.Delete( Idx );\r
end;\r
\r
//[destructor TWStrListEx.Destroy]\r
destructor TWStrListEx.Destroy;\r
begin\r
  fObjects.Free;\r
  inherited;\r
end;\r
\r
//[function TWStrListEx.GetObjects]\r
function TWStrListEx.GetObjects(Idx: Integer): DWORD;\r
begin\r
  Result := DWORD( fObjects.Items[ Idx ] );\r
end;\r
\r
//[function TWStrListEx.IndexOfObj]\r
function TWStrListEx.IndexOfObj(Obj: Pointer): Integer;\r
begin\r
  Result := FObjects.IndexOf( Obj );\r
end;\r
\r
//[procedure TWStrListEx.Init]\r
procedure TWStrListEx.Init;\r
begin\r
  inherited;\r
  fObjects := NewList;\r
end;\r
\r
//[procedure TWStrListEx.InsertObject]\r
procedure TWStrListEx.InsertObject(Before: Integer; const S: WideString;\r
  Obj: DWORD);\r
begin\r
  Insert( Before, S );\r
  FObjects.Insert( Before, Pointer( Obj ) );\r
end;\r
\r
//[procedure TWStrListEx.Move]\r
procedure TWStrListEx.Move(IdxOld, IdxNew: Integer);\r
begin\r
  fList.MoveItem( IdxOld, IdxNew );\r
  if FObjects.FCount >= Min( IdxOld, IdxNew ) then\r
  begin\r
    ProvideObjectsCapacity( Max( IdxOld, IdxNew ) + 1 );\r
    FObjects.MoveItem( IdxOld, IdxNew );\r
  end;\r
end;\r
\r
//[procedure TWStrListEx.ProvideObjectsCapacity]\r
procedure TWStrListEx.ProvideObjectsCapacity(NewCap: Integer);\r
begin\r
  if fObjects.Capacity >= NewCap then Exit;\r
  fObjects.Capacity := NewCap;\r
  FillChar( FObjects.FItems[ FObjects.FCount ],\r
            (FObjects.Capacity - FObjects.Count) * Sizeof( Pointer ), 0 );\r
  FObjects.FCount := NewCap;\r
end;\r
\r
//[procedure TWStrListEx.SetObjects]\r
procedure TWStrListEx.SetObjects(Idx: Integer; const Value: DWORD);\r
begin\r
  ProvideObjectsCapacity( Idx + 1 );\r
  fObjects.Items[ Idx ] := Pointer( Value );\r
end;\r
\r
{$ENDIF}\r
{+}\r
\r
\r
//////////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                            S  O  R  T  I  N  G\r
//\r
//\r
//////////////////////////////////////////////////////////////////////////\r
\r
{ -- qsort -- }\r
\r
//[PROCEDURE SortData]\r
{$IFDEF ASM_VERSION} // translated to BASM by Kladov Vladimir\r
procedure SortData( const Data: Pointer; const uNElem: Dword;\r
                    const CompareFun: TCompareEvent;\r
                    const SwapProc: TSwapEvent );\r
asm\r
        CMP      EDX, 2\r
        JL       @@exit\r
\r
        PUSH     EAX      // [EBP-4] = Data\r
        PUSH     ECX      // [EBP-8] = CompareFun\r
        PUSH     EBX      // EBX = pivotP\r
        XOR      EBX, EBX\r
        INC      EBX      // EBX = 1 to pass to qSortHelp as PivotP\r
        MOV      EAX, EDX // EAX = nElem\r
        CALL     @@qSortHelp\r
        POP      EBX\r
        POP      ECX\r
        POP      ECX\r
@@exit:\r
        POP      EBP\r
        RET      4\r
\r
@@qSortHelp:\r
        PUSH     EBX      // EBX (in) = PivotP\r
        PUSH     ESI      // ESI      = leftP\r
        PUSH     EDI      // EDI      = rightP\r
\r
@@TailRecursion:\r
        CMP      EAX, 2\r
        JG       @@2\r
        JNE      @@exit_qSortHelp\r
        LEA      ECX, [EBX+1]\r
        MOV      EDX, EBX\r
        CALL     @@Compare\r
        JLE      @@exit_qSortHelp\r
@@swp_exit:\r
        CALL     @@Swap\r
@@exit_qSortHelp:\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
        RET\r
\r
        // ESI = leftP\r
        // EDI = rightP\r
@@2:    LEA      EDI, [EAX+EBX-1]\r
        MOV      ESI, EAX\r
        SHR      ESI, 1\r
        ADD      ESI, EBX\r
        MOV      ECX, ESI\r
        MOV      EDX, EDI\r
        CALL     @@CompareLeSwap\r
        MOV      EDX, EBX\r
        CALL     @@Compare\r
\r
        JG       @@4\r
        CALL     @@Swap\r
        JMP      @@5\r
@@4:    MOV      ECX, EBX\r
        MOV      EDX, EDI\r
        CALL     @@CompareLeSwap\r
@@5:\r
        CMP      EAX, 3\r
        JNE      @@6\r
        MOV      EDX, EBX\r
        MOV      ECX, ESI\r
        JMP      @@swp_exit\r
@@6:    // classic Horae algorithm\r
\r
        PUSH     EAX     // EAX = pivotEnd\r
        LEA      EAX, [EBX+1]\r
        MOV      ESI, EAX\r
@@repeat:\r
        MOV      EDX, ESI\r
        MOV      ECX, EBX\r
        CALL     @@Compare\r
        JG       @@while2\r
@@while1:\r
        JNE      @@7\r
        MOV      EDX, ESI\r
        MOV      ECX, EAX\r
        CALL     @@Swap\r
        INC      EAX\r
@@7:\r
        CMP      ESI, EDI\r
        JGE      @@qBreak\r
        INC      ESI\r
        JMP      @@repeat\r
@@while2:\r
        CMP      ESI, EDI\r
        JGE      @@until\r
        MOV      EDX, EBX\r
        MOV      ECX, EDI\r
        CALL     @@Compare\r
        JGE      @@8\r
        DEC      EDI\r
        JMP      @@while2\r
@@8:\r
        MOV      EDX, ESI\r
        MOV      ECX, EDI\r
        PUSHFD\r
        CALL     @@Swap\r
        POPFD\r
        JE       @@until\r
        INC      ESI\r
        DEC      EDI\r
@@until:\r
        CMP      ESI, EDI\r
        JL       @@repeat\r
@@qBreak:\r
        MOV      EDX, ESI\r
        MOV      ECX, EBX\r
        CALL     @@Compare\r
        JG       @@9\r
        INC      ESI\r
@@9:\r
        PUSH     EBX      // EBX = PivotTemp\r
        PUSH     ESI      // ESI = leftTemp\r
        DEC      ESI\r
@@while3:\r
        CMP      EBX, EAX\r
        JGE      @@while3_break\r
        CMP      ESI, EAX\r
        JL       @@while3_break\r
        MOV      EDX, EBX\r
        MOV      ECX, ESI\r
        CALL     @@Swap\r
        INC      EBX\r
        DEC      ESI\r
        JMP      @@while3\r
@@while3_break:\r
        POP      ESI\r
        POP      EBX\r
\r
        MOV      EDX, EAX\r
        POP      EAX     // EAX = nElem\r
        PUSH     EDI     // EDI = lNum\r
        MOV      EDI, ESI\r
        SUB      EDI, EDX\r
        ADD      EAX, EBX\r
        SUB      EAX, ESI\r
\r
        PUSH     EBX\r
        PUSH     EAX\r
        CMP      EAX, EDI\r
        JGE      @@10\r
\r
        MOV      EBX, ESI\r
        CALL     @@qSortHelp\r
        POP      EAX\r
        MOV      EAX, EDI\r
        POP      EBX\r
        JMP      @@11\r
\r
@@10:   MOV      EAX, EDI\r
        CALL     @@qSortHelp\r
        POP      EAX\r
        POP      EBX\r
        MOV      EBX, ESI\r
@@11:\r
        POP      EDI\r
        JMP      @@TailRecursion\r
\r
@@Compare:\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     ECX\r
        MOV      EAX, [EBP-4]\r
        DEC      EDX\r
        DEC      ECX\r
        CALL     dword ptr [EBP-8]\r
        POP      ECX\r
        POP      EDX\r
        TEST     EAX, EAX\r
        POP      EAX\r
        RET\r
\r
@@CompareLeSwap:\r
        CALL     @@Compare\r
        JG       @@ret\r
\r
@@Swap: PUSH     EAX\r
        PUSH     EDX\r
        PUSH     ECX\r
        MOV      EAX, [EBP-4]\r
        DEC      EDX\r
        DEC      ECX\r
        CALL     dword ptr [SwapProc]\r
        POP      ECX\r
        POP      EDX\r
        TEST     EAX, EAX\r
        POP      EAX\r
@@ret:\r
        RET\r
\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure SortData( const Data: Pointer; const uNElem: Dword;\r
                    const CompareFun: TCompareEvent;\r
                    const SwapProc: TSwapEvent );\r
{ uNElem - number of elements to sort }\r
\r
  function Compare( const e1, e2 : DWord ) : Integer;\r
  begin\r
    Result := CompareFun( Data, e1 - 1, e2 - 1 );\r
  end;\r
\r
  procedure Swap( const e1, e2 : DWord );\r
  begin\r
    SwapProc( Data, e1 - 1, e2 - 1 );\r
  end;\r
\r
  procedure qSortHelp(pivotP: Dword; nElem: Dword);\r
  label\r
    TailRecursion,\r
    qBreak;\r
  var\r
    leftP, rightP, pivotEnd, pivotTemp, leftTemp: Dword;\r
    lNum: Dword;\r
    retval: integer;\r
  begin\r
    TailRecursion:\r
      if (nElem <= 2) then\r
      begin\r
        if (nElem = 2) then\r
          begin\r
            rightP := pivotP +1;\r
            retval := Compare(pivotP,rightP);\r
            if (retval > 0) then Swap(pivotP,rightP);\r
          end;\r
        exit;\r
      end;\r
      rightP := (nElem -1) + pivotP;\r
      leftP :=  (nElem shr 1) + pivotP;\r
      { sort pivot, left, and right elements for "median of 3" }\r
      retval := Compare(leftP,rightP);\r
      if (retval > 0) then Swap(leftP, rightP);\r
      retval := Compare(leftP,pivotP);\r
\r
      if (retval > 0) then\r
        Swap(leftP, pivotP)\r
      else\r
      begin\r
        retval := Compare(pivotP,rightP);\r
        if retval > 0 then Swap(pivotP, rightP);\r
      end;\r
      if (nElem = 3) then\r
      begin\r
        Swap(pivotP, leftP);\r
        exit;\r
      end;\r
      { now for the classic Horae algorithm }\r
      pivotEnd := pivotP + 1;\r
      leftP := pivotEnd;\r
      repeat\r
\r
        retval := Compare(leftP, pivotP);\r
        while (retval <= 0) do\r
          begin\r
\r
            if (retval = 0) then\r
              begin\r
                Swap(leftP, pivotEnd);\r
                Inc(pivotEnd);\r
              end;\r
            if (leftP < rightP) then\r
              Inc(leftP)\r
            else\r
              goto qBreak;\r
            retval := Compare(leftP, pivotP);\r
          end; {while}\r
        while (leftP < rightP) do\r
          begin\r
            retval := Compare(pivotP, rightP);\r
            if (retval < 0) then\r
              Dec(rightP)\r
\r
            else\r
              begin\r
                Swap(leftP, rightP);\r
                if (retval <> 0) then\r
                  begin\r
                    Inc(leftP);\r
                    Dec(rightP);\r
                  end;\r
                break;\r
              end;\r
          end; {while}\r
\r
      until (leftP >= rightP);\r
    qBreak:\r
      retval := Compare(leftP,pivotP);\r
      if (retval <= 0) then Inc(leftP);\r
\r
      leftTemp := leftP -1;\r
      pivotTemp := pivotP;\r
      while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do\r
      begin\r
        Swap(pivotTemp, leftTemp);\r
        Inc(pivotTemp);\r
        Dec(leftTemp);\r
      end; {while}\r
      lNum := (leftP - pivotEnd);\r
      nElem := ((nElem + pivotP) -leftP);\r
\r
      if (nElem < lNum) then\r
      begin\r
        qSortHelp(leftP, nElem);\r
        nElem := lNum;\r
      end\r
        else\r
      begin\r
        qSortHelp(pivotP, lNum);\r
        pivotP := leftP;\r
      end;\r
      goto TailRecursion;\r
    end; {qSortHelp }\r
\r
begin\r
  if (uNElem < 2) then  exit; { nothing to sort }\r
  qSortHelp(1, uNElem);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END SortData]\r
\r
//[FUNCTION CompareIntegers]\r
{$IFDEF ASM_VERSION}\r
function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;\r
asm\r
        MOV      EDX, [EAX+EDX*4]\r
        SUB      EDX, [EAX+ECX*4]\r
        XCHG     EAX, EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;\r
var I1, I2 : Integer;\r
begin\r
  I1 := PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;\r
  I2 := PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;\r
  Result := 0;\r
  if I1 < I2 then Result := -1\r
  else\r
  if I1 > I2 then Result := 1;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CompareIntegers]\r
\r
//[FUNCTION CompareDwords]\r
{$IFDEF ASM_VERSION}\r
function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;\r
asm\r
        MOV      EDX, [EAX+EDX*4]\r
        SUB      EDX, [EAX+ECX*4]\r
        XCHG     EAX, EDX\r
        JNB      @@1\r
        SBB      EAX, EAX\r
@@1:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;\r
var I1, I2 : DWord;\r
begin\r
  I1 := PDWORD( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;\r
  I2 := PDWORD( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;\r
  Result := 0;\r
  if I1 < I2 then Result := -1\r
  else\r
  if I1 > I2 then Result := 1;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CompareDwords]\r
\r
//[PROCEDURE SwapIntegers]\r
{$IFDEF ASM_VERSION}\r
procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD );\r
asm\r
        LEA      EDX, [EAX+EDX*4]\r
        LEA      ECX, [EAX+ECX*4]\r
        MOV      EAX, [EDX]\r
        XCHG     EAX, [ECX]\r
        MOV      [EDX], EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD );\r
var Tmp : Integer;\r
begin\r
  Tmp := PInteger( DWORD( Sender ) + e1 * SizeOf( Integer ) )^;\r
  PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^ :=\r
  PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;\r
  PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^ := Tmp;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END SwapIntegers]\r
\r
//[procedure SortIntegerArray]\r
procedure SortIntegerArray( var A : array of Integer );\r
begin\r
  SortData( @A[ 0 ], High( A ) - Low( A ) + 1, @CompareIntegers, @SwapIntegers );\r
end;\r
\r
//[procedure SortDwordArray]\r
procedure SortDwordArray( var A : array of DWORD );\r
begin\r
  SortData( @A[ 0 ], High( A ) - Low( A ) + 1, @CompareDwords, @SwapIntegers );\r
end;\r
\r
\r
{ -- status bar implementation -- }\r
\r
//[FUNCTION _NewStatusbar]\r
{$IFDEF ASM_VERSION}\r
function _NewStatusbar( AParent: PControl ): PControl;\r
const STAT_CLS_NAM: PChar = STATUSCLASSNAME;\r
asm\r
        PUSH     0\r
        PUSH     0\r
        //PUSH     EAX\r
        //CALL     TControl.GetCanResize\r
        CMP      [EAX].TControl.fSizeGrip, 0\r
        MOV      ECX, WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or 3 or WS_VISIBLE\r
        //MOV      CH, AL  // SBARS_SIZEGRIP =     $0100\r
        JZ       @@1\r
        //SETNZ    CH\r
        INC      CH\r
        AND      CL, not 3\r
@@1:\r
        //POP      EAX\r
        MOV      EDX, [STAT_CLS_NAM]\r
        CALL     _NewCommonControl\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        PUSH     EDI\r
        LEA      EDI, [EBX].TControl.fBoundsRect\r
        XOR      EAX, EAX\r
        STOSD\r
        STOSD\r
        STOSD\r
        STOSD\r
        MOV      [EBX].TControl.fAlign, caBottom\r
        INC      [EBX].TControl.fNotUseAlign\r
        POP      EDI\r
        MOV      EAX, EBX\r
        CALL     InitCommonControlSizeNotify\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function _NewStatusbar( AParent: PControl ): PControl;\r
var Style: DWORD;\r
    //R: TRect;\r
begin\r
  Style := WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or 3 or WS_VISIBLE;\r
  {if AParent.CanResize then\r
     Style := Style or SBARS_SIZEGRIP;}\r
  if AParent.fSizeGrip then\r
     Style := (Style or SBARS_SIZEGRIP) and not 3;\r
  Result := _NewCommonControl( AParent, STATUSCLASSNAME,\r
            Style, FALSE, nil  );\r
\r
  with Result.fBoundsRect do\r
  begin\r
    Left := 0;\r
    Right := 0;\r
    Top := 0;\r
    Bottom := 0;\r
  end;\r
  Result.fAlign := caBottom;\r
  Result.fNotUseAlign := True;\r
  {$IFDEF TEST_VERSION}\r
  Result.fTag := DWORD( PChar( 'Status bar' ) );\r
  {$ENDIF}\r
  InitCommonControlSizeNotify( Result );\r
  //R := AParent.ClientRect;\r
  //AParent.Perform( WM_SIZING, WMSZ_TOPLEFT, Integer( @ R ) );\r
  //Result.AttachProc( WndProcEraseBkgnd );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _NewStatusbar]\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetStatusText]\r
procedure TControl.SetStatusText(Index: Integer; Value: PChar);\r
asm\r
        PUSHAD\r
        MOV      EBX, EDX // EBX = Index\r
        MOV      ESI, EAX // ESI = @Self\r
\r
        PUSH     Value // prepare value for call at the end of procedure\r
        PUSH     EBX   // prepare Index for call at the end of procedure\r
\r
        MOV      ECX, [ESI].fStatusCtl\r
        INC      ECX\r
        LOOP     @@status_created\r
\r
        CALL     GetClientHeight\r
        PUSH     EAX // ch = old client height\r
\r
        MOV      EAX, ESI\r
        CALL     _NewStatusBar\r
        MOV      [ESI].fStatusCtl, EAX\r
        PUSH     EAX //-----------v\r
\r
        CALL     TControl.GetWindowHandle\r
        MOV      [ESI].fStatusWnd, EAX\r
        XCHG     EDI, EAX\r
        POP      EAX //-----------^\r
\r
        XOR      EDX, EDX\r
        PUSH     EDX\r
        INC      DH\r
        DEC      EDX\r
        CMP      EBX, EDX\r
        SETZ     DL\r
        NEG      EDX\r
\r
@@1:    PUSH     EDX\r
        PUSH     SB_SIMPLE\r
\r
        PUSH     EAX\r
        CALL     TControl.Perform\r
\r
        ADD      ESP, -16\r
        PUSH     ESP\r
        PUSH     [ESI].fStatusWnd\r
        CALL     GetWindowRect\r
        POP      EAX\r
        POP      EDX\r
        POP      EAX\r
        POP      EAX\r
        SUB      EAX, EDX\r
        MOV      [ESI].fClientBottom, EAX\r
\r
        POP      EDX // ch\r
\r
        PUSH     0\r
        PUSH     0\r
        PUSH     WM_SIZE\r
        PUSH     EDI\r
\r
        MOV      EAX, ESI\r
        CALL     TControl.SetClientHeight\r
\r
        CALL     SendMessage\r
\r
@@status_created:\r
        CMP      EBX, 255\r
        JGE      @@not_simple\r
\r
        PUSH     0\r
        PUSH     0\r
        PUSH     SB_GETPARTS\r
        PUSH     [ESI].fStatusWnd\r
        CALL     SendMessage\r
\r
        CMP      EAX, EBX\r
        JG       @@reset_simple\r
\r
        MOV      EAX, ESI\r
        CALL     GetWidth\r
        CDQ\r
        MOV      ECX, EBX\r
        INC      ECX\r
        IDIV     ECX\r
        MOV      EDX, EAX\r
\r
        ADD      ESP, -1024\r
        MOV      ECX, EBX\r
        MOV      EDI, ESP\r
        JECXZ    @@2\r
\r
@@store_loo:\r
        STOSD\r
        ADD      EAX, EDX\r
        LOOP     @@store_loo\r
@@2:\r
        OR       dword ptr [ESP+EBX*4], -1\r
        PUSH     ESP\r
        INC      EBX\r
        PUSH     EBX\r
        PUSH     SB_SETPARTS\r
        PUSH     [ESI].fStatusWnd\r
        CALL     SendMessage\r
        ADD      ESP, 1024\r
\r
@@reset_simple:\r
        PUSH     0\r
        PUSH     0\r
        PUSH     SB_SIMPLE\r
        PUSH     [ESI].fStatusWnd\r
        CALL     SendMessage\r
\r
@@not_simple:\r
        PUSH     SB_SETTEXT\r
        PUSH     [ESI].fStatusWnd\r
        CALL     SendMessage\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetStatusText(Index: Integer; Value: PChar);\r
var ch: Integer;\r
    R : TRect;\r
    N, I, L, W : Integer;\r
    WidthsBuf: array[ 0..254 ] of Integer;\r
begin\r
  if fStatusCtl = nil then\r
  begin\r
    ch := GetClientHeight;\r
    fStatusCtl := _NewStatusBar( @Self );\r
    fStatusWnd := fStatusCtl.GetWindowHandle;\r
    fStatusCtl.Perform( SB_SIMPLE, Integer( LongBool( Index = 255 ) ), 0 );\r
    GetWindowRect( fStatusWnd, R );\r
    fClientBottom := R.Bottom - R.Top;\r
    SetClientHeight( ch );\r
    SendMessage( fStatusWnd, WM_SIZE, 0, 0 );\r
  end;\r
  if Index < 255 then\r
  begin\r
    N := SendMessage( fStatusWnd, SB_GETPARTS, 0, 0 );\r
    if N <= Index then\r
    begin\r
      W := Width;\r
      L := W div (Index + 1);\r
      W := L;\r
      for I := 0 to Index - 1 do\r
      begin\r
        WidthsBuf[ I ] := W;\r
        Inc( W, L );\r
      end;\r
      WidthsBuf[ Index ] := -1;\r
      SendMessage( fStatusWnd, SB_SETPARTS, Index + 1, Integer( @WidthsBuf[ 0 ] ) );\r
    end;\r
    SendMessage( fStatusWnd, SB_SIMPLE, 0, 0 );\r
  end;\r
  SendMessage( fStatusWnd, SB_SETTEXT, Index, Integer( Value ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetStatusText]\r
function TControl.GetStatusText( Index: Integer ): PChar;\r
asm\r
        MOV      ECX, [EAX].fStatusWnd\r
        JECXZ    @@exit\r
\r
        PUSH     EBX\r
        PUSH     ESI\r
        XCHG     ESI, EAX // ESI = @Self\r
        MOV      EBX, EDX // EBX = Index\r
\r
        XOR      EAX, EAX\r
        XCHG     EAX, [ESI].fStatusTxt\r
        TEST     EAX, EAX\r
        JZ       @@1\r
        CALL     System.@FreeMem\r
@@1:\r
        XOR      EAX, EAX\r
        CDQ\r
        MOV      DL, WM_GETTEXTLENGTH\r
          PUSH     WM_GETTEXT\r
        CMP      EBX, 255\r
        JZ       @@2\r
          POP      EAX\r
        MOV      EAX, EBX\r
        MOV      DX, SB_GETTEXTLENGTH\r
          PUSH     SB_GETTEXT\r
@@2:\r
        MOV      EBX, EAX\r
\r
        PUSH     0\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     [ESI].fStatusWnd\r
        CALL     SendMessage\r
        TEST     AX, AX\r
        JZ       @@get_rslt\r
\r
        PUSH     EAX\r
        INC      EAX\r
        CALL     System.@GetMem\r
        POP      EDX\r
        MOV      [ESI].fStatusTxt, EAX\r
        MOV      byte ptr [EAX+EDX], 0\r
\r
        POP      EDX // Msg\r
        PUSH     EAX\r
        PUSH     EBX\r
        PUSH     EDX\r
        PUSH     [ESI].fStatusWnd\r
        CALL     SendMessage\r
          PUSH     EDX\r
@@get_rslt:\r
          POP      EDX\r
        MOV      ECX, [ESI].fStatusTxt\r
        POP      ESI\r
        POP      EBX\r
\r
@@exit: XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetStatusText( Index: Integer ): PChar;\r
var L, I: Integer;\r
    Msg: DWORD;\r
begin\r
  Result := nil;\r
  if fStatusWnd = 0 then Exit;\r
  if fStatusTxt <> nil then\r
     FreeMem( fStatusTxt );\r
  fStatusTxt := nil;\r
  Msg := SB_GETTEXTLENGTH;\r
  I := Index;\r
  if Index = 255 then\r
  begin\r
     Msg := WM_GETTEXTLENGTH;\r
     I := 0;\r
  end;\r
  L := SendMessage( fStatusWnd, Msg, I, 0 ) and $FFFF;\r
  if L > 0 then\r
  begin\r
    GetMem( fStatusTxt, L + 1 );\r
    fStatusTxt[ L ] := #0;\r
    Msg := SB_GETTEXT;\r
    if Index = 255 then\r
      Msg := WM_GETTEXT;\r
    SendMessage( fStatusWnd, Msg, I, Integer( fStatusTxt ) );\r
  end;\r
  Result := fStatusTxt;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.RemoveStatus]\r
procedure TControl.RemoveStatus;\r
asm\r
        MOV      ECX, [EAX].fStatusCtl\r
        JECXZ    @@exit\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CALL     GetClientHeight\r
        PUSH     EAX\r
        CDQ\r
        MOV      [EBX].fStatusWnd, EDX\r
        XCHG     EAX, EDX\r
        XCHG     [EBX].fStatusCtl, EAX\r
        CALL     TControl.Free\r
        POP      EAX\r
        CDQ\r
        MOV      [EBX].fClientBottom, EDX\r
        XCHG     EDX, EAX\r
        XCHG     EAX, EBX\r
        POP      EBX\r
        CALL     SetClientHeight\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.RemoveStatus;\r
var ch: Integer;\r
begin\r
  if fStatusCtl = nil then Exit;\r
  ch := ClientHeight;\r
  fStatusWnd := 0;\r
  fStatusCtl.Free;\r
  fStatusCtl := nil;\r
  fClientBottom := 0;\r
  ClientHeight := ch;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.StatusPanelCount]\r
function TControl.StatusPanelCount: Integer;\r
asm\r
        MOV      EAX, [EAX].fStatusWnd\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        PUSH     0\r
        PUSH     0\r
        PUSH     SB_GETPARTS\r
        PUSH     EAX\r
        CALL     SendMessage\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.StatusPanelCount: Integer;\r
begin\r
  Result := 0;\r
  if fStatusWnd = 0 then Exit;\r
  Result := SendMessage( fStatusWnd, SB_GETPARTS, 0, 0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetStatusPanelX]\r
function TControl.GetStatusPanelX(Idx: Integer): Integer;\r
asm\r
        MOV      ECX, [EAX].fStatusWnd\r
        JECXZ    @@exit\r
        PUSH     EBX\r
        MOV      EBX, EDX\r
        ADD      ESP, -1024\r
        PUSH     ESP\r
        XOR      EDX, EDX\r
        DEC      DL\r
        PUSH     EDX\r
        MOV      DX, SB_GETPARTS\r
        PUSH     EDX\r
        PUSH     ECX\r
        CALL     SendMessage\r
        CMP      EAX, EBX\r
        MOV      ECX, [ESP+EBX*4]\r
        JG       @@1\r
        XOR      ECX, ECX\r
@@1:    ADD      ESP, 1024\r
        POP      EBX\r
@@exit:\r
        XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetStatusPanelX(Idx: Integer): Integer;\r
var Buf: array[0..254] of Integer;\r
    N : Integer;\r
begin\r
  Result := 0;\r
  if fStatusWnd = 0 then Exit;\r
  N := SendMessage( fStatusWnd, SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );\r
  if N <= Idx then Exit;\r
  Result := Buf[ Idx ];\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetStatusPanelX]\r
procedure TControl.SetStatusPanelX(Idx: Integer; const Value: Integer);\r
asm\r
        ADD      ESP, -1024\r
        MOV      EAX, [EAX].fStatusWnd\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
\r
        PUSH     ESP\r
        PUSH     EDX\r
        PUSH     SB_SETPARTS\r
        PUSH     EAX\r
\r
        PUSH     EDX\r
        PUSH     ECX\r
\r
        LEA      EDX, [ESP+24]\r
        PUSH     EDX\r
        PUSH     255\r
        PUSH     SB_GETPARTS\r
        PUSH     EAX\r
        CALL     SendMessage\r
\r
        POP      ECX\r
        POP      EDX\r
        CMP      EAX, EDX\r
        JG       @@1\r
        ADD      ESP, 16\r
        JMP      @@exit\r
\r
@@1:    MOV      [ESP+8], EAX\r
        MOV      [ESP+16+EDX*4], ECX\r
        CALL     SendMessage\r
\r
@@exit: ADD      ESP, 1024\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetStatusPanelX(Idx: Integer; const Value: Integer);\r
var Buf: array[0..254] of Integer;\r
    N : Integer;\r
begin\r
  if fStatusWnd = 0 then Exit;\r
  N := SendMessage( fStatusWnd, SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );\r
  if N <= Idx then Exit;\r
  Buf[ Idx ] := Value;\r
  SendMessage( fStatusWnd, SB_SETPARTS, N, Integer( @Buf[ 0 ] ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.SetColor1]\r
procedure TControl.SetColor1(const Value: TColor);\r
begin\r
  fColor1 := Value;\r
  Invalidate;\r
end;\r
\r
//[procedure TControl.SetColor2]\r
procedure TControl.SetColor2(const Value: TColor);\r
begin\r
  fColor2 := Value;\r
  Invalidate;\r
end;\r
\r
//[procedure TControl.SetGradientLayout]\r
procedure TControl.SetGradientLayout(const Value: TGradientLayout);\r
begin\r
  FGradientLayout := Value;\r
  Invalidate;\r
end;\r
\r
//[procedure TControl.SetGradientStyle]\r
procedure TControl.SetGradientStyle(const Value: TGradientStyle);\r
begin\r
  FGradientStyle := Value;\r
  Invalidate;\r
end;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
{ -- Image List -- }\r
\r
//*\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewImageList]\r
function NewImageList( AOwner: PControl ): PImageList;\r
begin\r
  new( Result, CreateImageList( AOwner ) );\r
end;\r
//[END NewImageList]\r
{$ELSE not_USE_CONSTRUCTORS}\r
//[function NewImageList]\r
function NewImageList( AOwner: PControl ): PImageList;\r
begin\r
  {*************} DoInitCommonControls( ICC_WIN95_CLASSES );\r
  {-}\r
  New( Result, Create );\r
  {+}\r
  {++}(*Result := TImageList.Create;*){--}\r
  Result.FAllocBy := 1;\r
  Result.FMasked := True;\r
  if AOwner = nil then exit;\r
\r
  Result.FControl := AOwner;\r
  Result.fNext := PImageList( AOwner.fImageList );\r
  if AOwner.fImageList <> nil then\r
     PImageList( AOwner.fImageList ).fPrev := Result;\r
  Result.fBkColor := clNone;\r
  //ImageList_SetBkColor( Result.FHandle, CLR_NONE );\r
  AOwner.fImageList := Result;\r
  Result.FImgWidth := 32;\r
  Result.FImgHeight := 32;\r
  Result.FColors := ilcDefault;\r
end;\r
{$ENDIF}\r
\r
//[API ImageList_XXX]\r
function ImageList_Create; stdcall; external cctrl name 'ImageList_Create';\r
function ImageList_Destroy; external cctrl name 'ImageList_Destroy';\r
function ImageList_GetImageCount; external cctrl name 'ImageList_GetImageCount';\r
function ImageList_SetImageCount; external cctrl name 'ImageList_SetImageCount';\r
function ImageList_Add; external cctrl name 'ImageList_Add';\r
function ImageList_ReplaceIcon; external cctrl name 'ImageList_ReplaceIcon';\r
function ImageList_SetBkColor; external cctrl name 'ImageList_SetBkColor';\r
function ImageList_GetBkColor; external cctrl name 'ImageList_GetBkColor';\r
function ImageList_SetOverlayImage; external cctrl name 'ImageList_SetOverlayImage';\r
function ImageList_Draw; external cctrl name 'ImageList_Draw';\r
function ImageList_Replace; external cctrl name 'ImageList_Replace';\r
function ImageList_AddMasked; external cctrl name 'ImageList_AddMasked';\r
function ImageList_DrawEx; external cctrl name 'ImageList_DrawEx';\r
function ImageList_Remove; external cctrl name 'ImageList_Remove';\r
function ImageList_GetIcon; external cctrl name 'ImageList_GetIcon';\r
function ImageList_LoadImageA; external cctrl name 'ImageList_LoadImageA';\r
function ImageList_LoadImageW; external cctrl name 'ImageList_LoadImageW';\r
function ImageList_LoadImage; external cctrl name 'ImageList_LoadImageA';\r
function ImageList_BeginDrag; external cctrl name 'ImageList_BeginDrag';\r
function ImageList_EndDrag; external cctrl name 'ImageList_EndDrag';\r
function ImageList_DragEnter; external cctrl name 'ImageList_DragEnter';\r
function ImageList_DragLeave; external cctrl name 'ImageList_DragLeave';\r
function ImageList_DragMove; external cctrl name 'ImageList_DragMove';\r
function ImageList_SetDragCursorImage; external cctrl name 'ImageList_SetDragCursorImage';\r
function ImageList_DragShowNolock; external cctrl name 'ImageList_DragShowNolock';\r
function ImageList_GetDragImage; external cctrl name 'ImageList_GetDragImage';\r
//function ImageList_Read; external cctrl name 'ImageList_Read';\r
//function ImageList_Write; external cctrl name 'ImageList_Write';\r
function ImageList_GetIconSize; external cctrl name 'ImageList_GetIconSize';\r
function ImageList_SetIconSize; external cctrl name 'ImageList_SetIconSize';\r
function ImageList_GetImageInfo; external cctrl name 'ImageList_GetImageInfo';\r
function ImageList_Merge; external cctrl name 'ImageList_Merge';\r
\r
//[function ImageList_AddIcon]\r
function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer;\r
begin\r
  Result := ImageList_ReplaceIcon(ImageList, -1, Icon);\r
end;\r
\r
//[function Index2OverlayMask]\r
function Index2OverlayMask(Index: Integer): Integer;\r
begin\r
  Result := Index shl 8;\r
end;\r
\r
{ macros }\r
//[procedure ImageList_RemoveAll]\r
procedure ImageList_RemoveAll(ImageList: HImageList); stdcall;\r
begin\r
  ImageList_Remove(ImageList, -1);\r
end;\r
\r
//[function ImageList_ExtractIcon]\r
function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList;\r
  Image: Integer): HIcon; stdcall;\r
begin\r
  Result := ImageList_GetIcon(ImageList, Image, 0);\r
end;\r
\r
//[function ImageList_LoadBitmap]\r
function ImageList_LoadBitmap(Instance: THandle; Bmp: PChar;\r
  CX, Grow: Integer; Mask: TColorRef): HImageList; stdcall;\r
begin\r
  Result := ImageList_LoadImage(Instance, Bmp, CX, Grow, Mask,\r
    IMAGE_BITMAP, 0);\r
end;\r
\r
//[procedure FreeBmp]\r
procedure FreeBmp( Bmp: HBitmap );\r
begin\r
  DeleteObject( Bmp );\r
end;\r
\r
//[function LoadBmp]\r
function LoadBmp( Instance: Integer; Rsrc: PChar; MasterObj: PObj ): HBitmap;\r
begin\r
  Result := LoadBitmap( Instance, Rsrc );\r
  MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) );\r
end;\r
\r
{ TImageList }\r
\r
//*\r
//[function TImageList.Add]\r
function TImageList.Add(Bmp, Msk: HBitmap): Integer;\r
begin\r
  Result := -1;\r
  if not HandleNeeded then Exit;\r
  Result := ImageList_Add( FHandle, Bmp, Msk );\r
end;\r
\r
//*\r
//[function TImageList.AddIcon]\r
function TImageList.AddIcon(Ico: HIcon): Integer;\r
{var Bmp : HBitmap;\r
    DC : HDC;}\r
begin\r
  Result := -1;\r
  if ImgWidth = 0 then\r
    ImgWidth := 32;\r
  if ImgHeight = 0 then\r
    ImgHeight := 32;\r
  if not HandleNeeded then Exit;\r
\r
  {DC := GetDC( 0 );\r
  Bmp := CreateCompatibleBitmap( DC, ImgWidth, ImgHeight );\r
  Result := AddMasked( Bmp, 0 );\r
  DeleteObject( Bmp );\r
  ReleaseDC( 0, DC );\r
  if Result >= 0 then\r
     ReplaceIcon( Result, Ico );}\r
  Result := ImageList_AddIcon( fHandle, Ico );\r
end;\r
\r
//*\r
//[function TImageList.AddMasked]\r
function TImageList.AddMasked(Bmp: HBitmap; Color: TColor): Integer;\r
begin\r
  Result := -1;\r
  if not HandleNeeded then Exit;\r
  Result := ImageList_AddMasked( FHandle, Bmp, Color2RGB( Color ) );\r
end;\r
\r
//+\r
//[procedure TImageList.Clear]\r
procedure TImageList.Clear;\r
begin\r
  Handle := 0;\r
end;\r
\r
//*\r
//[procedure TImageList.Delete]\r
procedure TImageList.Delete(Idx: Integer);\r
begin\r
   if FHandle = 0 then Exit;\r
   ImageList_Remove( FHandle, Idx );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TImageList.Destroy]\r
destructor TImageList.Destroy;\r
asm\r
        PUSH     EAX\r
        XOR      EDX, EDX\r
        CALL     SetHandle\r
        POP      EAX\r
        MOV      EDX, [EAX].fNext\r
        MOV      ECX, [EAX].fPrev\r
        TEST     EDX, EDX\r
        JZ       @@nonext\r
        MOV      [EDX].fPrev, ECX\r
@@nonext:\r
        JECXZ    @@noprev\r
        MOV      [ECX].fNext, EDX\r
@@noprev:\r
        MOV      ECX, [EAX].fControl\r
        JECXZ    @@fin\r
        CMP      [ECX].TControl.fImageList, EAX\r
        JNZ      @@fin\r
        MOV      [ECX].TControl.fImageList, EDX\r
@@fin:  CALL     TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TImageList.Destroy;\r
begin\r
  Clear;\r
  if fNext <> nil then\r
    fNext.fPrev := fPrev;\r
  if fPrev <> nil then\r
    fPrev.fNext := fNext;\r
  if fControl <> nil then\r
  if PControl( fControl ).fImageList = @Self then\r
    PControl( fControl ).fImageList := fNext;\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[procedure TImageList.Draw]\r
procedure TImageList.Draw(Idx: Integer; DC: HDC; X, Y: Integer);\r
begin\r
  if FHandle = 0 then Exit;\r
  ImageList_Draw( FHandle, Idx, DC, X, Y, GetDrawStyle );\r
end;\r
\r
//[function TImageList.ExtractIcon]\r
function TImageList.ExtractIcon(Idx: Integer): HIcon;\r
begin\r
  Result := ImageList_ExtractIcon( 0, FHandle, Idx );\r
end;\r
\r
//[function TImageList.ExtractIconEx]\r
function TImageList.ExtractIconEx(Idx: Integer): HIcon;\r
begin\r
  Result := ImageList_GetIcon( FHandle, Idx, GetDrawStyle );\r
end;\r
\r
//*\r
//[function TImageList.GetBitmap]\r
function TImageList.GetBitmap: HBitmap;\r
var II : TImageInfo;\r
begin\r
  Result := 0;\r
  if FHandle = 0 then Exit;\r
  if ImageList_GetImageInfo( FHandle, 0, II ) then\r
     Result := II.hbmImage;\r
end;\r
\r
//*\r
//[function TImageList.GetBkColor]\r
function TImageList.GetBkColor: TColor;\r
begin\r
  Result := fBkColor;\r
  if FHandle = 0 then Exit;\r
  Result := ImageList_GetBkColor( FHandle );\r
end;\r
\r
//*\r
//[function TImageList.GetCount]\r
function TImageList.GetCount: Integer;\r
begin\r
  Result := 0;\r
  if FHandle <> 0 then\r
     Result := ImageList_GetImageCount( FHandle );\r
end;\r
\r
//*\r
//[function TImageList.GetDrawStyle]\r
function TImageList.GetDrawStyle: DWord;\r
begin\r
  Result := 0;\r
  if dsBlend25 in DrawingStyle then\r
     Result := Result or ILD_BLEND25;\r
  if dsBlend50 in DrawingStyle then\r
     Result := Result or ILD_BLEND50;\r
  if dsTransparent in DrawingStyle then\r
     Result := Result or ILD_TRANSPARENT\r
  else\r
  if dsMask in DrawingStyle then\r
     Result := Result or ILD_MASK\r
  {else\r
     Result := Result or ILD_NORMAL}; // ILD_NORMAL = 0\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TImageList.GetHandle]\r
function TImageList.GetHandle: THandle;\r
asm\r
        PUSH     EAX\r
        CALL     HandleNeeded\r
        POP      EAX\r
        MOV      EAX, [EAX].FHandle\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TImageList.GetHandle: THandle;\r
begin\r
  HandleNeeded;\r
  Result := FHandle;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[function TImageList.GetMask]\r
function TImageList.GetMask: HBitmap;\r
var II : TImageInfo;\r
begin\r
  Result := 0;\r
  if FHandle = 0 then Exit;\r
  if ImageList_GetImageInfo( FHandle, 0, II ) then\r
     Result := II.hbmMask;\r
end;\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TImageList.HandleNeeded]\r
function TImageList.HandleNeeded: Boolean;\r
const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR,\r
                 ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24,\r
                 ILC_COLOR32, ILC_COLORDDB );\r
asm\r
        MOV      ECX, [EAX].FHandle\r
        JECXZ    @@make_handle\r
        MOV      AL, 1\r
        RET\r
@@make_handle:\r
        MOV      ECX, [EAX].fImgWidth\r
        JECXZ    @@ret_ECX\r
        MOV      EDX, ECX\r
        MOV      ECX, [EAX].fImgHeight\r
        JECXZ    @@ret_ECX\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
\r
        PUSH     [EBX].FAllocBy\r
        PUSH     0\r
        MOVZX    EAX, [EBX].FColors\r
        MOVZX    EAX, byte ptr [ColorFlags+EAX]\r
        CMP      [EBX].FMasked, 0\r
        JZ       @@flags_ready\r
        {$IFDEF PARANOIA}\r
        DB $0C, $01\r
        {$ELSE}\r
        OR AL, 1\r
        {$ENDIF}\r
@@flags_ready:\r
        PUSH     EAX\r
        PUSH     ECX\r
        PUSH     EDX\r
        CALL     ImageList_Create\r
        MOV      [EBX].FHandle, EAX\r
        XCHG     ECX, EAX\r
        POP      EBX\r
@@ret_ECX:\r
        TEST     ECX, ECX\r
        SETNZ    AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TImageList.HandleNeeded: Boolean;\r
const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR,\r
                 ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24,\r
                 ILC_COLOR32, ILC_COLORDDB, 0 );\r
var Flags : DWord;\r
begin\r
  Result := True;\r
  if FHandle <> 0 then Exit;\r
  Result := False;\r
  if ImgWidth = 0 then Exit;\r
  if ImgHeight = 0 then Exit;\r
  Flags := ColorFlags[ FColors ];\r
  if Masked then\r
     Flags := Flags or ILC_MASK;\r
  FHandle := ImageList_Create( ImgWidth, ImgHeight, Flags, 0, FAllocBy );\r
  if fBkColor <> clNone then\r
    SetBkColor( fBkColor );\r
  Result := FHandle <> 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[function TImageList.ImgRect]\r
function TImageList.ImgRect(Idx: Integer): TRect;\r
var II : TImageInfo;\r
begin\r
  Result := MakeRect( 0, 0, 0, 0 );\r
  if FHandle = 0 then Exit;\r
  if ImageList_GetImageInfo( FHandle, Idx, II ) then\r
     Result := II.rcImage;\r
end;\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TImageList.LoadBitmap]\r
function TImageList.LoadBitmap(ResourceName: PChar;\r
  TranspColor: TColor): Boolean;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        XCHG     EAX, ECX //TranspColor\r
        PUSH     EDX\r
        CMP      EAX, clNone\r
        JNE      @@2rgb\r
        OR       EAX, -1\r
        JMP      @@tranColorReady\r
@@2rgb:\r
        CALL     Color2RGB\r
@@tranColorReady:\r
        POP      EDX\r
        PUSH     EAX\r
        PUSH     [EBX].fAllocBy\r
        PUSH     [EBX].fImgWidth\r
        PUSH     EDX\r
        PUSH     [hInstance]\r
        CALL     ImageList_LoadBitmap\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        XCHG     EDX, EAX\r
        XCHG     EAX, EBX\r
        CALL     SetHandle\r
        MOV      AL, 1\r
@@exit: POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TImageList.LoadBitmap(ResourceName: PChar;\r
  TranspColor: TColor): Boolean;\r
var NewHandle : THandle;\r
    TranColr: TColor;\r
begin\r
  TranColr := TranspColor;\r
  if TranColr = clNone then TranColr := TColor( CLR_NONE )\r
  else TranColr := Color2RGB( TranColr );\r
  NewHandle := ImageList_LoadBitmap( hInstance, ResourceName,\r
            ImgWidth, AllocBy, TranColr );\r
  //ImageList_GetIconSize( NewHandle, fImgWidth, fImgHeight );\r
  Result := NewHandle <> 0;\r
  if Result then\r
     Handle := NewHandle;\r
  ImageList_GetIconSize( fHandle, FImgWidth, FImgHeight );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[function TImageList.LoadFromFile]\r
function TImageList.LoadFromFile(FileName: PChar; TranspColor: TColor;\r
  ImgType: TImageType): Boolean;\r
const ImgTypes:array[ TImageType ] of DWord = ( IMAGE_BITMAP, IMAGE_ICON, IMAGE_CURSOR );\r
var NewHandle : THandle;\r
    TranspFlag : DWord;\r
begin\r
  TranspFlag := 0;\r
  if TranspColor <> clNone then\r
     TranspFlag := LR_LOADTRANSPARENT;\r
  NewHandle := ImageList_LoadImage( hInstance, FileName, ImgWidth, AllocBy, Color2RGB( TranspColor ),\r
                                    ImgTypes[ ImgType ], LR_LOADFROMFILE or TranspFlag );\r
  Result := NewHandle <> 0;\r
  if Result then\r
     Handle := NewHandle;\r
end;\r
\r
//*\r
//[function TImageList.LoadSystemIcons]\r
function TImageList.LoadSystemIcons(SmallIcons: Boolean): Boolean;\r
var NewHandle : THandle;\r
    FileInfo : TSHFileInfo;\r
    Flags : DWord;\r
begin\r
  OleInit;\r
  Flags := SHGFI_SYSICONINDEX;\r
  if SmallIcons then\r
     Flags := Flags or SHGFI_SMALLICON;\r
  NewHandle := SHGetFileInfo( '', 0, FileInfo, Sizeof( FileInfo ), Flags );\r
  Result := NewHandle <> 0;\r
  if Result then\r
  begin\r
     Handle := NewHandle;\r
     FShareImages := True;\r
  end;\r
end;\r
\r
//*\r
//[function TImageList.Merge]\r
function TImageList.Merge(Idx: Integer; ImgList2: PImageList; Idx2, X,\r
  Y: Integer): PImageList;\r
var L : THandle;\r
begin\r
  Result := nil;\r
  //if FHandle = 0 then Exit;\r
  L := ImageList_Merge( FHandle, Idx, ImgList2.Handle, Idx2, X, Y );\r
  if L <> 0 then\r
  begin\r
     Result := NewImageList( fControl );\r
     Result.Handle := L;\r
  end;\r
end;\r
\r
//*\r
//[function TImageList.Replace]\r
function TImageList.Replace(Idx: Integer; Bmp, Msk: HBitmap): Boolean;\r
begin\r
  Result := False;\r
  if FHandle = 0 then Exit;\r
  Result := ImageList_Replace( FHandle, Idx, Bmp, Msk );\r
end;\r
\r
//*\r
//[function TImageList.ReplaceIcon]\r
function TImageList.ReplaceIcon(Idx: Integer; Ico: HIcon): Boolean;\r
begin\r
  Result := False;\r
  if FHandle = 0 then Exit;\r
  Result := ImageList_ReplaceIcon( FHandle, Idx, Ico ) >= 0;\r
end;\r
\r
//*\r
//[procedure TImageList.SetAllocBy]\r
procedure TImageList.SetAllocBy(const Value: Integer);\r
begin\r
  if FHandle <> 0 then Exit;\r
     // AllocBy can be changed only before adding images\r
     // and creating image list handle\r
  FAllocBy := Value;\r
end;\r
\r
//*\r
//[procedure TImageList.SetBkColor]\r
procedure TImageList.SetBkColor(const Value: TColor);\r
begin\r
  fBkColor := Value;\r
  if fHandle <> 0 then\r
    ImageList_SetBkColor( FHandle, Color2RGB( Value ) );\r
end;\r
\r
//*\r
//[procedure TImageList.SetColors]\r
procedure TImageList.SetColors(const Value: TImageListColors);\r
begin\r
  if FHandle <> 0 then Exit;\r
  FColors := Value;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TImageList.SetHandle]\r
procedure TImageList.SetHandle(const Value: THandle);\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      ECX, [EBX].FHandle\r
        CMP      ECX, EDX\r
        JZ       @@exit\r
        JECXZ    @@set_handle\r
        CMP      [EBX].fShareImages, 0\r
        JNZ      @@set_handle\r
        PUSH     EDX\r
        PUSH     ECX\r
        CALL     ImageList_Destroy\r
        POP      EDX\r
\r
@@set_handle:\r
        MOV      [EBX].FHandle, EDX\r
        TEST     EDX, EDX\r
        JZ       @@set_sz0\r
        LEA      EAX, [EBX].FImgHeight\r
        PUSH     EAX\r
        LEA      EAX, [EBX].FImgWidth\r
        PUSH     EAX\r
        PUSH     EDX\r
        CALL     ImageList_GetIconSize\r
        JMP      @@exit\r
\r
@@set_sz0:\r
        MOV      [EBX].fImgWidth, EDX\r
        MOV      [EBX].fImgHeight, EDX\r
\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TImageList.SetHandle(const Value: THandle);\r
begin\r
  if FHandle = Value then Exit;\r
  if (FHandle <> 0) and not FShareImages then\r
     ImageList_Destroy( FHandle );\r
  FHandle := Value;\r
  if FHandle <> 0 then\r
     ImageList_GetIconSize( FHandle, FImgWidth, FImgHeight )\r
  else\r
  begin\r
    FImgWidth := 0;\r
    FImgHeight := 0;\r
  end;\r
  //FBkColor := ImageList_GetBkColor( FHandle );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TImageList.SetImgHeight]\r
procedure TImageList.SetImgHeight(const Value: Integer);\r
begin\r
  if FHandle <> 0 then Exit;\r
  FImgHeight := Value;\r
end;\r
\r
//[procedure TImageList.SetImgWidth]\r
procedure TImageList.SetImgWidth(const Value: Integer);\r
begin\r
  if FHandle <> 0 then Exit;\r
  FImgWidth := Value;\r
end;\r
\r
//[procedure TImageList.SetMasked]\r
procedure TImageList.SetMasked(const Value: Boolean);\r
begin\r
  if FHandle <> 0 then Exit;\r
  FMasked := Value;\r
end;\r
\r
//*\r
//[function TImageList.GetOverlay]\r
function TImageList.GetOverlay(Idx: TImgLOVrlayIdx): Integer;\r
begin\r
  Result := fOverlay[ Idx ];\r
end;\r
\r
//[procedure TImageList.SetOverlay]\r
procedure TImageList.SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer);\r
begin\r
  if ImageList_SetOverlayImage( fHandle, Value, Idx shl 8 ) then\r
    fOverlay[ Idx ] := Value;\r
end;\r
\r
//[procedure TImageList.StretchDraw]\r
procedure TImageList.StretchDraw(Idx: Integer; DC: HDC; const Rect: TRect);\r
begin\r
  if FHandle = 0 then Exit;\r
  ImageList_DrawEx( FHandle, Idx, DC, Rect.Left, Rect.Top,\r
                    Rect.Right- Rect.Left, Rect.Bottom-Rect.Top,\r
                    BkColor, BlendColor, GetDrawStyle );\r
end;\r
\r
//*\r
//[function GetImgListSize]\r
function GetImgListSize( Sender: PControl; Size: Integer ): PImageList;\r
begin\r
  if Size > 16 then\r
    Result := Sender.fCtlImageListNormal\r
  else\r
    Result := Sender.fCtlImageListSml;\r
  if Result <> nil then\r
  begin\r
    if Result.fImgWidth = 0 then\r
      Result.ImgWidth := Size;\r
    if Result.fImgHeight = 0 then\r
      Result.ImgHeight := Size;\r
    //if (Result.FImgWidth <> Size) or (Result.FImgHeight <> Size) then\r
    //  Result := nil;\r
  end;\r
  if Result = nil then\r
  begin\r
    Result := Sender.fImageList;\r
    while Result <> nil do\r
    begin\r
      if (Result.FImgWidth = Size) and (Result.FImgHeight = Size) then\r
        break;\r
      Result := Result.fNext;\r
    end;\r
  end;\r
end;\r
\r
//*\r
//[function TControl.GetImgListIdx]\r
function TControl.GetImgListIdx(const Index: Integer): PImageList;\r
begin\r
  if Index <> 0 then\r
    Result := GetImgListSize( @Self, Index )\r
  else\r
  begin\r
    Result := fCtlImgListState;\r
    if Result = nil then\r
    begin\r
      Result := fImageList;\r
      while Result <> nil do\r
      begin\r
        if (Result <> GetImgListIdx( 16 )) and (Result <> GetImgListIdx( 32 )) then\r
           break;\r
        Result := Result.fNext;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//*\r
//[procedure TControl.SetImgListIdx]\r
procedure TControl.SetImgListIdx(const Index: Integer;\r
  const Value: PImageList);\r
begin\r
\r
  if Value <> nil then\r
  begin\r
    if Index <> 0 then\r
    if (Value.ImgWidth = 0) or (Value.ImgHeight = 0) then\r
    begin\r
      Value.ImgWidth := Index;\r
      Value.ImgHeight := Index;\r
    end;\r
  end;\r
\r
  case Index of\r
  32: fCtlImageListNormal := Value;\r
  16: fCtlImageListSml := Value;\r
  else fCtlImgListState := Value;\r
  end;\r
  ApplyImageLists2Control( @Self );\r
end;\r
\r
{ -- list view -- }\r
\r
//[function WndProcEndLabelEdit]\r
function WndProcEndLabelEdit( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var NMhdr: PNMHdr;\r
    LVDisp: PLVDispInfo;\r
    {$IFNDEF _FPC}\r
    {$IFNDEF _D2}\r
    {$IFDEF UNICODE_CTRLS}\r
    LVDispW: PLVDispInfoW;\r
    {$ENDIF UNICODE_CTRLS}\r
    {$ENDIF _D2}\r
    {$ENDIF _FPC}\r
    Flag: Boolean;\r
begin\r
  Result := False;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NMHdr := Pointer( Msg.lParam );\r
    case NMHdr.code of\r
      LVN_ENDLABELEDIT {$IFDEF UNICODE_CTRLS}, LVN_ENDLABELEDITW {$ENDIF UNICODE_CTRLS}:\r
        begin\r
          LVDisp := Pointer( Msg.lParam );\r
          Result := True;\r
          if LVDisp.item.pszText = nil then Exit;\r
          Rslt := 1;\r
          if assigned( Self_.fOnEditLVItem ) then\r
          begin\r
          {$IFNDEF _FPC}\r
          {$IFNDEF _D2}\r
          {$IFDEF UNICODE_CTRLS}\r
            if NMHdr.code = LVN_ENDLABELEDITW then\r
            begin\r
              LVDispW := Pointer( LVDisp );\r
              Flag := Self_.fOnEditLVItem( Self_, LVDispW.item.iItem,\r
                   LVDispW.item.iSubItem, PChar( LVDispW.item.pszText ) );\r
            end else\r
          {$ENDIF UNICODE_CTRLS}\r
          {$ENDIF _D2}\r
          {$ENDIF _FPC}\r
            Flag := Self_.fOnEditLVItem( Self_, LVDisp.item.iItem,\r
                             LVDisp.item.iSubItem, LVDisp.item.pszText );\r
            if Flag then Rslt := 1\r
                    else Rslt := 0;\r
          end;\r
        end;\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnEditLVItem]\r
procedure TControl.SetOnEditLVItem(const Value: TOnEditLVItem);\r
begin\r
  fOnEditLVITem := Value;\r
  AttachProc( WndProcEndLabelEdit );\r
end;\r
\r
//*\r
//[procedure TControl.LVColAdd]\r
procedure TControl.LVColAdd(const aText: String; aalign: TTextAlign;\r
  aWidth: Integer);\r
begin\r
////////////////////////////////////////////////////\r
//LVColInsert( fLVColCount + 1, aText, aalign, aWidth );\r
//////////////////////////////////////////////////////\r
  LVColInsert( fLVColCount, aText, aalign, aWidth );// 21.10.2001\r
  ////////////////////////////////////////////////////\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[procedure TControl.LVColAddW]\r
procedure TControl.LVColAddW(const aText: WideString; aalign: TTextAlign;\r
  aWidth: Integer);\r
begin\r
  LVColInsertW( fLVColCount, aText, aalign, aWidth );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//****************** changed by Mike Gerasimov\r
//[procedure TControl.LVColInsert]\r
procedure TControl.LVColInsert(ColIdx: Integer; const aText: String;\r
  aAlign: TTextAlign; aWidth: Integer);\r
var LVColData: TLVColumn;\r
begin\r
  LVColData.mask := LVCF_FMT or LVCF_TEXT;\r
  if ImageListSmall <> nil then\r
    LVColData.mask := LVColData.mask; // or LVCF_IMAGE ;\r
  LVColData.iImage := -1;\r
  LVColData.fmt := Ord( aAlign );\r
  if aWidth < 0 then\r
  begin\r
    aWidth := -aWidth;\r
    LVColData.fmt := LVColData.fmt or LVCFMT_BITMAP_ON_RIGHT;\r
  end;\r
  LVColData.cx := aWidth;\r
  if aWidth > 0 then\r
    LVColData.mask := LVColData.mask or LVCF_WIDTH;\r
  LVColData.pszText := PChar( aText );\r
  if Perform( LVM_INSERTCOLUMN, ColIdx, Integer( @LVColData ) ) >= 0 then\r
    Inc( fLVColCount );\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[procedure TControl.LVColInsertW]\r
procedure TControl.LVColInsertW(ColIdx: Integer; const aText: WideString;\r
  aAlign: TTextAlign; aWidth: Integer);\r
var LVColData: TLVColumnW;\r
begin\r
  LVColData.mask := LVCF_FMT or LVCF_TEXT;\r
  if ImageListSmall <> nil then\r
    LVColData.mask := LVColData.mask; // or LVCF_IMAGE ;\r
  LVColData.iImage := -1;\r
  LVColData.fmt := Ord( aAlign );\r
  if aWidth < 0 then\r
  begin\r
    aWidth := -aWidth;\r
    LVColData.fmt := LVColData.fmt or LVCFMT_BITMAP_ON_RIGHT;\r
  end;\r
  LVColData.cx := aWidth;\r
  if aWidth > 0 then\r
    LVColData.mask := LVColData.mask or LVCF_WIDTH;\r
  LVColData.pszText := PWideChar( aText );\r
  if Perform( LVM_INSERTCOLUMNW, ColIdx, Integer( @LVColData ) ) >= 0 then\r
    Inc( fLVColCount );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[function TControl.GetLVColText]\r
function TControl.GetLVColText(Idx: Integer): String;\r
var Buf: array[ 0..4095 ] of Char;\r
    LC: TLVColumn;\r
begin\r
  LC.mask := LVCF_TEXT;\r
  LC.pszText := @ Buf[ 0 ];\r
  LC.cchTextMax := Sizeof( Buf );\r
  Buf[ 0 ] := #0;\r
  Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );\r
  Result := Buf;\r
end;\r
\r
//[procedure TControl.SetLVColText]\r
procedure TControl.SetLVColText(Idx: Integer; const Value: String);\r
var LC: TLVColumn;\r
begin\r
  FillChar( LC, Sizeof( LC ), 0 ); {Alexey (Lecha2002)}\r
  LC.mask := LVCF_TEXT;\r
  LC.pszText := '';\r
  if Value <> '' then\r
    LC.pszText := @ Value[ 1 ];\r
  Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function TControl.GetLVColTextW]\r
function TControl.GetLVColTextW(Idx: Integer): WideString;\r
var Buf: array[ 0..4095 ] of WideChar;\r
    LC: TLVColumnW;\r
begin\r
  LC.mask := LVCF_TEXT;\r
  LC.pszText := @ Buf[ 0 ];\r
  LC.cchTextMax := High( Buf ) + 1;\r
  Buf[ 0 ] := #0;\r
  Perform( LVM_GETCOLUMNW, Idx, Integer( @ LC ) );\r
  Result := Buf;\r
end;\r
\r
//[procedure TControl.SetLVColTextW]\r
procedure TControl.SetLVColTextW(Idx: Integer; const Value: WideString);\r
var LC: TLVColumnW;\r
begin\r
  FillChar( LC, Sizeof( LC ), 0 );\r
  LC.mask := LVCF_TEXT;\r
  LC.pszText := '';\r
  if Value <> '' then\r
    LC.pszText := @ Value[ 1 ];\r
  Perform( LVM_SETCOLUMNW, Idx, Integer( @ LC ) );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[function TControl.GetLVColalign]\r
function TControl.GetLVColalign(Idx: Integer): TTextAlign;\r
const Formats: array[ 0..2 ] of TTextAlign = ( taLeft, taRight, taCenter );\r
var LC: TLVColumn;\r
begin\r
  FillChar( LC, Sizeof( LC ), 0 ); {Alexey (Lecha2002)}\r
  LC.mask := LVCF_FMT;\r
  Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );\r
  Result := Formats[ LC.fmt and LVCFMT_JUSTIFYMASK ];\r
end;\r
\r
//[procedure TControl.SetLVColalign]\r
procedure TControl.SetLVColalign(Idx: Integer; const Value: TTextAlign);\r
const FormatFlags: array[ TTextAlign ] of BYTE = ( LVCFMT_LEFT, LVCFMT_RIGHT,\r
      LVCFMT_CENTER );\r
var LC: TLVColumn;\r
begin\r
  FillChar( LC, Sizeof( LC ), 0 ); {Alexey (Lecha2002)}\r
  LC.mask := LVCF_FMT;\r
  Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );\r
  LC.fmt := LC.fmt and not LVCFMT_JUSTIFYMASK or FormatFlags[ Value ];\r
  Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );\r
end;\r
\r
//[function TControl.GetLVColEx]\r
function TControl.GetLVColEx(Idx: Integer; const Index: Integer): Integer;\r
var LC: TLVColumn;\r
begin\r
  FillChar( LC, Sizeof( LC ), 0 ); {Alexey (Lecha2002)}\r
  LC.mask := LoWord( Index );\r
  Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );\r
  Result := PDWORD( Integer( @ LC ) + HiWord( Index ) )^;\r
end;\r
\r
//********************** changed by Mike Gerasimov\r
//[procedure TControl.SetLVColEx]\r
procedure TControl.SetLVColEx(Idx: Integer; const Index: Integer;\r
  const Value: Integer);\r
var LC: TLVColumn;\r
begin\r
  FillChar(LC,SizeOf(LC),0);                                    // Added Line\r
  LC.mask := LoWord( Index );\r
  if HiWord( Index ) = 24 then                                  // Added Line\r
   begin                                                        // Added Line\r
    LC.mask := LC.mask or LVCF_FMT;                             // Added Line\r
    if Value <>-1 Then                                          // Added Line\r
    LC.fmt := LC.fmt or LVCFMT_IMAGE or LVCFMT_COL_HAS_IMAGES;  // Added Line\r
   end;\r
  PDWORD( Integer( @ LC ) + HiWord( Index ) )^ := Value;\r
  Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );\r
end;\r
\r
//*\r
//[function TControl.LVAdd]\r
function TControl.LVAdd(const aText: String; ImgIdx: Integer;\r
  State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer;\r
  Data: DWORD): Integer;\r
begin\r
  Result := LVInsert( MaxInt {Count}, aText, ImgIdx, State, StateImgIdx, OverlayImgIdx, Data );\r
end;\r
\r
//*\r
//[function TControl.LVInsert]\r
function TControl.LVInsert(Idx: Integer; const aText: String;\r
  ImgIdx: Integer; State: TListViewItemState;  StateImgIdx, OverlayImgIdx: Integer;\r
  Data: DWORD): Integer;\r
const\r
  LVM_REDRAWITEMS         = LVM_FIRST + 21;\r
var LVI: TLVItem;\r
begin\r
  LVI.mask := LVIF_TEXT or LVIF_IMAGE or LVIF_PARAM or LVIF_STATE\r
              or LVIF_DI_SETITEM;\r
  LVI.iItem := Idx;\r
  LVI.iSubItem := 0;\r
  LVI.state := 0;\r
  if lvisBlend in State then\r
     LVI.state := LVIS_CUT;\r
  if lvisHighlight in State then\r
     LVI.state := LVI.state or LVIS_DROPHILITED;\r
  if lvisFocus in State then\r
     LVI.state := LVI.state or LVIS_FOCUSED;\r
  if lvisSelect in State then\r
     LVI.state := LVI.state or LVIS_SELECTED;\r
  LVI.stateMask := $FFFF;\r
  if StateImgIdx <> 0 then\r
     LVI.state := LVI.state or ((StateImgIdx and $F) shl 12);\r
  if OverlayImgIdx <> 0 then\r
     LVI.state := LVI.state or ((OverlayImgIdx and $F) shl 8);\r
  LVI.pszText := PChar( aText );\r
  LVI.iImage := ImgIdx;\r
  LVI.lParam := Data;\r
  Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) );\r
  //Perform( LVM_REDRAWITEMS, Idx, Idx );\r
end;\r
\r
//*\r
//[procedure TControl.LVSetItem]\r
procedure TControl.LVSetItem(Idx, Col: Integer; const aText: String;\r
  ImgIdx: Integer; State: TListViewItemState; StateImgIdx,\r
  OverlayImgIdx: Integer; Data: DWORD);\r
var LVI: TLVItem;\r
    I: Integer;\r
begin\r
  LVI.mask := LVIF_TEXT or {LVIF_STATE or} LVIF_DI_SETITEM;\r
  if Col = 0 then\r
  begin\r
    LVI.mask := LVIF_TEXT or LVIF_STATE or LVIF_PARAM\r
              or LVIF_DI_SETITEM;\r
    if ImgIdx <> I_SKIP then\r
       LVI.mask := LVI.mask or LVIF_IMAGE;\r
  end;\r
  if ImgIdx < I_SKIP then\r
    LVI.mask := LVIF_TEXT or LVIF_DI_SETITEM;\r
  LVI.iItem := Idx;\r
  LVI.iSubItem := Col;\r
  LVI.state := 0;\r
  if lvisBlend in State then\r
     LVI.state := LVIS_CUT;\r
  if lvisHighlight in State then\r
     LVI.state := LVI.state or LVIS_DROPHILITED;\r
  if lvisFocus in State then\r
     LVI.state := LVI.state or LVIS_FOCUSED;\r
  if lvisSelect in State then\r
     LVI.state := LVI.state or LVIS_SELECTED;\r
  LVI.stateMask := $FFFF;\r
  if StateImgIdx <> 0 then\r
     LVI.state := LVI.state or ((StateImgIdx and $F) shl 12);\r
  if StateImgIdx < 0 {= I_SKIP} then\r
     LVI.stateMask := $F0FF;\r
  if OverlayImgIdx <> 0 then\r
     LVI.state := LVI.state or ((OverlayImgIdx and $F) shl 8);\r
  if OverlayImgIdx < 0 {=I_SKIP} then\r
     LVI.stateMask := LVI.stateMask and $FFF;\r
  LVI.pszText := PChar( aText );\r
  LVI.iImage := ImgIdx;\r
  LVI.lParam := Data;\r
  I := Perform( LVM_SETITEM, 0, Integer( @LVI ) );\r
  if (I = 0) and (Col = 0) then\r
    Assert( False, 'Can not set item ' );\r
end;\r
\r
//*\r
//[procedure LVGetItem]\r
procedure LVGetItem( Sender: PControl; Idx, Col: Integer; var LVI: TLVItem;\r
          TextBuf: PChar; TextBufSize: Integer );\r
begin\r
  LVI.mask := LVIF_STATE or LVIF_PARAM or LVIF_IMAGE;\r
  if Col > 0 then\r
  if not (lvoSubItemImages in Sender.fLVOptions) then\r
    LVI.mask := LVIF_STATE or LVIF_PARAM;\r
  LVI.iItem := Idx;\r
  LVI.iSubItem := Col;\r
  LVI.pszText := TextBuf;\r
  LVI.cchTextMax := TextBufSize;\r
  if TextBufSize <> 0 then\r
    LVI.mask := LVI.mask or LVIF_TEXT;\r
  Sender.Perform( LVM_GETITEM, 0, Integer( @LVI ) );\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[procedure LVGetItemW]\r
procedure LVGetItemW( Sender: PControl; Idx, Col: Integer; var LVI: TLVItemW;\r
          TextBuf: PWideChar; TextBufSize: Integer );\r
begin\r
  LVI.mask := LVIF_STATE or LVIF_PARAM or LVIF_IMAGE;\r
  if Col > 0 then\r
  if not (lvoSubItemImages in Sender.fLVOptions) then\r
    LVI.mask := LVIF_STATE or LVIF_PARAM;\r
  LVI.iItem := Idx;\r
  LVI.iSubItem := Col;\r
  LVI.pszText := TextBuf;\r
  LVI.cchTextMax := TextBufSize;\r
  if TextBufSize <> 0 then\r
    LVI.mask := LVI.mask or LVIF_TEXT;\r
  Sender.Perform( LVM_GETITEMW, 0, Integer( @LVI ) );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//*\r
//[function TControl.LVGetItemImgIdx]\r
function TControl.LVGetItemImgIdx(Idx: Integer): Integer;\r
var LVI: TLVItem;\r
begin\r
  LVI.iImage := -1;//= Result if image is not assigned {Andrzej Kubaszek}\r
  LVGetItem( @Self, Idx, 0, LVI, nil, 0 );\r
  Result := LVI.iImage;\r
end;\r
\r
//*\r
//[procedure TControl.LVSetItemImgIdx]\r
procedure TControl.LVSetItemImgIdx(Idx: Integer; const Value: Integer);\r
var LVI: TLVItem;\r
begin\r
  LVGetItem( @Self, Idx, 0, LVI, nil, 0 );\r
  LVI.iImage := Value;\r
  Perform( LVM_SETITEM, 0, Integer( @LVI ) );\r
end;\r
\r
//*\r
//[function TControl.LVGetItemText]\r
function TControl.LVGetItemText(Idx, Col: Integer): String;\r
var LVI: TLVItem;\r
    TextBuf: PChar;\r
    BufSize: DWORD;\r
begin\r
  BufSize := 0;\r
  TextBuf := nil;\r
  repeat\r
    if TextBuf <> nil then\r
       FreeMem( TextBuf );\r
    BufSize := BufSize * 2 + 100; // to vary in asm version\r
    GetMem( TextBuf, BufSize );\r
    TextBuf[ 0 ] := #0;\r
    LVGetItem( @Self, Idx, Col, LVI, TextBuf, BufSize );\r
  until StrLen( TextBuf ) < BufSize - 1;\r
  Result := TextBuf;\r
  FreeMem( TextBuf );\r
end;\r
\r
//*\r
//[procedure TControl.LVSetItemText]\r
procedure TControl.LVSetItemText(Idx, Col: Integer; const Value: String);\r
var LVI: TLVItem;\r
begin\r
  LVI.iSubItem := Col;\r
  LVI.pszText := PChar( Value );\r
  Perform( LVM_SETITEMTEXT, Idx, Integer( @LVI ) );\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function TControl.LVGetItemTextW]\r
function TControl.LVGetItemTextW(Idx, Col: Integer): WideString;\r
var LVI: TLVItemW;\r
    TextBuf: PWideChar;\r
    BufSize: DWORD;\r
begin\r
  BufSize := 0;\r
  TextBuf := nil;\r
  repeat\r
    if TextBuf <> nil then\r
       FreeMem( TextBuf );\r
    BufSize := BufSize * 2 + 100; // to vary in asm version\r
    GetMem( TextBuf, BufSize * 2 );\r
    TextBuf[ 0 ] := #0;\r
    LVGetItemW( @Self, Idx, Col, LVI, TextBuf, BufSize );\r
  until DWORD( WStrLen( TextBuf ) ) < BufSize - 1;\r
  Result := TextBuf;\r
  FreeMem( TextBuf );\r
end;\r
\r
//[procedure TControl.LVSetItemTextW]\r
procedure TControl.LVSetItemTextW(Idx, Col: Integer;\r
  const Value: WideString);\r
var LVI: TLVItemW;\r
begin\r
  LVI.iSubItem := Col;\r
  LVI.pszText := PWideChar( Value );\r
  Perform( LVM_SETITEMTEXTW, Idx, Integer( @LVI ) );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//*\r
//[procedure TControl.LVColDelete]\r
procedure TControl.LVColDelete(ColIdx: Integer);\r
begin\r
  Perform( LVM_DELETECOLUMN, ColIdx, 0 );\r
  if fLVColCount > 0 then\r
    Dec( fLVColCount );\r
end;\r
\r
//*\r
//[procedure TControl.SetLVOptions]\r
procedure TControl.SetLVOptions(const Value: TListViewOptions);\r
begin\r
  if fLVOptions = Value then Exit;\r
  fLVOptions := Value;\r
  ApplyImageLists2ListView( @Self );\r
  PostMessage( fHandle, WM_SIZE, 0, 0 ); // to restore scrollers (otherwise its are lost)\r
end;\r
\r
//*\r
//[procedure TControl.SetLVStyle]\r
procedure TControl.SetLVStyle(const Value: TListViewStyle);\r
begin\r
  if fLVStyle = Value then Exit;\r
  fLVStyle := Value;\r
  ApplyImageLists2ListView( @Self );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.Perform]\r
function TControl.Perform(msgcode: DWORD; wParam, lParam: Integer): Integer; stdcall;\r
asm\r
        PUSH     [lParam]\r
        PUSH     [wParam]\r
        PUSH     [msgcode]\r
        MOV      EAX, [EBP+8]\r
        CALL     TControl.GetWindowHandle\r
        PUSH     EAX\r
        CALL     Windows.SendMessage\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.Perform(msgcode: DWORD; wParam, lParam: Integer): Integer; stdcall;\r
begin\r
  Result := SendMessage( GetWindowHandle, msgcode, wParam, lParam );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.GetChildCount]\r
function TControl.GetChildCount: Integer;\r
asm\r
        MOV      EAX, [EAX].fChildren\r
        MOV      EAX, [EAX].TList.fCount\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.GetChildCount: Integer;\r
begin\r
  Result := fChildren.fCount;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.LVDelete]\r
procedure TControl.LVDelete(Idx: Integer);\r
begin\r
  Perform( LVM_DELETEITEM, Idx, 0 );\r
end;\r
\r
//[procedure TControl.LVEditItemLabel]\r
procedure TControl.LVEditItemLabel(Idx: Integer);\r
begin\r
  Perform( LVM_EDITLABEL, Idx, 0 );\r
end;\r
\r
//*\r
//[function TControl.LVItemRect]\r
function TControl.LVItemRect(Idx: Integer; Part: TGetLVItemPart): TRect;\r
const Parts: array[ TGetLVItemPart ] of Byte = (\r
             LVIR_BOUNDS, LVIR_ICON, LVIR_LABEL, LVIR_SELECTBOUNDS );\r
begin\r
  Result := MakeRect( Parts[ Part ], 0, 0, 0 );\r
  if Perform( LVM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then\r
     Result := MakeRect( 0, 0, 0, 0 );\r
end;\r
\r
//[function TControl.LVSubItemRect]\r
function TControl.LVSubItemRect(Idx, ColIdx: Integer): TRect;\r
var Hdr: HWnd;\r
    R, R1: TRect;\r
    ClassNameBuf: array[ 0..31 ] of Char;\r
    HdItem: THDItem;\r
begin\r
  Result.Top := ColIdx; // + 1; error in MSDN ?\r
  Result.Left := LVIR_BOUNDS;\r
  if Perform( LVM_GETSUBITEMRECT, Idx, Integer( @Result ) ) <> 0 then\r
    Exit;\r
  Result := MakeRect( 0, 0, 0, 0 );\r
  if ColIdx > 0 then R := LVSubItemRect( Idx, ColIdx - 1 )\r
                else R := LVItemRect( Idx, lvipBounds );\r
  if (R.Left = 0) and (R.Right = 0) and\r
     (R.Top = 0) and (R.Bottom = 0) then Exit;\r
  Hdr := GetWindow( GetWindowHandle, GW_CHILD );\r
  if Hdr <> 0 then\r
  begin\r
    if GetClassName( Hdr, ClassNameBuf, 32 ) > 0 then\r
    if ClassNameBuf = 'SysHeader32' then\r
    begin\r
      if ColIdx > 0 then R.Left := R.Right\r
                    else R.Left := 0;\r
      R1.Top := 0; R1.Left := 0;\r
      Windows.ClientToScreen( Hdr,{$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} );\r
      Windows.ScreenToClient( fHandle, {$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} );\r
      R1 := R;\r
      HdItem.Mask := HDI_WIDTH;\r
      if SendMessage( Hdr, HDM_GETITEM, ColIdx, Integer( @HdItem ) ) = 0 then Exit;\r
      R1.Right := R1.Left + HdItem.cxy;\r
      Result := R1;\r
    end;\r
  end;\r
end;\r
\r
//*\r
//[function TControl.LVGetItemPos]\r
function TControl.LVGetItemPos(Idx: Integer): TPoint;\r
begin\r
  Perform( LVM_GETITEMPOSITION, Idx, Integer( @Result ) );\r
end;\r
\r
//*\r
//[procedure TControl.LVSetItemPos]\r
procedure TControl.LVSetItemPos(Idx: Integer; const Value: TPoint);\r
begin\r
  Perform( LVM_SETITEMPOSITION32, Idx, Integer( @Value ) );\r
end;\r
\r
//*\r
//[function TControl.LVItemAtPos]\r
function TControl.LVItemAtPos(X, Y: Integer): Integer;\r
var Dummy: TWherePosLVItem;\r
begin\r
  Result := LVItemAtPosEx( X, Y, Dummy );\r
end;\r
\r
//*\r
//[function TControl.LVItemAtPosEx]\r
function TControl.LVItemAtPosEx(X, Y: Integer;\r
  var Where: TWherePosLVItem): Integer;\r
var HTI: TLVHitTestInfo;\r
begin\r
  HTI.pt.x := X;\r
  HTI.pt.y := Y;\r
  Perform( LVM_HITTEST, 0, Integer( @HTI ) );\r
  Result := HTI.iItem;\r
  Where := lvwpOnColumn;\r
  if HTI.flags = LVHT_ONITEMICON then\r
     Where := lvwpOnIcon\r
  else\r
  if HTI.flags = LVHT_ONITEMLABEL then\r
     Where := lvwpOnLabel\r
  else\r
  if HTI.flags = LVHT_ONITEMSTATEICON then\r
     Where := lvwpOnStateIcon\r
  else\r
  if HTI.flags = LVHT_ONITEM then\r
     Where := lvwpOnItem;\r
end;\r
\r
//[procedure TControl.LVMakeVisible]\r
procedure TControl.LVMakeVisible(Item: Integer; PartiallyOK: Boolean);\r
begin\r
  if Item < 0 then Exit;\r
  Perform( LVM_ENSUREVISIBLE, Item, Integer( PartiallyOK ) );\r
end;\r
\r
//*\r
//[procedure TControl.LVSetColorByIdx]\r
procedure TControl.LVSetColorByIdx(const Index: Integer;\r
  const Value: TColor);\r
var MsgCode: Integer;\r
    ColorValue: TColor;\r
begin\r
  MsgCode := Index + 1;\r
  case MsgCode of\r
  LVM_SETTEXTCOLOR:  fTextColor := Value;\r
  LVM_SETTEXTBKCOLOR: fLVTextBkColor := Value;\r
  LVM_SETBKCOLOR: fColor := Value;\r
  end;\r
  ColorValue := Color2RGB( Value );\r
  Perform( MsgCode, 0, ColorValue );\r
end;\r
\r
{$IFDEF F_P}\r
//[function TControl.LVGetColorByIdx]\r
function TControl.LVGetColorByIdx(const Index: Integer): TColor;\r
begin\r
  CASE Index OF\r
  LVM_SETTEXTCOLOR:   Result := fTextColor;\r
  LVM_SETTEXTBKCOLOR: Result := fLVTextBkColor;\r
  LVM_SETBKCOLOR:     Result := fColor;\r
  END;\r
end;\r
{$ENDIF F_P}\r
\r
//*\r
//[function TControl.GetIntVal]\r
function TControl.GetIntVal(const Index: Integer): Integer;\r
begin\r
  Result := GetItemVal( 0, Index );\r
end;\r
\r
//*\r
//[procedure TControl.SetIntVal]\r
procedure TControl.SetIntVal(const Index, Value: Integer);\r
begin\r
  SetItemVal( Value, Index, 0 );\r
end;\r
\r
//*\r
//[function TControl.GetItemVal]\r
function TControl.GetItemVal(Item: Integer; const Index: Integer): Integer;\r
begin\r
  Result := Perform( LoWord(Index), Item, 0 );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.SetItemVal]\r
procedure TControl.SetItemVal(Item: Integer; const Index: Integer; const Value: Integer);\r
asm\r
        PUSH     EAX\r
        PUSH     [Value]\r
        PUSH     EDX\r
        MOV      EDX, ECX\r
        SHR      EDX, 16\r
        JNZ      @@1\r
        MOV      EDX, ECX\r
        INC      EDX\r
@@1:\r
        MOV      EBP, EDX\r
        AND      EDX, 7FFFh\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     Perform\r
        MOV      EAX, EBP\r
        ADD      AX, AX\r
        POP      EAX\r
        JNB      @@2\r
        CALL     Invalidate\r
@@2:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.SetItemVal(Item: Integer; const Index: Integer; const Value: Integer);\r
var MsgCode: Integer;\r
begin\r
  MsgCode := HiWord( Index );\r
  if MsgCode = 0 then\r
    MsgCode := Index + 1;\r
  Perform( MsgCode and $7FFF, Item, Value );\r
  if (MsgCode and $8000) <> 0 then\r
    Invalidate;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.GetSBMinMax]\r
function TControl.GetSBMinMax: TPoint;\r
{$IFDEF _D2}\r
var X, Y: Integer;\r
{$ENDIF}\r
begin\r
  if (Handle <> 0) then begin\r
    {$IFDEF _D2}\r
    GetScrollRange(Handle, SB_CTL, X, Y);\r
    Result.X := X;\r
    Result.Y := Y;\r
    {$ELSE}\r
    GetScrollRange(Handle, SB_CTL, Result.X, Result.Y);\r
    {$ENDIF}\r
    Dec(Result.Y, SBPageSize - 1);\r
  end\r
  else\r
    Result := fSBMinMax;\r
end;\r
\r
//[procedure TControl.GetSBPageSize]\r
function TControl.GetSBPageSize: Integer;\r
var\r
  SI: TScrollInfo;\r
begin\r
  FillChar(SI, SizeOf(SI), 0);\r
  SI.cbSize := SizeOf(SI);\r
  SI.fMask := SIF_PAGE;\r
  SBGetScrollInfo(SI);\r
  Result := SI.nPage;\r
end;\r
\r
//[procedure TControl.GetSBPosition]\r
function TControl.GetSBPosition: Integer;\r
begin\r
  Result := GetScrollPos(Handle, SB_CTL);\r
end;\r
\r
//[procedure TControl.SetSBMax]\r
procedure TControl.SetSBMax(Value: Longint);\r
var\r
  P: TPoint;\r
begin\r
  fSBMinMax.Y := Value;\r
  if (Handle <> 0) then begin\r
    P := SBMinMax;\r
    P.Y := Value;\r
    SBMinMax := P;\r
  end;\r
end;\r
\r
//[procedure TControl.SetSBMin]\r
procedure TControl.SetSBMin(Value: Longint);\r
var\r
  P: TPoint;\r
begin\r
  fSBMinMax.X := Value;\r
  if (Handle <> 0) then begin\r
    P := SBMinMax;\r
    P.X := Value;\r
    SBMinMax := P;\r
  end;\r
end;\r
\r
//[procedure TControl.SetSBPageSize]\r
procedure TControl.SetSBPageSize(Value: Integer);\r
var\r
  SI: TScrollInfo;\r
begin\r
  fSBPageSize := Value;\r
  if (Handle <> 0) then begin\r
    FillChar(SI, SizeOf(SI), 0);\r
    SI.cbSize := SizeOf(SI);\r
    SI.fMask := SIF_PAGE or SIF_RANGE;\r
    SBGetScrollInfo(SI);\r
    if (SI.nMax = 0) and (SI.nMin = 0) then\r
      SI.nMax := 1;\r
    SI.nMax := SI.nMax - Integer(SI.nPage) + Value;\r
    SI.nPage := Value;\r
    SBSetScrollInfo(SI);\r
  end;\r
end;\r
\r
//[procedure TControl.SetSBPosition]\r
procedure TControl.SetSBPosition(Value: Integer);\r
begin\r
  fSBPosition := Value;\r
  if (Handle <> 0) then\r
    SetScrollPos(Handle, SB_CTL, Value, True);\r
end;\r
\r
//[procedure TControl.SetSBMinMax]\r
procedure TControl.SetSBMinMax(const Value: TPoint);\r
begin\r
  GetSBMinMax;\r
  if (Handle <> 0) then\r
    SetScrollRange(Handle, SB_CTL, Value.X, Value.Y + SBPageSize - 1, True)\r
  else\r
    fSBMinMax := Value;\r
end;\r
\r
//[procedure TControl.SBSetScrollInfo]\r
function TControl.SBSetScrollInfo(const SI: TScrollInfo): Integer;\r
begin\r
  Result := SetScrollInfo(Handle, SB_CTL, SI, True)\r
end;\r
\r
//[procedure TControl.SBGetScrollInfo]\r
function TControl.SBGetScrollInfo(var SI: TScrollInfo): Boolean;\r
begin\r
  Result := Cardinal(GetScrollInfo(Handle, SB_CTL, SI)) <> 0;\r
end;\r
\r
\r
{ -- OpenSaveDialog -- }\r
\r
//*\r
//[function NewOpenSaveDialog]\r
function NewOpenSaveDialog( const Title, StrtDir: String;\r
         Options: TOpenSaveOptions ): POpenSaveDialog;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := POpenSaveDialog.Create;*){--}\r
  Result.FOptions := Options;\r
  if Options = [] then\r
    Result.FOptions := DefOpenSaveDlgOptions;\r
  Result.fOpenDialog := True;\r
  Result.FTitle := Title;\r
  Result.FInitialDir := StrtDir;\r
end;\r
//[END NewOpenSaveDialog]\r
\r
{ TOpenSaveDialog }\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TOpenSaveDialog.Destroy]\r
destructor TOpenSaveDialog.Destroy;\r
asm     //cmd    //opd\r
        PUSH     EAX\r
        PUSH     0\r
        LEA      EDX, [EAX].FFilter\r
        PUSH     EDX\r
        LEA      EDX, [EAX].FInitialDir\r
        PUSH     EDX\r
        LEA      EDX, [EAX].FDefExtension\r
        PUSH     EDX\r
        LEA      EDX, [EAX].FFileName\r
        PUSH     EDX\r
        LEA      EAX, [EAX].FTitle\r
@@loo:\r
        CALL     System.@LStrClr\r
        POP      EAX\r
        TEST     EAX, EAX\r
        JNZ      @@loo\r
        POP      EAX\r
        CALL     TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TOpenSaveDialog.Destroy;\r
begin\r
  FFilter := '';\r
  FInitialDir := '';\r
  FDefExtension := '';\r
  FFileName := '';\r
  FTitle := '';\r
  {$IFDEF OpenSaveDialog_Extended}\r
  TemplateName := '';\r
  {$ENDIF}\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TOpenSaveDialog.Execute]\r
function TOpenSaveDialog.Execute: Boolean;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
\r
        XOR      ECX, ECX\r
        {$IFDEF OpenSaveDialog_Extended}\r
        PUSH     [EBX].TemplateName\r
        PUSH     [EBX].HookProc\r
        {$ELSE}\r
        PUSH     ECX                      // prepare lpTemplateName = nil\r
        PUSH     ECX                      // prepare lpfnHook = nil\r
        {$ENDIF}\r
        PUSH     EBX                      // prepare lCustData = @Self\r
        MOV      EDX, [EBX].FDefExtension\r
        CALL     EDX2PChar\r
        PUSH     EDX                      // prepare lpstrDefExt = FDefExtension\r
        PUSH     ECX                      // prepare nFileExtension, nFileOffset: Word = 0, 0\r
        // prepare flags:\r
        LEA      EAX, [EBX].FOptions\r
        MOV      EDX, Offset[@@OpenSaveFlags]\r
        {$IFDEF OpenSaveDialog_Extended}\r
        MOV      CL, 14\r
        {$ELSE}\r
        MOV      CL, 12\r
        {$ENDIF}\r
        CALL     MakeFlags\r
        XOR      ECX, ECX\r
        OR       EAX, OFN_EXPLORER or OFN_LONGNAMES or OFN_ENABLESIZING\r
        PUSH     EAX                       // push Flags\r
        PUSH     [EBX].FTitle              // prepare lpstrTitle\r
        PUSH     [EBX].FInitialDir         // prepare lpstrInitialDir\r
        PUSH     ECX                       // prepare nMaxFileTitle = 0\r
        PUSH     ECX                       // prepare lpstrFileTitle = nil\r
        TEST     AH, 2      // MultiSelect?\r
        MOV      EAX, 65520\r
        JNZ      @@1\r
        MOV      AX, MAX_PATH+2\r
@@1:    PUSH     EAX                       // prepare nMaxFile\r
        CALL     System.@GetMem\r
        POP      ECX\r
        PUSH     ECX\r
        PUSH     EAX                       // prepare lpStrFile\r
        XOR      EDX, EDX\r
\r
@@2:    //MOV      [EAX], DL  // clear it initially {Vadim Petrov: it is necessary}\r
        //INC      EAX\r
        //LOOP     @@2\r
\r
        MOV      EDX, [EBX].fFileName // no, fill it initilly by FileName\r
        CALL     EDX2PChar\r
        DEC      ECX // added 5 october 2003 to prevent possible error if FileName too big\r
        CALL     StrLCopy\r
        XOR      EDX, EDX\r
\r
        PUSH     [EBX].FFilterIndex        // prepare nFilterIndex\r
        PUSH     EDX                       // prepare nMaxCustFilter\r
        PUSH     EDX                       // prepare lpstrCustomFilter\r
        PUSH     EDX                       // prepare lpstrFilter = nil\r
        MOV      EAX, ESP\r
        OR       EDX, [EBX].FFilter\r
        JZ       @@5\r
\r
        MOV      ECX, offset[@@0]\r
        CALL     System.@LStrCat3          // prepare lpStrFilter = FFilter + #0\r
        POP      EAX\r
        PUSH     EAX\r
        XOR      EDX, EDX\r
@@3:    INC      EAX   // filter is not starting from ';' or '|'...\r
        CMP      [EAX], DL\r
        JZ       @@5\r
        CMP      byte ptr [EAX], '|'\r
        JNZ      @@3\r
@@4:    MOV      [EAX], DL\r
        JMP      @@3\r
@@OpenSaveFlags:\r
        DD OFN_CREATEPROMPT, OFN_EXTENSIONDIFFERENT, OFN_FILEMUSTEXIST\r
        DD OFN_HIDEREADONLY, OFN_NOCHANGEDIR, OFN_NODEREFERENCELINKS\r
        DD OFN_ALLOWMULTISELECT, OFN_NONETWORKBUTTON, OFN_NOREADONLYRETURN\r
        DD OFN_OVERWRITEPROMPT, OFN_PATHMUSTEXIST, OFN_READONLY, OFN_NOVALIDATE\r
        {$IFDEF OpenSaveDialog_Extended}\r
        DD OFN_ENABLETEMPLATE, OFN_ENABLEHOOK\r
        {$ENDIF}\r
\r
        DD       -1, 1\r
@@0:    DB       0\r
\r
\r
@@5:\r
        PUSH     [hInstance]               // prepare hInstance\r
\r
        MOV      ECX, [EBX].TControl.fWnd\r
        INC      ECX\r
        LOOP     @@6\r
        MOV      ECX, [Applet]\r
        JECXZ    @@6\r
        MOV      ECX, [ECX].TControl.fHandle\r
@@6:    PUSH     ECX                       // prepare hWndOwner\r
        PUSH     76                        // prepare lStructSize\r
\r
        PUSH     ESP\r
        CMP      [EBX].FOpenDialog, DL\r
        JZ       @@7\r
        CALL     GetOpenFileName\r
        JMP      @@8\r
@@7:    CALL     GetSaveFileName\r
@@8:\r
        PUSH     EAX\r
        XOR      EDX, EDX\r
        TEST     EAX, EAX\r
        JZ       @@10\r
\r
        MOV      EAX, [ESP+4].TOpenFileName.nFilterIndex\r
        MOV      [EBX].FFilterIndex, EAX\r
\r
        MOV      EAX, [ESP+4].TOpenFileName.lpstrFile\r
        MOV      EDX, EAX\r
        XOR      ECX, ECX\r
\r
        TEST     [EBX].FOptions, 1 shl OSAllowMultiSelect\r
        JZ       @@10\r
\r
        DEC      EAX\r
@@9:    INC      EAX\r
        CMP      byte ptr [EAX], CL\r
        JNZ      @@9\r
        CMP      byte ptr [EAX+1], CL\r
        JZ       @@10\r
        MOV      byte ptr [EAX], 13\r
        JMP      @@9\r
\r
@@10:\r
        LEA      EAX, [EBX].FFileName\r
        CALL     System.@LStrFromPChar\r
        MOV      EAX, [ESP+4].TOpenFileName.lpstrFile\r
        CALL     System.@FreeMem // v1.86 +AK\r
\r
        LEA      EAX, [ESP+4].TOpenFileName.lpstrFilter\r
        CALL     System.@LStrClr\r
\r
        POP      EAX\r
        ADD      ESP, 76\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TOpenSaveDialog.Execute: Boolean;\r
const OpenSaveFlags: array[ TOpenSaveOption ] of Integer = (\r
      OFN_CREATEPROMPT,\r
      OFN_EXTENSIONDIFFERENT,\r
      OFN_FILEMUSTEXIST,\r
      OFN_HIDEREADONLY,\r
      OFN_NOCHANGEDIR,\r
      OFN_NODEREFERENCELINKS,\r
      OFN_ALLOWMULTISELECT,\r
      OFN_NONETWORKBUTTON,\r
      OFN_NOREADONLYRETURN,\r
      OFN_OVERWRITEPROMPT,\r
      OFN_PATHMUSTEXIST,\r
      OFN_READONLY,\r
      OFN_NOVALIDATE\r
      //{$IFDEF OpenSaveDialog_Extended}\r
      ,\r
      OFN_ENABLETEMPLATE,\r
      OFN_ENABLEHOOK\r
      //{$ENDIF}\r
      );\r
var\r
  Ofn : TOpenFilename;\r
  Fltr : String;\r
  TempFilename : String;\r
\r
  Function MakeFilter(s : string) : String;\r
  {\r
  format of filter for API call is following:\r
    'text files'#0'*.txt'#0\r
    'bitmap files'#0'*.bmp'#0#0\r
  }\r
  var Str: PChar;\r
  begin\r
    Result := s;\r
    if Result='' then\r
      exit;\r
    Result:=Result+#0; {Delphi string always end on #0 is this is #0#0}\r
    Str := PChar( Result );\r
    while Str^ <> #0 do\r
    begin\r
      if Str^ = '|' then\r
        Str^ := #0;\r
      Inc( Str );\r
    end;\r
  end;\r
\r
begin\r
  Fillchar( ofn, sizeof( ofn ), 0 );\r
\r
  ofn.lStructSize:= 76; //to provide correct work in Win9x\r
  //sizeof(ofn); - by suggestion of Michael Morozov, 28-Nov-2001\r
  if fWnd <> 0 then\r
    ofn.hWndOwner := fWnd\r
  else\r
  if assigned(applet) then\r
    ofn.hwndOwner:=applet.Handle;\r
\r
  ofn.hInstance:=HInstance;\r
\r
  Fltr:=MakeFilter(FFilter);\r
  if Fltr <> '' then\r
    ofn.lpstrFilter:=pchar(Fltr);\r
\r
  //ofn.lpstrCustomFilter:=nil;\r
  //ofn.nMaxCustFilter:=0;\r
  ofn.nFilterIndex:=FFilterIndex;\r
\r
  if OSAllowMultiSelect in FOptions then\r
    ofn.nMaxFile:=High(word)-14    // by V.K. (exchanged condition)\r
  else\r
    ofn.nMaxFile:=MAX_PATH+2;\r
\r
  TempFileName:=StringOfChar(#0,ofn.nMaxFile); {Vadim Petrov}\r
  ofn.lpstrFile:=StrLCopy(pchar(TempFileName), pchar(fFileName),\r
                   Min(ofn.nMaxFile,Length(fFileName)));\r
\r
  ofn.lpstrInitialDir:=Pointer(FInitialDir);\r
  ofn.lpstrTitle:=Pointer(FTitle);\r
  ofn.Flags := MakeFlags( @FOptions, OpenSaveFlags )\r
            or OFN_EXPLORER or OFN_LONGNAMES or OFN_ENABLESIZING;\r
\r
  ofn.lpstrDefExt:=PChar(FDefExtension);\r
  ofn.lCustData:=integer(@self);\r
  {$IFDEF OpenSaveDialog_Extended}\r
  ofn.lpTemplateName := PChar( TemplateName );\r
  ofn.lpfnHook := HookProc;\r
  {$ELSE}\r
  ofn.lpTemplateName:=nil;\r
  ofn.lpfnHook:=nil;\r
  {$ENDIF}\r
  if fOpenDialog then\r
    result:=GetOpenFileName(ofn)\r
  else\r
    result:=GetSaveFileName(ofn);\r
  if result then begin\r
    fFilterIndex := ofn.nFilterIndex; // by Vadim\r
    if OSAllowMultiSelect in foptions then begin\r
      FFileName:=copy(TempFileName, 1, pos(#0#0, tempfilename)-1);\r
      while pos(#0, ffilename) > 0 do begin\r
        FFilename[pos(#0, ffilename)]:=#13;\r
      end;\r
    end else\r
      FFileName:=copy(tempFileName, 1, pos(#0, TempFilename)\r
      -1 // by X.Y.B.\r
      );\r
  end else\r
    FFilename:='';\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{ -- OpenDirDialog -- }\r
\r
//*\r
//[function NewOpenDirDialog]\r
function NewOpenDirDialog( const Title: String; Options: TOpenDirOptions ):\r
         POpenDirDialog;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := POpenDirDialog.Create;*){--}\r
  Result.FOptions := [ odOnlySystemDirs ];\r
  if Options <> [] then\r
    Result.FOptions := Options;\r
  Result.FTitle := Title;\r
end;\r
//[END NewOpenDirDialog]\r
\r
{ TOpenDirDialog }\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TOpenDirDialog.Destroy]\r
destructor TOpenDirDialog.Destroy;\r
asm     //cmd    //opd\r
        PUSH     EAX\r
        PUSH     0\r
        LEA      EDX, [EAX].FTitle\r
        PUSH     EDX\r
        LEA      EDX, [EAX].FInitialPath\r
        PUSH     EDX\r
        LEA      EAX, [EAX].FStatusText\r
@@loo:  CALL     System.@LStrClr\r
        POP      EAX\r
        TEST     EAX, EAX\r
        JNZ      @@loo\r
        POP      EAX\r
        CALL     TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TOpenDirDialog.Destroy;\r
begin\r
  FTitle := '';\r
  FInitialPath := '';\r
  FStatusText := '';\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
type\r
  {$IFNDEF _D2}\r
  (*IMalloc = interface(IUnknown)\r
    ['{00000002-0000-0000-C000-000000000046}']\r
    function Alloc(cb: Longint): Pointer; stdcall;\r
    function Realloc(pv: Pointer; cb: Longint): Pointer; stdcall;\r
    procedure Free(pv: Pointer); stdcall;\r
    function GetSize(pv: Pointer): Longint; stdcall;\r
    function DidAlloc(pv: Pointer): Integer; stdcall;\r
    procedure HeapMinimize; stdcall;\r
  end;*)\r
  {$ENDIF}\r
\r
  PSHItemID = ^TSHItemID;\r
  TSHItemID = packed record\r
    cb: Word;                         { Size of the ID (including cb itself) }\r
    abID: array[0..0] of Byte;        { The item ID (variable length) }\r
  end;\r
\r
  PItemIDList = ^TItemIDList;\r
  TItemIDList = record\r
     mkid: TSHItemID;\r
  end;\r
\r
  PBrowseInfo = ^TBrowseInfo;\r
  TBrowseInfo = record\r
    hwndOwner: HWND;\r
    pidlRoot: PItemIDList;\r
    pszDisplayName: PAnsiChar;  { Return display name of item selected. }\r
    lpszTitle: PAnsiChar;      { text to go in the banner over the tree. }\r
    ulFlags: UINT;           { Flags that control the return stuff }\r
    lpfn: Pointer; //TFNBFFCallBack;\r
    lParam: LPARAM;          { extra info that's passed back in callbacks }\r
    iImage: Integer;         { output var: where to return the Image index. }\r
  end;\r
\r
//[API SHXXXXXXXXXX]\r
function SHBrowseForFolder(var lpbi: TBrowseInfo): PItemIDList; stdcall;\r
  external 'shell32.dll' name 'SHBrowseForFolderA';\r
function SHGetPathFromIDList(pidl: PItemIDList; pszPath: PChar): BOOL; stdcall;\r
  external shell32 name 'SHGetPathFromIDListA';\r
{\r
function CoTaskMemAlloc(cb : DWORD) : pointer; stdcall; external 'ole32.dll'\r
  name 'CoTaskMemAlloc';\r
}\r
procedure CoTaskMemFree(pv: Pointer); stdcall; external 'ole32.dll'\r
  name 'CoTaskMemFree';\r
\r
const\r
  BIF_RETURNONLYFSDIRS   = $0001;  { For finding a folder to start document searching }\r
  BIF_DONTGOBELOWDOMAIN  = $0002;  { For starting the Find Computer }\r
  BIF_STATUSTEXT         = $0004;\r
  BIF_RETURNFSANCESTORS  = $0008;\r
  BIF_EDITBOX            = $0010;\r
  BIF_VALIDATE           = $0020;  { insist on valid result (or CANCEL) }\r
  BIF_BROWSEFORCOMPUTER  = $1000;  { Browsing for Computers. }\r
  BIF_BROWSEFORPRINTER   = $2000;  { Browsing for Printers }\r
  BIF_BROWSEINCLUDEFILES = $4000;  { Browsing for Everything }\r
\r
  BFFM_INITIALIZED       = 1;\r
  BFFM_SELCHANGED        = 2;\r
\r
  BFFM_SETSTATUSTEXT     = WM_USER + 100;\r
  BFFM_ENABLEOK          = WM_USER + 101;\r
  BFFM_SETSELECTION      = WM_USER + 102;\r
\r
\r
{$IFDEF ASM_VERSION} // WndOwner\r
//[function TOpenDirDialog.Execute]\r
function TOpenDirDialog.Execute: Boolean;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
\r
        XOR      ECX, ECX\r
        PUSH     ECX             // prepare iImage = 0\r
        PUSH     EBX             // prepare lParam = @Self\r
        PUSH     [EBX].FCallBack // prepare lpfn = FCallBack\r
        LEA      EAX, [EBX].FOptions\r
        MOV      EDX, Offset[@@FlagsArray]\r
        MOV      CL, 5\r
        CALL     MakeFlags\r
        PUSH     EAX             // prepare ulFlags = Options\r
        PUSH     [EBX].FTitle    // prepare lpszTitle\r
        LEA      EAX, [EBX].FBuf\r
        PUSH     EAX             // prepare pszDisplayName\r
        PUSH     0               // prepare pidlRoot\r
        MOV      ECX, [EBX].fWnd\r
        INC      ECX\r
        LOOP     @@1\r
        MOV      ECX, Applet\r
        JECXZ    @@1\r
        MOV      ECX, [ECX].TControl.fHandle\r
@@1:    PUSH     ECX             // prepare hwndOwner\r
\r
        PUSH     ESP\r
        CALL     SHBrowseForFolder\r
        ADD      ESP, 32\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
\r
        PUSH     EAX\r
\r
        LEA      EDX, [EBX].FBuf\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     SHGetPathFromIDList\r
\r
        CALL     CoTaskMemFree\r
\r
        MOV      AL, 1\r
        JMP      @@fin\r
\r
@@FlagsArray:\r
        DD BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN\r
        DD BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT, BIF_BROWSEINCLUDEFILES\r
\r
@@exit: XOR      EAX, EAX\r
@@fin:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TOpenDirDialog.Execute: Boolean;\r
const FlagsArray: array[ TOpenDirOption ] of Integer =\r
      ( BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN,\r
        BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT,\r
        BIF_BROWSEINCLUDEFILES );\r
var BI : TBrowseInfo;\r
    Browse : PItemIdList;\r
begin\r
  Result := False;\r
  if WndOwner <> 0 then\r
    BI.hwndOwner := WndOwner\r
  else\r
  if assigned( Applet ) then\r
    BI.hwndOwner := Applet.Handle\r
  else\r
    BI.hwndOwner := 0;\r
  BI.pidlRoot  := nil;\r
  BI.pszDisplayName := @FBuf[ 0 ];\r
  BI.lpszTitle := PChar( Title );\r
  BI.ulFlags   := MakeFlags( @FOptions, FlagsArray );\r
  BI.lpfn := FCallBack;\r
  BI.lParam := Integer( @Self );\r
  Browse := SHBrowseForFolder( BI );\r
  if Browse <> nil then\r
  begin\r
    SHGetPathFromIDList( Browse, @FBuf[ 0 ] );\r
    CoTaskMemFree( Browse );\r
    Result := True;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TOpenDirDialog.GetInitialPath]\r
function TOpenDirDialog.GetInitialPath: String;\r
begin\r
  Result := IncludeTrailingPathDelimiter( fInitialPath );\r
end;\r
\r
//[function TOpenDirDialog.GetPath]\r
function TOpenDirDialog.GetPath: String;\r
begin\r
  Result := FBuf;\r
end;\r
\r
//[FUNCTION OpenDirSelChangeCallBack]\r
{$IFDEF ASM_VERSION}\r
function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ):\r
         Integer; stdcall;\r
asm\r
        MOV      EAX, [lpData]\r
        MOV      ECX, [EAX].TOpenDirDialog.FOnSelChanged.TMethod.Code\r
        JECXZ    @@exit\r
\r
        LEA      EDX, [EAX].TOpenDirDialog.FBuf\r
        PUSH     EDX\r
        PUSH     [lParam]\r
        CALL     SHGetPathFromIDList\r
\r
        //EnableOK := 0;\r
        //Self_.FOnSelChanged( Self_, Self_.FBuf, EnableOK, Self_.FStatusText );\r
\r
        MOV      EDX, [lpData]\r
        LEA      ECX, [EDX].TOpenDirDialog.FBuf\r
        PUSH     0\r
        PUSH     ESP\r
        LEA      EAX, [EDX].TOpenDirDialog.FStatusText\r
        PUSH     EAX\r
        MOV      EAX, [EDX].TOpenDirDialog.FOnSelChanged.TMethod.Data\r
        CALL     dword ptr [EDX].TOpenDirDialog.FOnSelChanged.TMethod.Code\r
        POP      ECX\r
        JECXZ    @@1\r
\r
        INC      ECX\r
        PUSH     ECX\r
        PUSH     0\r
        PUSH     BFFM_ENABLEOK\r
        PUSH     [Wnd]\r
        CALL     SendMessage\r
@@1:\r
        MOV      EDX, [lpData]\r
        MOV      ECX, [EDX].TOpenDirDialog.FStatusText\r
        JECXZ    @@exit\r
\r
        PUSH     ECX\r
        PUSH     0\r
        PUSH     BFFM_SETSTATUSTEXT\r
        PUSH     [Wnd]\r
        CALL     SendMessage\r
\r
@@exit: XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ):\r
         Integer; stdcall;\r
var _Self_: POpenDirDialog;\r
    EnableOK: Integer;\r
begin\r
  _Self_ := Pointer( lpData );\r
  if assigned( _Self_.FOnSelChanged ) then\r
  begin\r
    SHGetPathFromIDList( PItemIDList( lParam ), @ _Self_.FBuf[ 0 ] );\r
    EnableOK := 0;\r
    _Self_.FOnSelChanged( _Self_, _Self_.FBuf, EnableOK, _Self_.FStatusText );\r
    if EnableOK <> 0 then\r
       SendMessage( Wnd, BFFM_ENABLEOK, 0, EnableOK + 1 );\r
    if _Self_.FStatusText <> '' then\r
       SendMessage( Wnd, BFFM_SETSTATUSTEXT, 0, Integer( PChar( _Self_.FStatusText ) ) );\r
  end;\r
  Result := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END OpenDirSelChangeCallBack]\r
\r
//[FUNCTION OpenDirCallBack]\r
{$IFDEF ASM_VERSION}\r
function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer;\r
         stdcall;\r
asm\r
        MOV      EAX, [Wnd]\r
        MOV      EDX, [lpData]\r
        MOV      ECX, [Msg]\r
        LOOP     @@chk_sel_chg\r
        // Msg = 1 -> BFFM_Initialized\r
\r
        MOV      ECX, [EDX].TOpenDirDialog.FCenterProc\r
        JECXZ    @@1\r
        PUSH     EDX\r
        CALL     ECX\r
        POP      EDX\r
@@1:    MOV      ECX, [EDX].TOpenDirDialog.FInitialPath\r
        JECXZ    @@exit\r
        PUSH     ECX\r
        PUSH     1\r
        PUSH     BFFM_SETSELECTION\r
        PUSH     [Wnd]\r
        CALL     SendMessage\r
        JMP      @@exit\r
\r
@@chk_sel_chg:\r
        LOOP     @@exit\r
        // Msg = 2 -> BFFM_SelChanged\r
\r
        MOV      ECX, [EDX].TOpenDirDialog.FDoSelChanged\r
        JECXZ    @@exit\r
        POP      EBP\r
        JMP      ECX\r
\r
@@exit: XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer;\r
         stdcall;\r
var Self_ : POpenDirDialog;\r
begin\r
  Self_ := Pointer( lpData );\r
  if Msg = BFFM_INITIALIZED then\r
  begin\r
    if assigned( Self_.FCenterProc ) then\r
       Self_.FCenterProc( Wnd );\r
    if Self_.FInitialPath <> '' then\r
      SendMessage( Wnd, BFFM_SETSELECTION, 1, Integer( PChar( Self_.FInitialPath ) ) );\r
  end\r
     else\r
  if Msg = BFFM_SELCHANGED then\r
  begin\r
    if assigned( Self_.FDoSelChanged ) then\r
      Self_.FDoSelChanged( Wnd, Msg, lParam, lpData );\r
  end;\r
  Result := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END OpenDirCallBack]\r
\r
//[PROCEDURE OpenDirDlgCenter]\r
{$IFDEF ASM_VERSION}\r
procedure OpenDirDlgCenter( Wnd: HWnd );\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
\r
        ADD      ESP, -16\r
        PUSH     ESP\r
        PUSH     EAX\r
        CALL     GetWindowRect\r
        POP      EDX          // EDX = Left\r
        POP      ECX          // ECX = Top\r
        POP      EAX          // EAX = Right\r
        SUB      EAX, EDX     // EAX = W\r
        POP      EDX          // EDX = Bottom\r
        SUB      EDX, ECX     // EDX = H\r
        XOR      ECX, ECX\r
        INC      ECX\r
        PUSH     ECX  // prepare True\r
        PUSH     EDX  // prepare H\r
        PUSH     EAX  // prepare W\r
\r
        INC      ECX\r
@@1:\r
        PUSH     ECX\r
\r
        DEC      ECX\r
        PUSH     ECX\r
        CALL     GetSystemMetrics\r
\r
        POP      ECX\r
        SUB      EAX, [ESP+4]\r
        SAR      EAX, 1\r
        PUSH     EAX\r
\r
        LOOP     @@1\r
\r
        {\r
        PUSH     SM_CYSCREEN\r
        CALL     GetSystemMetrics\r
        SUB      EAX, [ESP+4]\r
        SAR      EAX, 1\r
        PUSH     EAX\r
\r
        PUSH     SM_CXSCREEN\r
        CALL     GetSystemMetrics\r
        SUB      EAX, [ESP+4]\r
        SAR      EAX, 1\r
        PUSH     EAX\r
        }\r
\r
        PUSH     EBX\r
        CALL     MoveWindow\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure OpenDirDlgCenter( Wnd: HWnd );\r
var R: TRect;\r
    W, H: Integer;\r
begin\r
  GetWindowRect( Wnd, R );\r
  W := R.Right - R.Left;\r
  H := R.Bottom - R.Top;\r
  R.Left := (GetSystemMetrics( SM_CXSCREEN ) - W) div 2;\r
  R.Top := (GetSystemMetrics( SM_CYSCREEN ) - H) div 2;\r
  MoveWindow( Wnd, R.Left, R.Top, W, H, True );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END OpenDirDlgCenter]\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TOpenDirDialog.SetCenterOnScreen]\r
procedure TOpenDirDialog.SetCenterOnScreen(const Value: Boolean);\r
asm\r
        MOV      [EAX].FCenterOnScreen, DL\r
        MOVZX    ECX, DL\r
        JECXZ    @@1\r
        MOV      ECX, Offset[OpenDirDlgCenter]\r
@@1:    MOV      [EAX].FCenterProc, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TOpenDirDialog.SetCenterOnScreen(const Value: Boolean);\r
var P: procedure( Wnd: HWnd );\r
begin\r
  FCenterOnScreen := Value;\r
  P := nil;\r
  if Value then\r
    P := @OpenDirDlgCenter;\r
  FCenterProc := P;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TOpenDirDialog.SetInitialPath]\r
procedure TOpenDirDialog.SetInitialPath(const Value: String);\r
begin\r
  FCallBack := @OpenDirCallBack;\r
  FInitialPath := ExcludeTrailingPathDelimiter( Value );\r
end;\r
\r
//[procedure TOpenDirDialog.SetOnSelChanged]\r
procedure TOpenDirDialog.SetOnSelChanged(const Value: TOnODSelChange);\r
begin\r
  FOnSelChanged := Value;\r
  FCallBack := @OpenDirCallBack;\r
  FDoSelChanged := @OpenDirSelChangeCallBack;\r
end;\r
\r
\r
type\r
  PByteArray    =^TByteArray;\r
  TByteArray    = array[Word]of Byte;\r
\r
//[API CreateMappedBitmap]\r
function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;\r
  Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; stdcall;\r
  external cctrl name 'CreateMappedBitmap';\r
\r
//[function CreateMappedBitmapEx]\r
function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PChar; Flags:\r
Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap;\r
var bi: TBITMAPINFO;\r
    DC, tmcl: Cardinal;\r
    Bits: PByteArray;\r
    i, j, k, CO, bps: Integer;\r
    tm: array [1..4] of byte absolute tmcl;\r
    bm: Windows.TBITMAP;\r
    CM: PColorMap;\r
    DW: HWnd;\r
begin\r
  Result := LoadBitmap( Instance, BmpRsrcName );\r
  if Result = 0 then\r
  begin\r
    {$IFDEF DEBUG}\r
    ShowMessage( 'Can not load bitmap ' + BmpRsrcName + ', error ' +\r
                 Int2Str( GetLastError ) + ': ' + SysErrorMessage( GetLastError ) );\r
    {$ENDIF}\r
    Exit;\r
  end;\r
  DW := GetDesktopWindow;\r
  DC := GetDC(DW);\r
  FillChar( bm, SizeOf(bm), 0 );\r
  GetObject( Result, SizeOf( bm ), @bm );\r
\r
  FillChar( bi, SizeOf( bi ), 0 );\r
  bi.bmiHeader.biSize := SizeOf( bi.bmiHeader );\r
  bi.bmiHeader.biWidth := bm.bmWidth;\r
  bi.bmiHeader.biHeight := -bm.bmHeight;\r
  bi.bmiHeader.biPlanes := 1;\r
  bi.bmiHeader.biBitCount := 24;\r
// BitCout - always 24 for easy algorythm\r
  bi.bmiHeader.biCompression:=BI_RGB;\r
  bps := CalcScanLineSize( @bi.bmiHeader );\r
\r
  GetMem( Bits, bps * bm.bmHeight );\r
  GetDIBits( DC, Result, 0, bm.bmHeight, @Bits[0], bi, DIB_RGB_COLORS );\r
  DeleteObject( Result );\r
\r
  for i := 0 to bm.bmHeight - 1 do begin\r
      for j := 0 to bm.bmWidth - 1 do begin\r
          CO := bps * i + 3 * j;\r
          for k := 0 to NumMaps - 1 do begin\r
              CM := Pointer( Integer( ColorMap ) + SizeOf( TColorMap ) * k );\r
              if RGB( Bits[CO+2], Bits[CO+1], Bits[CO] ) = CM.cFrom then\r
              begin\r
                  tmcl := CM.cTo;\r
                  tm[4]:=tm[1];\r
                  tm[1]:=tm[3];\r
                  tm[3]:=tm[4];\r
                  Move( tmcl, Bits[CO], 3);\r
              end;\r
          end;\r
      end;\r
  end;\r
  Result := CreateDIBitmap( DC, bi.bmiHeader, CBM_INIT, @Bits[0], bi,\r
    DIB_RGB_COLORS );\r
  ReleaseDC( DW, DC );\r
  FreeMem( Bits );\r
end;\r
\r
//*\r
//[function LoadMappedBitmap]\r
function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor )\r
         : HBitmap;\r
var Map2Pass: Pointer;\r
begin\r
  Map2Pass := nil;\r
  if High( Map ) > 0 then\r
    Map2Pass := PColorMap( @Map[ 0 ] );\r
  Result := CreateMappedBitmap( hInst, BmpResID, 0, Map2Pass, (High( Map ) + 1) div 2 );\r
end;\r
\r
//[function LoadMappedBitmapEx]\r
function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PChar; const Map: array of TColor )\r
         : HBitmap;\r
var Map2Pass: Pointer;\r
begin\r
  Map2Pass := nil;\r
  if High( Map ) > 0 then\r
    Map2Pass := PColorMap( @Map[ 0 ] );\r
  Result := CreateMappedBitmapEx( hInst, BmpResName, 0, Map2Pass, (High( Map ) + 1) div 2 );\r
  if MasterObj <> nil then\r
    MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) );\r
end;\r
\r
{ -- Toolbar -- }\r
\r
{$IFDEF ASM_noVERSION} // width\r
//[procedure TControl.TBAddBitmap]\r
procedure TControl.TBAddBitmap(Bitmap: HBitmap);\r
const szBI = sizeof(TBitmapInfo);\r
asm\r
        TEST     EDX, EDX\r
        JZ       @@exit\r
        JGE      @@1\r
        CMP      EDX, -6\r
        JL       @@1\r
\r
        NEG      EDX\r
        DEC      EDX\r
        PUSH     EDX\r
        PUSH     -1\r
        XOR      EDX, EDX\r
        JMP      @@2\r
\r
@@1:    PUSH     EDX    // AB.hInst = Bitmap\r
        PUSH     0      // AB.nID = 0\r
\r
        PUSH     EAX    // > @Self\r
        ADD      ESP, -szBI\r
        PUSH     ESP\r
        PUSH     szBI\r
        PUSH     EDX\r
        CALL     GetObject\r
        TEST     EAX, EAX\r
        JG       @@11\r
\r
        ADD      ESP, szBI\r
        JMP      @@exit\r
\r
@@11:   MOV      EAX, [ESP].TBitmapInfo.bmiHeader.biWidth\r
        MOV      ECX, [ESP].TBitmapInfo.bmiHeader.biHeight\r
        TEST     ECX, ECX\r
        JGE      @@12\r
        NEG      ECX\r
@@12:   ADD      ESP, szBI\r
        CDQ                  // EDX = 0\r
        DIV      ECX         // EAX = N\r
        XCHG     EAX, [ESP]  // > N\r
        PUSH     EAX         // > @Self\r
\r
        MOV      EDX, ECX\r
        SHL      EDX, 16\r
        OR       ECX, EDX\r
        CDQ\r
        PUSH     EDX\r
        PUSH     EDX\r
        PUSH     TB_AUTOSIZE\r
        PUSH     EAX\r
\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     TB_SETBITMAPSIZE\r
        PUSH     EAX\r
        CALL     Perform\r
        CALL     Perform\r
        POP      EAX\r
        POP      EDX\r
\r
@@2:    PUSH     ESP\r
        PUSH     EDX\r
        PUSH     TB_ADDBITMAP\r
        PUSH     EAX\r
        CALL     Perform\r
        POP      ECX\r
        POP      ECX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.TBAddBitmap(Bitmap: HBitmap);\r
const NstdBitmaps: array[ 0..5 ] of DWORD = ( 15, 15, 0, 0, 13, 13 );\r
var BI: TBitmapInfo;\r
    AB: TTBAddBitmap;\r
    N, W: Integer;\r
begin\r
  if Bitmap = 0 then Exit;\r
  if (Integer( Bitmap ) >= -10) and (Integer( Bitmap ) <= -1) then\r
  begin\r
    AB.hInst := THandle(-1);\r
    AB.nID := -Integer(Bitmap) - 1;\r
    N := 0; //NstdBitmaps[ AB.nID ]; // (this value is ignored)\r
  end\r
     else\r
  if GetObject( Bitmap, sizeof( TBitmapInfo ), @BI ) > 0 then\r
  begin\r
    AB.hInst := 0;\r
    AB.nID := Bitmap;\r
    W := fTBBtnImgWidth;\r
    if W = 0 then\r
      W := Abs( BI.bmiHeader.biHeight );\r
    N := BI.bmiHeader.biWidth div W;\r
    Perform( TB_SETBITMAPSIZE, 0, MAKELONG( W, Abs(BI.bmiHeader.biHeight )) );\r
    Perform( TB_AUTOSIZE, 0, 0 );\r
  end\r
    else Exit;\r
  Perform( TB_ADDBITMAP, N, Integer( @AB ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
var ToolbarsIDcmd: Integer = 100;\r
{$IFDEF ASM_VERSION}\r
//[function TControl.TBAddInsButtons]\r
function TControl.TBAddInsButtons(Idx: Integer; const Buttons: array of PChar;\r
  const BtnImgIdxArray: array of Integer): Integer; stdcall;\r
asm\r
        { [EBP+$8] = @Self\r
          [EBP+$C] = Idx\r
          [EBP+$10] = Buttons\r
          [EBP+$14] = High(Butons)\r
          [EBP+$18] = BtnImgIdxArray\r
          [EBP+$1C] = High(BtnImgIdxArray)\r
        }\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        OR       EBX, -1\r
        MOV      EAX, 20\r
        MOV      ECX, [EBP+$14]\r
        CMP      ECX, EBX\r
        JLE      @@fin\r
        INC      ECX\r
        MUL      ECX\r
        CALL     System.@GetMem\r
        PUSH     EAX           // save AB to FreeMem after\r
        MOV      EDX, EBX\r
        DEC      EDX           // nBmp := -2\r
\r
        MOV      ECX, [EBP+$14]\r
        INC      ECX\r
        JZ       @@exit\r
\r
        MOV      ECX, [EBP+$1C]\r
        INC      ECX\r
        JZ       @@1\r
        MOV      ECX, [BtnImgIdxArray]\r
        MOV      EDX, [ECX]\r
        DEC      EDX           // nBmp := BtnImgIdxArray[ 0 ] - 1\r
@@1:    MOV      ECX, [EBP+$14]\r
        INC      ECX\r
        MOV      ESI, [Buttons]\r
        MOV      EDI, EAX      // EDI = PAB\r
        PUSH     0             // N:=0 in [EBP-$14]\r
        // -- impossible?-- JZ       @@break\r
@@loop:\r
        LODSD\r
        TEST     EAX, EAX\r
        JZ       @@break\r
        //CMP      byte ptr [EAX], 0\r
        //JZ       @@break\r
        PUSH     ECX\r
\r
        CMP      word ptr [EAX], '-'\r
        JNE      @@2\r
\r
        OR       EAX, -1\r
        STOSD\r
        //INC      EAX   //=0\r
        MOV      EAX, [ToolbarsIDcmd]\r
        TEST     EBX, EBX\r
        {$IFDEF USE_CMOV}\r
        CMOVL    EBX, EAX\r
        {$ELSE}\r
        JGE      @@b0\r
        MOV      EBX, EAX\r
@@b0:   {$ENDIF}\r
\r
        //INC      [ToolbarsIDcmd]\r
        STOSD\r
        XOR      EAX, EAX\r
        INC      AH  // TBSTYLE_SEP = 1\r
        STOSD\r
        DEC      AH\r
        STOSD\r
        DEC      EAX\r
        JMP      @@3\r
\r
        DD       -1, 1\r
@@0:    DB       0\r
\r
@@2:\r
        INC      EDX  // Inc( nBmp )\r
        PUSH     EAX\r
\r
        MOV      EAX, [EBP+$1C]\r
        MOV      ECX, [EBP-$14]\r
        CMP      EAX, ECX\r
        MOV      EAX, EDX\r
        JL       @@21\r
        MOV      EAX, [BtnImgIdxArray]\r
        MOV      EAX, [EAX+ECX*4]\r
@@21:   STOSD\r
\r
        TEST     EDX, EDX\r
        JGE      @@2a\r
        DEC      EDX\r
@@2a:\r
\r
        MOV      EAX, [ToolbarsIDcmd]\r
        //INC      [ToolbarsIDcmd]\r
        STOSD\r
        TEST     EBX, EBX\r
        {$IFDEF USE_CMOV}\r
        CMOVL    EBX, EAX\r
        {$ELSE}\r
        JGE      @@210\r
        MOV      EBX, EAX\r
@@210:  {$ENDIF}\r
\r
        POP      ECX\r
        MOV      AX, $1004 // AL=fsState=_ENABLED, AH=fsStyle=_AUTOSIZE\r
        CMP      byte ptr [ECX], '^'\r
        JNE      @@22\r
        MOV      AH, TBSTYLE_DROPDOWN or TBSTYLE_AUTOSIZE\r
        INC      ECX\r
@@22:   CMP      byte ptr [ECX], '-'\r
        JZ       @@23\r
        CMP      byte ptr [ECX], '+'\r
        JNZ      @@24\r
        MOV      AL, TBSTATE_ENABLED or TBSTATE_CHECKED\r
@@23:   INC      ECX\r
        OR       AH, TBSTYLE_CHECK\r
        CMP      byte ptr [ECX], '!'\r
        JNZ      @@24\r
        OR       AH, TBSTYLE_GROUP\r
        INC      ECX\r
@@24:   STOSD\r
        MOV      EAX, [EBP+8]\r
        STOSD\r
        OR       EAX, -1\r
        CMP      word ptr [ECX], ' '\r
        JZ       @@3\r
        CMP      byte ptr [ECX], 0\r
        JZ       @@3\r
\r
        PUSH     EDX\r
        PUSH     0\r
        MOV      EDX, ECX\r
        MOV      EAX, ESP\r
        CALL     System.@LStrFromPChar\r
        MOV      EAX, ESP\r
        MOV      EDX, offset[@@0]\r
        CALL     System.@LStrCat\r
        PUSH     dword ptr [ESP]\r
        PUSH     0\r
        PUSH     TB_ADDSTRING\r
        PUSH     dword ptr [EBP+8]\r
        CALL     Perform\r
        STOSD\r
\r
        CALL     RemoveStr\r
        POP      EDX\r
        JMP      @@30\r
\r
@@3:    STOSD\r
@@30:   INC      dword ptr [EBP-$14]\r
        INC      [ToolbarsIDcmd]\r
        POP      ECX\r
        DEC      ECX\r
        JNZ      @@loop\r
@@break:\r
        POP      ECX\r
        JECXZ    @@exit\r
        PUSH     dword ptr [ESP]\r
        MOV      EAX, [Idx]\r
        TEST     EAX, EAX\r
        JGE      @@31\r
\r
        PUSH     ECX\r
        PUSH     TB_ADDBUTTONS\r
        JMP      @@32\r
@@31:\r
        PUSH     EAX\r
        PUSH     TB_INSERTBUTTON\r
@@32:\r
        PUSH     dword ptr [EBP+8]\r
        CALL     Perform\r
@@exit:\r
        POP      EAX\r
        //TEST     EAX, EAX\r
        //JZ       @@fin\r
        CALL     System.@FreeMem\r
\r
@@fin:\r
        POP      EDI\r
        POP      ESI\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TBAddInsButtons(Idx: Integer; const Buttons: array of PChar;\r
  const BtnImgIdxArray: array of Integer): Integer; stdcall;\r
\r
      function AddInsButtons: Integer;\r
      type TTBBtnArray = array[ 0..100000 ] of TTBButton;\r
           PTBBtnArray = ^TTBBtnArray;\r
      var AB: PTBBtnArray;\r
          I, N, nBmp: Integer;\r
          PAB: PTBButton;\r
          Str: PChar;\r
      begin\r
        Result := -1;\r
        AB := nil;\r
        if High( Buttons ) >= 0 then\r
          GetMem( AB, Sizeof( TTBButton ) * (High(Buttons) + 1) );\r
        N := 0;\r
        PAB := @AB[ 0 ];\r
        nBmp := -2;\r
        if High(BtnImgIdxArray) >= 0 then\r
          nBmp := BtnImgIdxArray[ 0 ] - 1;\r
        for I:= 0 to High( Buttons ) do\r
        begin\r
          if Buttons[ I ] = nil then break;\r
\r
          {if High( BtnImgIdxArray ) >= 0 then\r
            if I > High( BtnImgIdxArray ) then\r
              nBmp := -3;}\r
\r
          if Buttons[ I ] = {$IFDEF F_P}''+{$ENDIF} '-' then\r
          begin\r
            PAB.iBitmap := -1;\r
            //PAB.idCommand := 0;\r
            PAB.fsState := 0;\r
            PAB.fsStyle := TBSTYLE_SEP;\r
            PAB.iString := -1;\r
          end\r
             else\r
          begin\r
            Str := Buttons[ I ];\r
            Inc( nBmp );\r
            PAB.iBitmap := nBmp;\r
            if nBmp < 0 then\r
              Dec( nBmp );\r
            if High( BtnImgIdxArray ) >= N then\r
              PAB.iBitmap := BtnImgIdxArray[ N ];\r
            {PAB.idCommand := ToolbarsIDcmd;\r
            if Result < 0 then Result := PAB.idCommand;\r
            Inc( ToolbarsIDcmd );}\r
            PAB.fsState := TBSTATE_ENABLED;\r
            PAB.fsStyle := TBSTYLE_BUTTON or TBSTYLE_AUTOSIZE;\r
            if Str^ = '^' then\r
            begin\r
              PAB.fsStyle := TBSTYLE_DROPDOWN or TBSTYLE_AUTOSIZE;\r
              Inc( Str );\r
            end;\r
            if Str^ in [ '-', '+' ] then\r
            begin\r
              PAB.fsStyle := PAB.fsStyle or TBSTYLE_CHECK;\r
              if Str^ = '+' then\r
                PAB.fsState := PAB.fsState or TBSTATE_CHECKED;\r
              Inc( Str );\r
              if Str^ = '!' then\r
              begin\r
                PAB.fsStyle := PAB.fsStyle or TBSTYLE_GROUP;\r
                Inc( Str );\r
              end;\r
            end;\r
            if (Str =  {$IFDEF F_P}''+{$ENDIF} ' ') or (Str^ = #0) then\r
              PAB.iString := -1\r
                //Perform( TB_ADDSTRING, 0, Integer( PChar( '' + #0 ) ) )\r
                // an experiment: is it possible to remove space right to image\r
                // without setting tboTextBottom option (non compatible with FixFlatXP)\r
                // answer: seems not possible.\r
            else\r
              PAB.iString :=\r
                Perform( TB_ADDSTRING, 0, Integer( PChar( '' + Str + #0 ) ) );\r
          end;\r
\r
          PAB.idCommand := ToolbarsIDcmd;\r
          if Result < 0 then Result := PAB.idCommand;\r
          Inc( ToolbarsIDcmd );\r
\r
          PAB.dwData := Integer( @Self );\r
          Inc( N );\r
          Inc( PAB );\r
        end;\r
        if N > 0 then\r
        begin\r
          if Idx < 0 then\r
            Perform( TB_ADDBUTTONS, N, Integer( @AB[ 0 ] ) )\r
          else\r
            Perform( TB_INSERTBUTTON, Idx, Integer( @AB[ 0 ] ) );\r
        end;\r
        if AB <> nil then\r
          FreeMem( AB );\r
      end;\r
begin\r
  if High( Buttons ) < 0 then\r
    Result := -1\r
  else\r
    Result := AddInsButtons;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.TBAddButtons]\r
function TControl.TBAddButtons(const Buttons: array of PChar;\r
         const BtnImgIdxArray: array of Integer): Integer;\r
asm\r
        PUSH     dword ptr [EBP+8]\r
        PUSH     dword ptr [EBP+12]\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     -1\r
        PUSH     EAX\r
        CALL     TBAddInsButtons\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TBAddButtons(const Buttons: array of PChar;\r
         const BtnImgIdxArray: array of Integer): Integer;\r
begin\r
  Result := TBAddInsButtons( -1, Buttons, BtnImgIdxArray );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[function TControl.TBInsertButtons]\r
function TControl.TBInsertButtons(BeforeIdx: Integer;\r
  Buttons: array of PChar; BtnImgIdxArray: array of Integer): Integer;\r
var I, J, K: Integer;\r
begin\r
  J := -1;\r
  Result := -1;\r
  for I := 0 to High( Buttons ) do\r
  begin\r
    if I <= High( BtnImgIdxArray ) then\r
      J := BtnImgIdxArray[ I ]\r
    else\r
      if J >= 0 then Inc( J );\r
    K := TBAddInsButtons( BeforeIdx, [ Buttons[ I ], '' ], [ J ] );\r
    if Result < 0 then Result := K;\r
  end;\r
end;\r
\r
//[function GetTBBtnGoodID]\r
function GetTBBtnGoodID( Toolbar: PControl; BtnIDorIdx: Integer ): Integer;\r
// change by Alexander Pravdin (to fix toolbar with separator first):\r
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\r
var Btn1st, i: Integer; btn: TTBButton;\r
begin\r
  Result := BtnIDorIdx;\r
  Btn1st := 0;\r
  for i := 0 to Toolbar.TBButtonCount - 1 do begin\r
    Toolbar.Perform( TB_GETBUTTON, i, Integer( @btn ) );\r
    if btn.fsStyle <> TBSTYLE_SEP then begin\r
        Btn1st := i;\r
        Break;\r
    end;\r
  end;\r
  if Result < Toolbar.TBIndex2Item( Btn1st ) then\r
    Result := Toolbar.TBIndex2Item( Result );\r
end;\r
\r
type\r
  TTBButtonEvent = packed Record\r
    BtnID: DWORD;\r
    Event: TOnToolbarButtonClick;\r
  end;\r
  PTBButtonEvent = ^TTBButtonEvent;\r
\r
//[procedure TControl.TBFreeTBevents]\r
procedure TControl.TBFreeTBevents;\r
begin\r
  fTBevents.Release;\r
end;\r
\r
//[function WndProcToolbarButtonsClicks]\r
function WndProcToolbarButtonsClicks( TB: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Notify: PTBNotify;\r
    I: Integer;\r
    Event: PTBButtonEvent;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    Notify := Pointer( Msg.lParam );\r
    if Notify.hdr.code = NM_CLICK then\r
    begin\r
      for I := TB.fTBevents.fCount-1 downto 0 do\r
      begin\r
        Event := TB.fTBevents.fItems[ I ];\r
        if Integer( Event.BtnID ) = Notify.iItem then\r
        begin\r
          if Assigned( Event.Event ) then\r
          begin\r
            TB.RefInc;\r
            Rslt := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam );\r
            Event.Event( TB, Event.BtnID );\r
            //Rslt := TB.CallDefWndProc( Msg );\r
            TB.RefDec;\r
            Result := TRUE;\r
            Exit;\r
          end;\r
          break;\r
        end;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.TBAssignEvents]\r
procedure TControl.TBAssignEvents(BtnID: Integer;\r
  Events: array of TOnToolbarButtonClick);\r
var I: Integer;\r
    EventRec: PTBButtonEvent;\r
begin\r
  if fTBevents = nil then\r
  begin\r
    fTBevents := NewList;\r
    Add2AutoFreeEx( TBFreeTBevents );\r
    AttachProc( WndProcToolbarButtonsClicks );\r
  end;\r
  BtnID := GetTBBtnGoodID( @Self, BtnID );\r
  for I := 0 to High( Events ) do\r
  begin\r
    GetMem( EventRec, Sizeof( TTBButtonEvent ) );\r
    fTBevents.Add( EventRec );\r
    EventRec.Event := Events[ I ];\r
    EventRec.BtnID := BtnID;\r
    Inc( BtnID );\r
  end;\r
end;\r
\r
//[procedure TControl.TBResetImgIdx]\r
procedure TControl.TBResetImgIdx( BtnID, BtnCount: Integer );\r
begin\r
  while BtnCount > 0 do\r
  begin\r
    TBButtonImage[ BtnID ] := -2;\r
    Inc( BtnID );\r
    Dec( BtnCount );\r
  end;\r
end;\r
\r
//*\r
//[function TControl.TBGetButtonVisible]\r
function TControl.TBGetButtonVisible(BtnID: Integer): Boolean;\r
begin\r
  Result := Perform( TB_ISBUTTONHIDDEN, GetTBBtnGoodID( @ Self, BtnID ), 0 ) = 0;\r
end;\r
\r
//*\r
//[function TControl.TBItem2Index]\r
function TControl.TBItem2Index(BtnID: Integer): Integer;\r
begin\r
  Result := Perform( TB_COMMANDTOINDEX, BtnID, 0 );\r
end;\r
\r
//*\r
//[procedure TControl.TBSetButtonVisible]\r
procedure TControl.TBSetButtonVisible(BtnID: Integer;\r
  const Value: Boolean);\r
begin\r
  BtnID := GetTBBtnGoodID( @Self, BtnID );\r
  Perform( TB_HIDEBUTTON, BtnID, Integer( not Value ) );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.TBGetBtnStt]\r
function TControl.TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;\r
asm\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     GetTBBtnGoodID\r
        POP      EDX\r
        POP      ECX\r
        PUSH     EAX\r
        ADD      ECX, 8\r
        PUSH     ECX\r
        PUSH     EDX\r
        CALL     Perform\r
        TEST     EAX, EAX\r
        SETNZ    AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;\r
begin\r
  BtnID := GetTBBtnGoodID( @Self, BtnID );\r
  Result := Perform( Index + 8, BtnID, 0 ) <> 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//+\r
//[procedure TControl.TBSetBtnStt]\r
procedure TControl.TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean);\r
begin\r
  BtnID := GetTBBtnGoodID( @Self, BtnID );\r
  Perform( Index, BtnID, Integer( Value ) );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.TBIndex2Item]\r
function TControl.TBIndex2Item(Idx: Integer): Integer;\r
//*/////////////////////////////////////////////////////\r
const                                                 //\r
  _sizeof_TTBButton = sizeof( TTBButton );            //\r
//*/////////////////////////////////////////////////////\r
asm\r
//*/////////////////////////////////////////////////////\r
//        ADD      ESP, -sizeof(TTBButton)\r
//*/////////////////////////////////////////////////////\r
        ADD      ESP, -_sizeof_TTBButton              //\r
//*/////////////////////////////////////////////////////\r
        PUSH     ESP\r
        PUSH     EDX\r
        PUSH     TB_GETBUTTON\r
        PUSH     EAX\r
        CALL     Perform\r
        TEST     EAX, EAX\r
        MOV      EAX, [ESP].TTBButton.idCommand\r
        JNZ      @@1\r
        OR       EAX, -1\r
//*/////////////////////////////////////////////////////\r
//@@1:    ADD      ESP, sizeof( TTBButton )\r
//*/////////////////////////////////////////////////////\r
@@1:    ADD      ESP, _sizeof_TTBButton               //\r
//*/////////////////////////////////////////////////////\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TBIndex2Item(Idx: Integer): Integer;\r
var ButtonInfo: TTBButton;\r
begin\r
  Result := -1;\r
  if Perform( TB_GETBUTTON, Idx, Integer( @ButtonInfo ) ) <> 0 then\r
    Result := ButtonInfo.idCommand;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.TBGetButtonText]\r
function TControl.TBGetButtonText( BtnID: Integer ): String;\r
asm\r
        PUSH     ECX\r
        ADD      ESP, -1024\r
        PUSH     ESP\r
        PUSH     EAX\r
        CALL     GetTBBtnGoodID\r
        POP      EDX\r
        PUSH     EAX\r
        PUSH     TB_GETBUTTONTEXT\r
        PUSH     EDX\r
        CALL     Perform\r
        TEST     EAX, EAX\r
        JLE      @@2\r
        MOV      EDX, ESP\r
        JMP      @@1\r
@@2:    XOR      EDX, EDX\r
@@1:    MOV      EAX, [ESP+1024]\r
        CALL     System.@LStrFromPChar\r
        ADD      ESP, 1028\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TBGetButtonText( BtnID: Integer ): String;\r
var Buffer: array[ 0..1023 ] of Char;\r
begin\r
  BtnID := GetTBBtnGoodID( @Self, BtnID );\r
  if Perform( TB_GETBUTTONTEXT, BtnID, Integer( @Buffer[ 0 ] ) ) > 0 then\r
    Result := Buffer\r
  else\r
  Result := '';\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[function TControl.TBGetButtonRect]\r
function TControl.TBGetButtonRect(BtnID: Integer): TRect;\r
begin\r
  BtnID := GetTBBtnGoodID( @Self, BtnID );\r
  Perform( TB_GETITEMRECT, TBItem2Index( BtnID ), Integer( @Result ) );\r
end;\r
\r
//*\r
//[function TControl.TBGetRows]\r
function TControl.TBGetRows: Integer;\r
begin\r
  Result := 1;\r
  UpdateWndStyles;\r
  if (TBSTYLE_WRAPABLE and fStyle) <> 0 then\r
    Result := Perform( TB_GETROWS, 0, 0 );\r
end;\r
\r
//*\r
//[procedure TControl.TBSetRows]\r
procedure TControl.TBSetRows(const Value: Integer);\r
begin\r
  Perform( TB_SETROWS, Value, 0 );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.TBSetTooltips]\r
procedure TControl.TBSetTooltips(BtnID1st: Integer;\r
  Tooltips: array of PChar);\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      ESI, ECX\r
        MOV      EBX, EAX\r
        PUSHAD\r
        MOV      ECX, [EBX].fTBttCmd\r
        INC      ECX\r
        LOOP     @@1\r
        CALL     NewList\r
        MOV      [EBX].fTBttCmd, EAX\r
        CALL     NewStrList\r
        MOV      [EBX].fTBttTxt, EAX\r
@@1:    POPAD\r
        MOV      ECX, [EBP+8]\r
        INC      ECX\r
        JZ       @@exit\r
@@loop:\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     0\r
        LODSD\r
        MOV      EDX, EAX\r
        MOV      EAX, ESP\r
        CALL     System.@LStrFromPChar\r
\r
        MOV      EDX, [ESP+4]\r
        MOV      EAX, [EBX].fTBttCmd\r
        CALL     TList.IndexOf\r
        TEST     EAX, EAX\r
        JGE      @@2\r
\r
        MOV      EDX, [ESP+4]\r
        MOV      EAX, [EBX].fTBttCmd\r
        CALL     TList.Add\r
        POP      EDX\r
        PUSH     EDX\r
        MOV      EAX, [EBX].fTBttTxt\r
        CALL     TStrList.Add\r
        JMP      @@3\r
\r
@@2:\r
        MOV      EDX, EAX\r
        POP      ECX\r
        PUSH     ECX\r
        MOV      EAX, [EBX].fTBttTxt\r
        CALL     TStrList.Put\r
@@3:\r
        CALL     RemoveStr\r
\r
        POP      EDX\r
        POP      ECX\r
        INC      EDX\r
        LOOP     @@loop\r
@@exit:\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.TBSetTooltips(BtnID1st: Integer;\r
  Tooltips: array of PChar);\r
var I, J: Integer;\r
begin\r
  if not assigned( fTBttCmd ) then\r
  begin\r
    fTBttCmd := NewList;\r
    fTBttTxt := NewStrList;\r
  end;\r
  for I:= 0 to High( Tooltips ) do\r
  begin\r
    J := fTBttCmd.IndexOf( Pointer( BtnID1st ) );\r
    if J < 0 then\r
    begin\r
      fTBttCmd.Add( Pointer( BtnID1st ) );\r
      fTBttTxt.Add( Tooltips[ I ] );\r
    end\r
       else\r
      fTBttTxt.Items[ J ] := Tooltips[ I ];\r
    Inc( BtnID1st );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.TBButtonAtPos]\r
function TControl.TBButtonAtPos(X, Y: Integer): Integer;\r
asm\r
        PUSH     EAX\r
        CALL     TBBtnIdxAtPos\r
        TEST     EAX, EAX\r
        MOV      EDX, EAX\r
        POP      EAX\r
        JGE      TBIndex2Item\r
        MOV      EAX, EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TBButtonAtPos(X, Y: Integer): Integer;\r
var I: Integer;\r
begin\r
  I := TBBtnIdxAtPos( X, Y );\r
  if I >= 0 then\r
     I := TBIndex2Item( I );\r
  Result := I;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.TBBtnIdxAtPos]\r
function TControl.TBBtnIdxAtPos(X, Y: Integer): Integer;\r
asm\r
        PUSH     EBX\r
        PUSH     ECX\r
        PUSH     EDX\r
        MOV      EBX, EAX\r
        CALL     GetItemsCount\r
        MOV      ECX, EAX\r
        JECXZ    @@fin\r
@@1:    PUSH     ECX\r
        ADD      ESP, -16\r
        PUSH     ESP\r
        DEC      ECX\r
        PUSH     ECX\r
        PUSH     TB_GETITEMRECT\r
        PUSH     EBX\r
        CALL     Perform\r
        MOV      EDX, ESP\r
        LEA      EAX, [ESP+20]\r
        CALL     PointInRect\r
        ADD      ESP, 16\r
        POP      ECX\r
        TEST     AL, AL\r
        {$IFDEF USE_CMOV}\r
        CMOVNZ   EAX, ECX\r
        {$ELSE}\r
        JZ       @@2\r
        MOV      EAX, ECX\r
        JMP      @@fin\r
@@2:    {$ENDIF}\r
        JNZ      @@fin\r
\r
        LOOP     @@1\r
@@fin:  DEC      EAX\r
        POP      EDX\r
        POP      EDX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TBBtnIdxAtPos(X, Y: Integer): Integer;\r
var I: Integer;\r
    R: TRect;\r
    P: TPoint;\r
begin\r
  P := MakePoint( X, Y );\r
  for I := TBButtonCount - 1 downto 0 do\r
  begin\r
    Perform( TB_GETITEMRECT, I, Integer( @R ) );\r
    if PointInRect( P, R ) then\r
    begin\r
      Result := I;\r
      Exit;\r
    end;\r
  end;\r
  Result := -1;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[procedure TControl.TBDeleteButton]\r
procedure TControl.TBDeleteButton(BtnID: Integer);\r
begin\r
  BtnID := GetTBBtnGoodID( @Self, BtnID );\r
  Perform( TB_DELETEBUTTON, TBItem2Index( BtnID ), 0 );\r
end;\r
\r
//*\r
//[procedure TControl.TBDeleteBtnByIdx]\r
procedure TControl.TBDeleteBtnByIdx(Idx: Integer);\r
begin\r
  Perform( TB_DELETEBUTTON, Idx, 0 );\r
end;\r
\r
//*\r
//[procedure TControl.Clear]\r
procedure TControl.Clear;\r
begin\r
  fCommandActions.aClear( @Self );\r
end;\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TControl.TBGetBtnImgIdx]\r
function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer;\r
const szTBButton = sizeof( TTBButton );\r
asm\r
        ADD      ESP, -szTBButton\r
        PUSH     ESP\r
        PUSH     EAX\r
        CALL     TBItem2Index\r
        POP      EDX\r
        PUSH     EAX\r
        PUSH     TB_GETBUTTON\r
        PUSH     EDX\r
        CALL     Perform\r
        POP      EAX\r
        ADD      ESP, szTBButton-4\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer;\r
var B: TTBButton;\r
begin\r
  Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID ) ), Integer( @B ) );\r
  Result := B.iBitmap;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[procedure TControl.TBSetBtnImgIdx]\r
procedure TControl.TBSetBtnImgIdx(BtnID: Integer; const Value: Integer);\r
begin\r
  Perform( TB_CHANGEBITMAP, GetTBBtnGoodID( @Self, BtnID ), Value );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.TBSetButtonText]\r
procedure TControl.TBSetButtonText(BtnID: Integer; const Value: String);\r
asm\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     GetTBBtnGoodID\r
        POP      EDX\r
\r
        ADD      ESP, -16\r
        PUSH     TBIF_TEXT\r
        PUSH     32 //Sizeof( TTBButtonInfo )\r
        PUSH     ESP\r
        PUSH     EAX\r
        PUSH     TB_SETBUTTONINFO\r
        PUSH     EDX\r
        CALL     Perform\r
        ADD      ESP, 32 //sizeof( TTBButtonInfo )\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.TBSetButtonText(BtnID: Integer; const Value: String);\r
var BI: TTBButtonInfo;\r
begin\r
  BtnID := GetTBBtnGoodID( @Self, BtnID );\r
  BI.cbSize := Sizeof( BI );\r
  BI.dwMask := TBIF_TEXT;\r
  BI.pszText := PChar( Value );\r
  Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.TBGetBtnWidth]\r
function TControl.TBGetBtnWidth(BtnID: Integer): Integer;\r
asm\r
        ADD      ESP, -16\r
        MOV      ECX, ESP\r
        CALL     TBGetButtonRect\r
        POP      EDX\r
        POP      ECX\r
        POP      EAX\r
        SUB      EAX, EDX\r
        POP      EDX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.TBGetBtnWidth(BtnID: Integer): Integer;\r
var R: TRect;\r
begin\r
  R := TBButtonRect[ BtnID ];\r
  Result := R.Right - R.Left;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.TBSetBtnWidth]\r
procedure TControl.TBSetBtnWidth(BtnID: Integer; const Value: Integer);\r
asm\r
        PUSH     EBX\r
        MOV      EBX, ECX\r
\r
        PUSH     EAX\r
        CALL     GetTBBtnGoodID\r
        POP      EDX\r
\r
        ADD      ESP, -24\r
        PUSH     TBIF_SIZE or TBIF_STYLE\r
        PUSH     32\r
        MOV      ECX, ESP\r
\r
        PUSH     ECX\r
        PUSH     EAX\r
        PUSH     TB_SETBUTTONINFO\r
        PUSH     EDX\r
\r
        PUSH     ECX\r
        PUSH     EAX\r
        PUSH     TB_GETBUTTONINFO\r
        PUSH     EDX\r
        CALL     Perform\r
\r
        MOV      [ESP+16+18], BX\r
        AND      byte ptr [ESP+16].TTBButtonInfo.fsStyle, not TBSTYLE_AUTOSIZE\r
        CALL     Perform\r
        ADD      ESP, 32\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.TBSetBtnWidth(BtnID: Integer; const Value: Integer);\r
var BI: TTBButtonInfo;\r
begin\r
  BI.cbSize := Sizeof( BI );\r
  BI.dwMask := TBIF_SIZE or TBIF_STYLE;\r
  BtnID := GetTBBtnGoodID( @Self, BtnID );\r
  Perform( TB_GETBUTTONINFO, BtnID, Integer( @BI ) );\r
  BI.cx := Value;\r
  BI.fsStyle := BI.fsStyle and not TBSTYLE_AUTOSIZE;\r
  Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.TBSetBtMinMaxWidth]\r
procedure TControl.TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer);\r
begin\r
  case Idx of\r
  0: FTBBtMinWidth := Value;\r
  1: FTBBtMaxWidth := Value;\r
  end;\r
  Perform( TB_SETBUTTONWIDTH, 0, FTBBtMaxWidth or (FTBBtMinWidth shl 16) );\r
end;\r
\r
{$IFDEF F_P}\r
//[function TControl.TBGetBtMinMaxWidth]\r
function TControl.TBGetBtMinMaxWidth(const Idx: Integer): Integer;\r
begin\r
  CASE Idx OF\r
  0: Result := FTBBtMinWidth;\r
  1: Result := FTBBtMaxWidth;\r
  END;\r
end;\r
{$ENDIF F_P}\r
\r
//[procedure TControl.SetDroppedDown]\r
procedure TControl.SetDroppedDown(const Value: Boolean);\r
begin\r
  //fDropped := Value;\r
  Perform( CB_SHOWDROPDOWN, Integer( Value ), 0 );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.AddDirList]\r
procedure TControl.AddDirList(const Filemask: String; Attrs: DWORD);\r
asm\r
        CALL     EDX2PChar\r
        PUSH     EDX\r
        PUSH     ECX\r
        MOVZX    ECX, [EAX].fCommandActions.aDir\r
        JECXZ    @@exit\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     Perform\r
        RET\r
@@exit:\r
        POP      ECX\r
        POP      ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.AddDirList(const Filemask: String; Attrs: DWORD);\r
begin\r
  if fCommandActions.aDir <> 0 then\r
  Perform( fCommandActions.aDir, Attrs, Integer( PChar( Filemask ) ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[FUNCTION WndProcShowModal]\r
{$IFDEF ASM_VERSION}\r
function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm\r
        CMP      word ptr [EDX].TMsg.message, WM_CLOSE\r
        JNZ      @@ret_false\r
{//++++++ AP\r
        PUSH     EBX\r
        MOV      EBX, 1\r
        CMP      [EAX].TControl.fOnClose.TMethod.Code, 0\r
        JZ       @@AP1\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     ECX\r
        XCHG     EDX, EAX\r
        PUSH     EBX\r
        MOV      ECX, ESP\r
        MOV      EAX, [EDX].TControl.fOnClose.TMethod.Data\r
        CALL     dword ptr [EDX].TControl.fOnClose.TMethod.Code\r
        POP      EBX\r
        POP      ECX\r
        POP      EDX\r
        POP      EAX\r
@@AP1:\r
//------ AP}\r
\r
        XCHG     EDX, EAX\r
        XOR      EAX, EAX\r
        CMP      [EDX].TControl.fModalResult, EAX\r
        JNZ      @@1\r
        OR       [EDX].TControl.fModalResult, -1\r
@@1:\r
{//++++++ AP\r
        TEST     BL, BL\r
        JNZ      @@AP2\r
        MOV      [EDX].TControl.fModalResult, 0\r
@@AP2:\r
        POP      EBX\r
//------ AP}\r
\r
        MOV      [ECX], EAX\r
        INC      EAX\r
        RET\r
@@ret_false:\r
        XOR      EAX, EAX\r
\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
//var Accept: Boolean; // {Alexander Pravdin, AP}\r
begin\r
  if Msg.message = WM_CLOSE then\r
  begin\r
    //++++++++ {AP} +++++++++++++++++++++++++++++++++++++++++++++++++++++++//\r
    {Accept := True;                                                       //\r
    if Assigned( Self_.fOnClose ) then Self_.fOnClose( Self_, Accept );  //\r
    }//-------- {AP} ----------------------------------------------------//\r
    if Self_.ModalResult = 0 then { (Sergey Shishmintzev) }\r
      Self_.ModalResult := -1;\r
    //++++++++ {AP} +++++++++++++++++++++++++++++++++++++++++++++++++++++++//\r
    {if not Accept then                     //\r
      Self_.ModalResult := 0; //íå çàêðûâàåì ôîðìó, îñòàâëÿÿ å¸ íà ýêðàíå//\r
    }//-------- {AP} ----------------------------------------------------//\r
    Rslt := 0;\r
    Result := True; // Do not process !\r
  end\r
    else\r
    Result := False;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcShowModal]\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TControl.ShowModal]\r
function TControl.ShowModal: Integer;\r
asm\r
        MOV      ECX, [EAX].fParent\r
        JECXZ    @@show\r
        MOVZX    ECX, [EAX].fIsControl\r
        JECXZ    @@show_modal\r
@@show:\r
        CALL     Show\r
        XOR      EAX, EAX\r
        RET\r
@@show_modal:\r
        PUSHAD\r
\r
        MOV      EBX, EAX\r
        MOV      EDI, [Applet]\r
\r
        XOR      EBP, EBP  // CurCtl = nil\r
\r
        MOV      EAX, [EDI].fCurrentControl\r
        CMP      [EDI].TControl.FIsApplet, 0\r
        {$IFDEF USE_CMOV}\r
        CMOVZ    EAX, EDI\r
        {$ELSE}\r
        JNZ      @@curctrl_save\r
        MOV      EAX, EDI\r
@@curctrl_save:\r
        {$ENDIF}\r
\r
        PUSH     EAX\r
\r
        MOV      EDX, offset[WndProcShowModal]\r
        PUSH     EDX\r
\r
        MOV      EAX, EBX\r
        CALL     TControl.AttachProc\r
        XOR      EDX, EDX\r
        MOV      [EBX].fModalResult, EDX\r
\r
        CALL     NewList\r
        XCHG     EAX, EBP\r
\r
        XOR      ECX, ECX\r
        INC      ECX\r
        MOV      ESI, EDI\r
\r
        CMP      [EDI].TControl.FIsApplet, 0\r
        JZ       @@isapplet\r
\r
        MOV      EBP, [EDI].fCurrentControl // CurCtl = Applet.fCurrentControl\r
\r
        MOV      ESI, [EDI].fChildren\r
        MOV      ECX, [ESI].TList.fCount\r
        MOV      ESI, [ESI].TList.fItems\r
\r
@@1loo: LODSD\r
\r
@@isapplet:\r
\r
        PUSH     ECX\r
        CMP      EAX, EBX\r
        JE       @@1nx\r
        PUSH     EAX\r
        CALL     GetEnabled\r
        TEST     AL, AL\r
        POP      EAX\r
        JZ       @@1nx\r
        PUSH     EAX\r
        MOV      DL, 0\r
        CALL     SetEnabled\r
        POP      EDX\r
        MOV      EAX, EBP\r
        CALL     TList.Add\r
@@1nx:  POP      ECX\r
        LOOP     @@1loo\r
\r
        INC      [EBX].fModal\r
        MOV      EAX, [Applet]\r
        MOV      [EAX].fModalForm, EBX\r
\r
        MOV      EAX, EBX\r
        CALL     Show\r
\r
@@msgloo:\r
        MOVZX    ECX, [AppletTerminated]\r
        OR       ECX, [EBX].fModalResult\r
        JNZ      @@e_msgloo\r
        CALL     WaitMessage\r
        MOV      EAX, EDI\r
        CALL     ProcessMessages\r
        {$IFNDEF NOT_USE_OnIdle}\r
        MOV      EAX, EBX\r
        CALL     [ProcessIdle]\r
        {$ENDIF}\r
        JMP      @@msgloo\r
\r
@@e_msgloo:\r
        POP      EDX\r
        MOV      EAX, EBX\r
        CALL     TControl.DetachProc\r
\r
        DEC      [EBX].fModal\r
        MOV      EAX, [Applet]\r
        XOR      ECX, ECX\r
        MOV      [EAX].fModalForm, ECX\r
\r
        MOV      ECX, [EBP].TList.fCount\r
        JECXZ    @@2end\r
        MOV      ESI, [EBP].TList.fItems\r
\r
@@2loo: LODSD\r
        PUSH     ECX\r
        MOV      DL, 1\r
        CALL     TControl.SetEnabled\r
        POP      ECX\r
        LOOP     @@2loo\r
\r
@@2end:\r
        MOV      EAX, EBP\r
        CALL     TObj.Free\r
\r
        POP      ECX\r
        JECXZ    @@exit\r
        PUSH     0\r
        PUSH     WA_ACTIVE\r
        PUSH     WM_ACTIVATE\r
        PUSH     [ECX].fHandle\r
        CALL     PostMessage\r
\r
        TEST     EBP, EBP  // CurCtl = nil ?\r
        JZ       @@exit\r
        MOV      EAX, EBP\r
        MOV      DL, 1\r
        CALL     TControl.SetFocused\r
\r
@@exit:\r
        POPAD\r
        MOV      EAX, [EAX].fModalResult\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
{$IFDEF USE_SHOWMODALPARENTED_ALWAYS}\r
function TControl.ShowModal: Integer;\r
begin\r
  Result := ShowModalParented(Applet);\r
end;\r
{$ELSE not USE_SHOWMODALPARENTED_ALWAYS}\r
function TControl.ShowModal: Integer;\r
var FL: PList;\r
var CurForm: PControl;\r
    I: Integer;\r
    F: PControl;\r
    CurCtl: PControl; // { Alexander Pravdin }\r
begin\r
  Result := 0;\r
  if (fIsControl) or (fParent = nil) then\r
  begin\r
    Show;\r
    Exit;\r
  end;\r
  AttachProc( WndProcShowModal );\r
  CurForm := Applet.fCurrentControl;\r
  FL := NewList;\r
  CurCtl := nil; // { Alexander Pravdin }\r
\r
  if Applet.IsApplet then\r
  for I := 0 to Applet.ChildCount - 1 do\r
  begin\r
    F := Applet.fChildren.Items[ I ];\r
    if F <> @Self then\r
    if F.Enabled then\r
    begin\r
       FL.Add( F );\r
       F.Enabled := FALSE;\r
    end;\r
  end\r
  else\r
    begin\r
      CurForm := Applet;\r
      if Applet.Enabled then\r
      begin\r
        FL.Add( Applet );\r
        CurCtl := Applet.fCurrentControl; { Alexander Pravdin }\r
        Applet.Enabled := FALSE;\r
      end;\r
    end;\r
\r
  Inc( fModal );\r
  Applet.fModalForm := @ Self;\r
  Enabled := TRUE;\r
\r
  Show;\r
  ModalResult := 0;\r
  while not AppletTerminated and (ModalResult = 0) do\r
  begin\r
    WaitMessage;\r
    Applet.ProcessMessages;\r
    {$IFNDEF NOT_USE_OnIdle}\r
    ProcessIdle( @Self );\r
    {$ENDIF}\r
  end;\r
\r
  Dec( fModal );\r
  Applet.fModalForm := nil;\r
\r
  DetachProc( WndProcShowModal );\r
  for I := 0 to FL.Count - 1 do\r
  begin\r
    F := FL.Items[ I ];\r
    F.Enabled := TRUE;\r
    //EnableWindow( F.Handle, TRUE );\r
    //F.Perform( WM_ENABLE, 1, 0 );\r
  end;\r
  FL.Free;\r
\r
  if CurForm <> nil then\r
    PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 );\r
  if CurCtl <> nil then CurCtl.SetFocused( TRUE ); { Alexander Pravdin }\r
\r
  Result := ModalResult;\r
end;\r
{$ENDIF USE_SHOWMODALPARENTED_ALWAYS}\r
{$ENDIF ASM_VERSION}\r
\r
//[function TControl.ShowModalParented]\r
{$IFNDEF NEW_MODAL}\r
function TControl.ShowModalParented( const AParent: PControl ): Integer;\r
begin\r
  Result := 0;\r
end;\r
{$ELSE NEW_MODAL defined}\r
function TControl.ShowModalParented( const AParent: PControl ): Integer;\r
var\r
  FL: PList;\r
  OldMF, F: PControl;\r
  I: Integer;\r
begin\r
  Result := 0;\r
  if ( AParent = nil ) then Exit;\r
\r
  Inc( fModal );\r
  FL := NewList;\r
  OldMF := AParent.fModalForm;\r
  AParent.fModalForm := @Self;\r
\r
  if AParent.fIsApplet or ( AParent.IsMainWindow and AParent.fIsForm ) then\r
  begin\r
    for I := 0 to AParent.ChildCount - 1 do\r
    begin\r
      F := AParent.fChildren.Items[ I ];\r
      if ( F <> @Self ) and F.fIsForm and F.fEnabled and F.fVisible then\r
      begin\r
        FL.Add( F );\r
        F.Enabled := FALSE;\r
      end;\r
    end;\r
  end;\r
\r
  if AParent.fIsForm and AParent.Enabled then\r
  begin\r
    FL.Add( AParent );\r
    AParent.Enabled := FALSE;\r
  end;\r
\r
  ModalResult := 0;\r
  Show;\r
  while not AppletTerminated and ( ModalResult = 0 ) do\r
  begin\r
    WaitMessage;\r
    AParent.ProcessMessages;\r
{$IFNDEF NOT_USE_OnIdle}\r
    ProcessIdle( @Self );\r
{$ENDIF}\r
  end;\r
\r
  AParent.fModalForm := OldMF;\r
  Dec( fModal );\r
  for I := 0 to FL.Count - 1 do\r
    PControl( FL.Items[ I ] ).Enabled := True;\r
  FL.Free;\r
  Hide;\r
  Result := ModalResult;\r
end;\r
{$ENDIF NEW_MODAL}\r
\r
//[function DisableWindows]\r
function DisableWindows( W: hwnd; LPARAM: Integer ): Bool; stdcall;\r
var FL: PList;\r
    Buf: array[ 0..127 ] of Char;\r
begin\r
  FL := Pointer( LPARAM );\r
  if IsWindowEnabled( W ) and (W <> FL.Tag) then\r
  begin\r
    GetClassName( W, @ Buf[ 0 ], Sizeof( Buf ) );\r
    if Buf <> 'ComboLBox' then\r
    begin\r
      FL.Add( Pointer( W ) );\r
      EnableWindow( W, FALSE );\r
    end;\r
  end;\r
  Result := TRUE;\r
end;\r
\r
//[function TControl.ShowModalEx]\r
function TControl.ShowModalEx: Integer;\r
var FL: PList;\r
var CurForm: PControl;\r
    I: Integer;\r
    W: HWnd;\r
    CurCtl: PControl; { Alexander Pravdin }\r
begin\r
  Result := 0;\r
  if (fIsControl) or (fParent = nil) then\r
  begin\r
    Show;\r
    Exit;\r
  end;\r
  AttachProc( WndProcShowModal );\r
  CurForm := Applet.fCurrentControl;\r
  FL := NewList;\r
  FL.Tag := fHandle;\r
\r
  // ++++ { Alexander Pravdin }\r
  if not Applet.fIsApplet then CurCtl := Applet.fCurrentControl\r
                          else CurCtl := nil;\r
  // ----\r
  CreateWindow;\r
\r
  EnumThreadWindows( GetCurrentThreadID, @ DisableWindows, Integer( FL ) );\r
  Enabled := TRUE;\r
\r
  Inc( fModal );\r
  Applet.fModalForm := @ Self;\r
  Show;\r
  ModalResult := 0;\r
  while not AppletTerminated and (ModalResult = 0) do\r
  begin\r
    WaitMessage;\r
    Applet.ProcessMessages;\r
    {$IFNDEF NOT_USE_OnIdle}\r
    ProcessIdle( @Self );\r
    {$ENDIF}\r
  end;\r
\r
  Dec( fModal );\r
  Applet.fModalForm := @ Self;\r
\r
  DetachProc( WndProcShowModal );\r
\r
  for I := 0 to FL.Count - 1 do\r
  begin\r
    W := THandle( FL.Items[ I ] );\r
    EnableWindow( W, TRUE );\r
  end;\r
  FL.Free;\r
\r
  if CurForm <> nil then\r
    PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 );\r
  if CurCtl <> nil then CurCtl.SetFocused( True ); { Alexander Pravdin }\r
  Result := ModalResult;\r
end;\r
\r
//[function TControl.GetModal]\r
function TControl.GetModal: Boolean;\r
begin\r
  Result := fModal > 0;\r
end;\r
\r
{$IFDEF USE_SETMODALRESULT}\r
//[procedure TControl.SetModalResult]\r
procedure TControl.SetModalResult( const Value: Integer );\r
begin\r
  //if fModal <= 0 then Exit;\r
  fModalResult := Value;\r
  if Value <> 0 then\r
    PostMessage( GetWindowHandle, 0, 0, 0 );\r
end;\r
{$ENDIF}\r
\r
\r
//////////////////////////////////////////////////////////////////\r
//\r
//                          T  I  M  E  R\r
//\r
//////////////////////////////////////////////////////////////////\r
\r
var TimerOwnerWnd: PControl;\r
    TimerCount: Integer = 0;\r
\r
{ -- Constructor of timer -- }\r
\r
//[function NewTimer]\r
function NewTimer( Interval: Integer ): PTimer;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PTimer.Create;*){--}\r
  if Interval <= 0 then Interval := 1000;\r
  Result.fInterval := Interval;\r
  Inc( TimerCount );\r
end;\r
//[END NewTimer]\r
\r
{ -- Timer procedure -- }\r
\r
//[FUNCTION TimerProc]\r
{$IFDEF ASM_VERSION}\r
function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer;\r
          stdcall;\r
asm     //cmd    //opd\r
        MOV      EDX, T\r
        MOV      ECX, [EDX].TTimer.fOnTimer.TMethod.Code\r
        JECXZ    @@exit\r
        MOV      EAX, [EDX].TTimer.fOnTimer.TMethod.Data\r
        CALL     ECX\r
@@exit: XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer;\r
          stdcall;\r
begin\r
  if Assigned( T.fOnTimer ) then\r
     T.fOnTimer( T );\r
   Result := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END TimerProc]\r
\r
{ TTimer }\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TTimer.Destroy]\r
destructor TTimer.Destroy;\r
asm\r
        PUSH     EAX\r
        XOR      EDX, EDX\r
        CALL     TTimer.SetEnabled\r
        POP      EAX\r
        CALL     TObj.Destroy\r
        DEC      [TimerCount]\r
        JNZ      @@exit\r
        XOR      EAX, EAX\r
        XCHG     EAX, [TimerOwnerWnd]\r
        CALL     TObj.Free\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TTimer.Destroy;\r
begin\r
  Enabled := False;\r
  inherited;\r
  Dec( TimerCount );\r
  if TimerCount = 0 then\r
  begin\r
    TimerOwnerWnd.Free;\r
    TimerOwnerWnd := nil;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TTimer.SetEnabled]\r
procedure TTimer.SetEnabled(const Value: Boolean);\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
\r
        CMP      [EBX].fEnabled, DL\r
        JZ       @@exit\r
\r
        MOV      [EBX].fEnabled, DL\r
\r
        TEST     DL, DL\r
        JZ       @@disable\r
\r
        MOV      ECX, [TimerOwnerWnd]\r
        INC      ECX\r
        LOOP     @@owner_ready\r
\r
        INC      ECX\r
        MOV      EDX, offset[EmptyString]\r
        XOR      EAX, EAX\r
        CALL     _NewWindowed\r
        MOV      [TimerOwnerWnd], EAX\r
        MOV      [EAX].TControl.fStyle, 0\r
        INC      [EAX].TControl.fIsControl\r
        XCHG     ECX, EAX\r
\r
@@owner_ready:\r
\r
        PUSH     offset[TimerProc]\r
        PUSH     [EBX].fInterval\r
        PUSH     EBX\r
        XCHG     EAX, ECX\r
        CALL     TControl.GetWindowHandle\r
        PUSH     EAX\r
        CALL     SetTimer\r
        MOV      [EBX].fHandle, EAX\r
\r
        JMP      @@exit\r
\r
@@disable:\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EBX].TTimer.fHandle\r
        JECXZ    @@exit\r
\r
        PUSH     ECX\r
        MOV      EAX, [TimerOwnerWnd]\r
        PUSH     [EAX].TControl.fHandle\r
        CALL     KillTimer\r
\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TTimer.SetEnabled(const Value: Boolean);\r
begin\r
  if FEnabled = Value then Exit;\r
  fEnabled := Value;\r
  if Value then\r
  begin\r
    if TimerOwnerWnd = nil then\r
    begin\r
      TimerOwnerWnd := _NewWindowed( nil, '', TRUE );\r
      TimerOwnerWnd.fStyle := 0;\r
      TimerOwnerWnd.fIsControl := TRUE;\r
    end;\r
    fHandle := SetTimer( TimerOwnerWnd.GetWindowHandle, Integer( @Self ),\r
                         fInterval, @TimerProc );\r
  end\r
     else\r
  begin\r
    if fHandle <> 0 then\r
    begin\r
      KillTimer( TimerOwnerWnd.fHandle, fHandle );\r
      fHandle := 0;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TTimer.SetInterval]\r
procedure TTimer.SetInterval(const Value: Integer);\r
asm\r
        CMP      EDX, [EAX].fInterval\r
        JE       @@exit\r
        MOV      [EAX].fInterval, EDX\r
        PUSH     dword ptr [EAX].fEnabled\r
        PUSH     EAX\r
        XOR      EDX, EDX\r
        CALL     SetEnabled\r
        POP      EAX\r
        POP      EDX\r
        CALL     SetEnabled\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TTimer.SetInterval(const Value: Integer);\r
var WasEnabled : Boolean;\r
begin\r
  if fInterval = Value then Exit;\r
  fInterval := Value;\r
  WasEnabled := Enabled;\r
  Enabled := False;\r
  Enabled := WasEnabled;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
\r
{ TMMTimer }\r
\r
{ ------------ declarations moved here from MMSystem -------------------- }\r
const\r
  TIME_ONESHOT    = 0;   { program timer for single event }\r
  TIME_PERIODIC   = 1;   { program for continuous periodic event }\r
  TIME_CALLBACK_FUNCTION    = $0000;  { callback is function }\r
  TIME_CALLBACK_EVENT_SET   = $0010;  { callback is event - use SetEvent }\r
  TIME_CALLBACK_EVENT_PULSE = $0020;  { callback is event - use PulseEvent }\r
\r
type\r
  TFNTimeCallBack = procedure(uTimerID, uMessage: UINT;\r
    dwUser, dw1, dw2: DWORD) stdcall;\r
//[API timeSetEvent]\r
function timeSetEvent(uDelay, uResolution: UINT;\r
  lpFunction: TFNTimeCallBack; dwUser: DWORD; uFlags: UINT): THandle; stdcall;\r
  external 'winmm.dll' name 'timeSetEvent';\r
function timeKillEvent(uTimerID: UINT): Integer; stdcall;\r
  external 'winmm.dll' name 'timeKillEvent';\r
{ ----------------------------------------------------------------------- }\r
\r
//[procedure MMTimerCallback]\r
procedure MMTimerCallback(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD);\r
          stdcall;\r
var MMTimer: PMMTimer;\r
begin\r
  MMTimer := Pointer( dwUser );\r
  if Assigned( MMTimer.FOnTimer ) then\r
    MMTimer.fOnTimer( MMTimer );\r
end;\r
\r
//[function NewMMTimer]\r
function NewMMTimer( Interval: Integer ): PMMTimer;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+} {++}(* Result := PMMTimer.Create; *){--}\r
  Result.fInterval := Interval;\r
  Result.FPeriodic := TRUE;\r
end;\r
//[END NewMMTimer]\r
\r
//[destructor TMMTimer.Destroy]\r
destructor TMMTimer.Destroy;\r
begin\r
  Enabled := FALSE;\r
  Inc( TimerCount );\r
  inherited;\r
end;\r
\r
//[procedure TMMTimer.SetEnabled]\r
procedure TMMTimer.SetEnabled(const Value: Boolean);\r
begin\r
  if Value xor (fHandle <> 0) then\r
  begin\r
    if fHandle = 0 then\r
      fHandle := timeSetEvent( Interval, Resolution, MMTimerCallback, DWORD( @ Self ),\r
              Integer( Periodic ) or TIME_CALLBACK_FUNCTION )\r
    else\r
    begin\r
      timeKillEvent( fHandle );\r
      fHandle := 0;\r
    end;\r
  end;\r
  fEnabled := Value;\r
end;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
////////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                         t  B  I  T  M  A  P\r
//\r
//\r
///////////////////////////////////////////////////////////////////////\r
\r
{ -- bitmap -- }\r
\r
//[FUNCTION PrepareBitmapHeader]\r
{$IFDEF ASM_VERSION}\r
function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo;\r
const szIH = sizeof(TBitmapInfoHeader);\r
      szHd = szIH + 256 * Sizeof(TRGBQuad);\r
asm\r
        PUSH     EDI\r
\r
          PUSH     ECX  // BitsPerPixel\r
        PUSH     EDX    // H\r
        PUSH     EAX    // W\r
\r
        MOV      EAX, szHd\r
        CALL     AllocMem\r
\r
        MOV      EDI, EAX\r
        XCHG     ECX, EAX\r
\r
        XOR      EAX, EAX\r
        MOV      AL, szIH\r
        STOSD           // biSize = Sizeof( TBitmapInfoHeader )\r
        POP      EAX    // ^ W\r
        STOSD           // -> biWidth\r
        POP      EAX    // ^ H\r
        STOSD           // -> biHeight\r
        XOR      EAX, EAX\r
        INC      EAX\r
        STOSW           // 1 -> biPlanes\r
          POP      EAX  // ^ BitsPerPixel\r
        STOSW           // -> biBitCount\r
\r
        XCHG     EAX, ECX // EAX = Result\r
        POP      EDI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo;\r
begin\r
  Assert( W > 0, 'Width must be >0' );\r
  Assert( H > 0, 'Height must be >0' );\r
\r
  Result := AllocMem( 256*Sizeof(TRGBQuad)+Sizeof(TBitmapInfoHeader) );\r
  Assert( Result <> nil, 'No memory' );\r
\r
  Result.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );\r
  Result.bmiHeader.biWidth := W;\r
  Result.bmiHeader.biHeight := H; // may be, -H ?\r
  Result.bmiHeader.biPlanes := 1;\r
  Result.bmiHeader.biBitCount := BitsPerPixel;\r
  //Result.bmiHeader.biCompression := BI_RGB; // BI_RGB = 0\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END PrepareBitmapHeader]\r
\r
const\r
  BitsPerPixel_By_PixelFormat: array[ TPixelFormat ] of Byte =\r
                               ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );\r
\r
//[FUNCTION Bits2PixelFormat]\r
{$IFDEF ASM_VERSION}\r
function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;\r
asm\r
        PUSH     ESI\r
        MOV      ESI, offset[ BitsPerPixel_By_PixelFormat + 1 ]\r
        XOR      ECX, ECX\r
        XCHG     EDX, EAX\r
@@loo:  INC      ECX\r
        LODSB\r
        CMP      AL, DL\r
        JZ       @@exit\r
        TEST     AL, AL\r
        JNZ      @@loo\r
@@exit: XCHG     EAX, ECX\r
        POP      ESI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;\r
var I: TPixelFormat;\r
begin\r
  for I := High(I) downto Low(I) do\r
    if BitsPerPixel = BitsPerPixel_By_PixelFormat[ I ] then\r
    begin\r
      Result := I;\r
      Exit;\r
    end;\r
  Result := pfDevice;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END Bits2PixelFormat]\r
\r
//[procedure DummyDetachCanvas]\r
procedure DummyDetachCanvas( Sender: PBitmap );\r
begin\r
end;\r
\r
//[FUNCTION _NewBitmap]\r
{$IFDEF ASM_VERSION}\r
function _NewBitmap( W, H: Integer ): PBitmap;\r
begin\r
  New( Result, Create );\r
  Result.fDetachCanvas := DummyDetachCanvas;\r
  Result.fWidth := W;\r
  Result.fHeight := H;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _NewBitmap]\r
\r
//[FUNCTION NewBitmap]\r
{$IFDEF ASM_VERSION}\r
function NewBitmap( W, H: Integer ): PBitmap;\r
asm\r
        PUSH     EAX\r
        PUSH     EDX\r
        CALL     _NewBitmap\r
        POP      EDX\r
        POP      ECX\r
        PUSH     EAX\r
        INC      [EAX].TBitmap.fHandleType\r
        JECXZ    @@exit\r
        TEST     EDX, EDX\r
        JZ       @@exit\r
        PUSH     EBX\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     ECX\r
        PUSH     0\r
        CALL     GetDC\r
        PUSH     EAX\r
        XCHG     EBX, EAX\r
        CALL     CreateCompatibleBitmap\r
        POP      EDX\r
        MOV      [EDX].TBitmap.fHandle, EAX\r
        PUSH     EBX\r
        PUSH     0\r
        CALL     ReleaseDC\r
        POP      EBX\r
@@exit: POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewBitmap( W, H: Integer ): PBitmap;\r
var DC: HDC;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PBitmap.Create;*){--}\r
  Result.fHandleType := bmDDB;\r
  Result.fDetachCanvas := DummyDetachCanvas;\r
  Result.fWidth := W;\r
  Result.fHeight := H;\r
  if (W <> 0) and (H <> 0) then\r
  begin\r
    //DC := CreateCompatibleDC( 0 );\r
    DC := GetDC( 0 );\r
    Result.fHandle := CreateCompatibleBitmap( DC, W, H );\r
    Assert( Result.fHandle <> 0, 'Can not create bitmap handle' );\r
    //DeleteDC( DC );\r
    ReleaseDC( 0, DC );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewBitmap]\r
\r
const InitColors: array[ 0..17 ] of DWORD = ( $F800, $7E0, $1F, 0, $800000, $8000,\r
      $808000, $80, $800080, $8080, $808080, $C0C0C0, $FF0000, $FF00, $FFFF00, $FF,\r
      $FF00FF, $FFFF );\r
//[PROCEDURE PreparePF16bit]\r
{$IFDEF ASM_VERSION}\r
procedure PreparePF16bit( DIBHeader: PBitmapInfo );\r
const szBIH = sizeof(TBitmapInfoHeader);\r
asm\r
        MOV      byte ptr [EAX].TBitmapInfoHeader.biCompression, BI_BITFIELDS\r
        ADD      EAX, szBIH\r
        XCHG     EDX, EAX\r
        MOV      EAX, offset[InitColors]\r
        XOR      ECX, ECX\r
        MOV      CL, 19*4\r
        CALL     System.Move\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure PreparePF16bit( DIBHeader: PBitmapInfo );\r
begin\r
        DIBHeader.bmiHeader.biCompression := BI_BITFIELDS;\r
        Move( InitColors[ 0 ], DIBHeader.bmiColors[ 0 ], 19*Sizeof(TRGBQUAD) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END PreparePF16bit]\r
\r
//[FUNCTION NewDIBBitmap]\r
{$IFDEF ASM_VERSION}\r
function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;\r
asm\r
        PUSH     EBX\r
\r
        PUSH     ECX\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     _NewBitmap\r
        XCHG     EBX, EAX\r
        POP      EAX //W\r
        POP      EDX //H\r
        POP      ECX //PixelFormat\r
\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        TEST     EDX, EDX\r
        JZ       @@exit\r
\r
        PUSH     EAX\r
        MOVZX    EAX, CL\r
        JMP      @@loadBitsPixel\r
@@loadDefault:\r
        MOVZX    EAX, [DefaultPixelFormat]\r
@@loadBitsPixel:\r
        MOVZX    ECX, byte ptr [ BitsPerPixel_By_PixelFormat + EAX ]\r
        JECXZ    @@loadDefault\r
        MOV      [EBX].TBitmap.fNewPixelFormat, AL\r
        {$IFDEF PARANOIA}\r
        DB $3C, pf16bit\r
        {$ELSE}\r
        CMP      AL, pf16bit\r
        {$ENDIF}\r
        POP      EAX\r
\r
        PUSHFD\r
        CALL     PrepareBitmapHeader\r
        MOV      [EBX].TBitmap.fDIBHeader, EAX\r
        POPFD\r
        JNZ      @@2\r
\r
        CALL     PreparePF16bit\r
\r
@@2:\r
        MOV      EAX, EBX\r
        CALL     TBitmap.GetScanLineSize\r
        MOV      EDX, [EBX].TBitmap.fHeight\r
        MUL      EDX\r
        MOV      [EBX].TBitmap.fDIBSize, EAX\r
        CALL     AllocMem\r
        MOV      [EBX].TBitmap.fDIBBits, EAX\r
@@exit:\r
        XCHG     EAX, EBX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;\r
const BitsPerPixel: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );\r
var BitsPixel: Integer;\r
    //AField: PDWORD;\r
    //DC0 : HDC;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PBitmap.Create;*){--}\r
  Result.fDetachCanvas := DummyDetachCanvas;\r
  Result.fWidth := W;\r
  Result.fHeight := H;\r
  if (W <> 0) and (H <> 0) then\r
  begin\r
    BitsPixel := BitsPerPixel[ PixelFormat ];\r
    if BitsPixel = 0 then\r
    begin\r
       Result.fNewPixelFormat := DefaultPixelFormat;\r
       BitsPixel := BitsPerPixel[DefaultPixelFormat];\r
    end\r
       else\r
       Result.fNewPixelFormat := PixelFormat;\r
    ASSERT( Result.fNewPixelFormat in [ pf1bit..pf32bit ], 'Strange pixel format' );\r
    Result.fDIBHeader := PrepareBitmapHeader( W, H, BitsPixel );\r
    if PixelFormat = pf16bit then\r
    begin\r
      PreparePF16bit( Result.fDIBHeader );\r
      {\r
      Result.fDIBHeader.bmiHeader.biCompression := BI_BITFIELDS;\r
      AField := @Result.fDIBHeader.bmiColors[ 0 ];\r
      AField^ := $F800; Inc( AField );\r
      AField^ := $07E0; Inc( AField );\r
      AField^ := $001F; Inc( AField );\r
      DC0 := CreateCompatibleDC( 0 );\r
      GetSystemPaletteEntries( DC0, 0, 16, AField^ );\r
      DeleteDC( DC0 );\r
      }\r
    end;\r
\r
    Result.fDIBSize := Result.ScanLineSize * H;\r
    Result.fDIBBits := AllocMem( Result.fDIBSize );\r
    ASSERT( Result.fDIBBits <> nil, 'No memory' );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END NewDIBBitmap]\r
\r
{ TBitmap }\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.ClearData]\r
procedure TBitmap.ClearData;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CALL     [EBX].fDetachCanvas\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EBX].fHandle\r
        JECXZ    @@1\r
        PUSH     ECX\r
        CALL     DeleteObject\r
        XOR      ECX, ECX\r
        MOV      [EBX].fDIBBits, ECX\r
@@1:    XCHG     ECX, [EBX].fDIBBits\r
        JECXZ    @@2\r
        XCHG     EAX, ECX\r
        CALL     System.@FreeMem\r
@@2:    XOR      ECX, ECX\r
        XCHG     ECX, [EBX].fDIBHeader\r
        JECXZ    @@3\r
        XCHG     EAX, ECX\r
        CALL     System.@FreeMem\r
@@3:    XOR      EAX, EAX\r
        MOV      [EBX].fScanLineSize, EAX\r
        MOV      [EBX].fGetDIBPixels, EAX\r
        MOV      [EBX].fSetDIBPixels, EAX\r
        XCHG     EAX, EBX\r
        POP      EBX\r
        CALL     ClearTransImage\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.ClearData;\r
begin\r
  fDetachCanvas( @Self );\r
  if fHandle <> 0 then\r
  begin\r
    DeleteObject( fHandle );\r
    fHandle := 0;\r
    fDIBBits := nil;\r
    //fDIBHeader := nil;\r
  end;\r
  if fDIBBits <> nil then\r
  begin\r
    FreeMem( fDIBBits );\r
    fDIBBits := nil;\r
  end;\r
  if fDIBHeader <> nil then\r
  begin\r
    FreeMem( fDIBHeader );\r
    fDIBHeader := nil;\r
  end;\r
  fScanLineSize := 0;\r
  fGetDIBPixels := nil;\r
  fSetDIBPixels := nil;\r
  ClearTransImage;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.Clear]\r
procedure TBitmap.Clear;\r
asm\r
        PUSH     EAX\r
        CALL     RemoveCanvas\r
        POP      EAX\r
        PUSH     EAX\r
        CALL     ClearData\r
        POP      EAX\r
        XOR      EDX, EDX\r
        MOV      [EAX].fWidth, EDX\r
        MOV      [EAX].fHeight, EDX\r
        MOV      [EAX].fDIBAutoFree, DL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.Clear;\r
begin\r
  RemoveCanvas;\r
  ClearData;\r
  fWidth := 0;\r
  fHeight := 0;\r
  fDIBAutoFree := FALSE;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TBitmap.GetBoundsRect]\r
function TBitmap.GetBoundsRect: TRect;\r
begin\r
  Result := MakeRect( 0, 0, Width, Height );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TBitmap.Destroy]\r
destructor TBitmap.Destroy;\r
asm\r
        PUSH     EAX\r
        CALL     Clear\r
        POP      EAX\r
        CALL     TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TBitmap.Destroy;\r
begin\r
  Clear;\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TBitmap.BitsPerPixel]\r
function TBitmap.BitsPerPixel: Integer;\r
var B: tagBitmap;\r
begin\r
  CASE PixelFormat OF\r
  pf1bit: Result := 1;\r
  pf4bit: Result := 4;\r
  pf8bit: Result := 8;\r
  pf15bit: Result := 15;\r
  pf16bit: Result := 16;\r
  pf24bit: Result := 24;\r
  pf32bit: Result := 32;\r
  else begin\r
         Result := 0;\r
         if fHandle <> 0 then\r
         if GetObject( fHandle, Sizeof( B ), @B ) > 0 then\r
           Result := B.bmBitsPixel * B.bmPlanes;\r
       end;\r
  END;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.Draw]\r
procedure TBitmap.Draw(DC: HDC; X, Y: Integer);\r
const szBitmap = sizeof( tagBitmap );\r
asm                       // [EBP+8] = Y\r
        PUSH     EDX      // [EBP-4] = DC\r
        PUSH     ECX      // [EBP-8] = X\r
        PUSH     EBX\r
        PUSH     ESI\r
@@try_again:\r
        MOV      EBX, EAX\r
        CALL     GetEmpty // GetEmpty must be assembler version !\r
        JZ       @@exit\r
\r
        MOV      ECX, [EBX].fHandle\r
        JECXZ    @@2\r
\r
        //MOV      EAX, EBX\r
        //CALL     [EBX].fDetachCanvas // detached in StartDC\r
\r
        ADD      ESP, -szBitmap\r
        PUSH     ESP\r
        PUSH     szBitmap\r
        PUSH     [EBX].fHandle\r
        CALL     GetObject\r
        TEST     EAX, EAX\r
        MOV      ESI, [ESP].tagBitmap.bmHeight\r
        {$IFDEF USE_CMOV}\r
        CMOVZ    ESI, [EBX].fHeight\r
        {$ELSE}\r
        JNZ      @@1\r
        MOV      ESI, [EBX].fHeight\r
@@1:    {$ENDIF}\r
\r
        ADD      ESP, szBitmap\r
        CALL     StartDC\r
\r
        PUSH     SRCCOPY\r
        PUSH     0\r
        PUSH     0\r
        PUSH     EAX\r
        CALL     @@prepare\r
        CALL     BitBlt\r
        CALL     FinishDC\r
        JMP      @@exit\r
\r
@@prepare:\r
        XCHG     ESI, [ESP]\r
        PUSH     [EBX].fWidth\r
        PUSH     Y\r
        PUSH     dword ptr [EBP-8]\r
        PUSH     dword ptr [EBP-4]\r
        JMP      ESI\r
\r
@@2:\r
        MOV      ECX, [EBX].fDIBHeader\r
        JECXZ    @@exit\r
\r
        MOV      ESI, [ECX].TBitmapInfoHeader.biHeight\r
        TEST     ESI, ESI\r
        JGE      @@20\r
        NEG      ESI\r
@@20:\r
        PUSH     SRCCOPY\r
        PUSH     DIB_RGB_COLORS\r
        PUSH     ECX\r
        PUSH     [EBX].fDIBBits\r
        PUSH     ESI\r
        PUSH     [EBX].fWidth\r
        PUSH     0\r
        PUSH     0\r
        CALL     @@prepare\r
        CALL     StretchDIBits\r
        TEST     EAX, EAX\r
        JNZ      @@exit\r
        MOV      EAX, EBX\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        XCHG     EAX, EBX\r
        JNZ      @@try_again\r
@@exit:\r
        POP      ESI\r
        POP      EBX\r
        MOV      ESP, EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.Draw(DC: HDC; X, Y: Integer);\r
var\r
    DCfrom, DC0: HDC;\r
    oldBmp: HBitmap;\r
    oldHeight: Integer;\r
    B: tagBitmap;\r
label\r
    TRYAgain;\r
begin\r
TRYAgain:\r
  if Empty then Exit;\r
  if fHandle <> 0 then\r
  begin\r
    fDetachCanvas( @Self );\r
    oldHeight := fHeight;\r
    if GetObject( fHandle, sizeof( B ), @B ) <> 0 then\r
       oldHeight := B.bmHeight;\r
    ASSERT( oldHeight > 0, 'oldHeight must be > 0' );\r
\r
    DC0 := GetDC( 0 );\r
    DCfrom := CreateCompatibleDC( DC0 );\r
    ReleaseDC( 0, DC0 );\r
\r
    oldBmp := SelectObject( DCfrom, fHandle );\r
    ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );\r
\r
    BitBlt( DC, X, Y, fWidth, oldHeight, DCfrom, 0, 0, SRCCOPY );\r
    {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}\r
\r
    SelectObject( DCfrom, oldBmp );\r
    DeleteDC( DCfrom );\r
  end\r
     else\r
  if fDIBBits <> nil then\r
  begin\r
    oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);\r
    ASSERT( oldHeight > 0, 'oldHeight must be > 0' );\r
    ASSERT( fWidth > 0, 'Width must be > 0' );\r
    if StretchDIBits( DC, X, Y, fWidth, oldHeight, 0, 0, fWidth, oldHeight,\r
                   fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY ) = 0 then\r
    begin\r
      if GetHandle <> 0 then\r
        goto TRYAgain;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.StretchDraw]\r
procedure TBitmap.StretchDraw(DC: HDC; const Rect: TRect);\r
asm\r
        PUSH     EBX\r
        PUSH     EDI\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
        PUSH     EDX\r
        PUSH     ECX\r
        MOV      EBX, EAX\r
        CALL     GetEmpty\r
        JZ       @@exit\r
\r
        MOV      ECX, [EBX].fHandle\r
        JECXZ    @@2\r
\r
@@0:\r
        CALL     StartDC\r
        PUSH     SRCCOPY\r
        PUSH     [EBX].fHeight\r
        PUSH     [EBX].fWidth\r
        PUSH     0\r
        PUSH     0\r
        PUSH     EAX\r
\r
        CALL     @@prepare\r
        CALL     StretchBlt\r
        CALL     FinishDC\r
        JMP      @@exit\r
\r
@@prepare:\r
        POP      EDI\r
        MOV      EAX, [EBP-8]\r
        MOV      EDX, [EAX].TRect.Bottom\r
        MOV      ECX, [EAX].TRect.Top\r
        SUB      EDX, ECX\r
        PUSH     EDX\r
        MOV      EDX, [EAX].TRect.Right\r
        MOV      EAX, [EAX].TRect.Left\r
        SUB      EDX, EAX\r
        PUSH     EDX\r
        PUSH     ECX\r
        PUSH     EAX\r
        PUSH     dword ptr [EBP-4]\r
        JMP      EDI\r
\r
\r
@@2:    MOV      ECX, [EBX].fDIBHeader\r
        JECXZ    @@exit\r
\r
        PUSH     SRCCOPY\r
        PUSH     DIB_RGB_COLORS\r
        PUSH     ECX\r
        PUSH     [EBX].fDIBBits\r
        PUSH     [EBX].fHeight\r
        PUSH     [EBX].fWidth\r
        PUSH     0\r
        PUSH     0\r
        CALL     @@prepare\r
        CALL     StretchDIBits\r
        TEST     EAX, EAX\r
        JG       @@exit\r
\r
        MOV      EAX, EBX\r
        CALL     GetHandle\r
        MOV      ECX, [EBX].fHandle\r
        JECXZ    @@exit\r
        JMP      @@0\r
\r
@@exit: MOV      ESP, EBP\r
        POP      EBP\r
        POP      EDI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.StretchDraw(DC: HDC; const Rect: TRect);\r
var DCfrom: HDC;\r
    oldBmp: HBitmap;\r
label DrawHandle;\r
begin\r
  if Empty then Exit;\r
DrawHandle:\r
  if fHandle <> 0 then\r
  begin\r
    fDetachCanvas( @Self );\r
    DCfrom := CreateCompatibleDC( 0 );\r
    oldBmp := SelectObject( DCfrom, fHandle );\r
    ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );\r
    StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,\r
                Rect.Bottom - Rect.Top, DCfrom, 0, 0, fWidth, fHeight,\r
                SRCCOPY );\r
    SelectObject( DCfrom, oldBmp );\r
    DeleteDC( DCfrom );\r
  end\r
     else\r
  if fDIBBits <> nil then\r
  begin\r
    if StretchDIBits( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,\r
                Rect.Bottom - Rect.Top, 0, 0, fWidth, fHeight,\r
                fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY )<=0 then\r
    begin\r
      if GetHandle <> 0 then\r
        goto DrawHandle;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TBitmap.DrawMasked]\r
procedure TBitmap.DrawMasked(DC: HDC; X, Y: Integer; Mask: HBitmap);\r
begin\r
  StretchDrawMasked( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ), Mask );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.DrawTransparent]\r
procedure TBitmap.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor);\r
asm\r
        PUSH     ECX\r
        MOV      ECX, TranspColor\r
        INC      ECX\r
        MOV      ECX, [Y]\r
        JNZ      @@2\r
        XCHG     ECX, [ESP]\r
        CALL     Draw\r
        JMP      @@exit\r
@@2:\r
        ADD      ECX, [EAX].fHeight\r
        PUSH     ECX\r
        MOV      ECX, [EBP-4]\r
        ADD      ECX, [EAX].fWidth\r
        PUSH     ECX\r
        PUSH     [Y]\r
        PUSH     dword ptr [EBP-4]\r
        MOV      ECX, ESP\r
        PUSH     [TranspColor]\r
        CALL     StretchDrawTransparent\r
@@exit:\r
        MOV      ESP, EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor);\r
begin\r
  if TranspColor = clNone then\r
    Draw( DC, X, Y )\r
  else\r
    StretchDrawTransparent( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ),\r
                            TranspColor );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.StretchDrawTransparent]\r
procedure TBitmap.StretchDrawTransparent(DC: HDC; const Rect: TRect; TranspColor: TColor);\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [TranspColor]\r
        INC      EAX\r
        MOV      EAX, EBX\r
        JNZ      @@2\r
        CALL     StretchDraw\r
        JMP      @@exit\r
@@2:\r
        PUSH     EDX\r
        PUSH     ECX\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit2\r
\r
        MOV      EAX, [TranspColor]\r
        CALL     Color2RGB\r
        MOV      ECX, [EBX].fTransMaskBmp\r
        JECXZ    @@makemask0\r
        CMP      EAX, [EBX].fTransColor\r
        JE       @@3\r
@@makemask0:\r
        MOV      [EBX].fTransColor, EAX\r
        INC      ECX\r
        LOOP     @@20\r
        //MOV      EAX, [EBX].fWidth\r
        //MOV      EDX, [EBX].fHeight\r
        XOR      EAX, EAX // pass height = 0\r
        // absolutely no matter what to pass as width\r
        CALL     NewBitmap\r
        MOV      [EBX].fTransMaskBmp, EAX\r
@@20:\r
        MOV      EAX, [EBX].fTransMaskBmp\r
        PUSH     EAX\r
        MOV      EDX, EBX\r
        CALL     Assign\r
        POP      EAX\r
        MOV      EDX, [EBX].fTransColor\r
        CALL     Convert2Mask\r
@@3:\r
        MOV      EAX, [EBX].fTransMaskBmp\r
        CALL     GetHandle\r
        POP      ECX\r
        POP      EDX\r
        PUSH     EAX\r
        XCHG     EAX, EBX\r
        CALL     StretchDrawMasked\r
        JMP      @@exit\r
@@exit2:\r
        POP      ECX\r
        POP      EDX\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.StretchDrawTransparent(DC: HDC; const Rect: TRect; TranspColor: TColor);\r
begin\r
  if TranspColor = clNone then\r
     StretchDraw( DC, Rect )\r
  else\r
  begin\r
    if GetHandle = 0 then Exit;\r
    TranspColor := Color2RGB( TranspColor );\r
    if (fTransMaskBmp = nil) or (fTransColor <> TranspColor) then\r
    begin\r
      if fTransMaskBmp = nil then\r
        fTransMaskBmp := NewBitmap( 0, 0 {fWidth, fHeight} );\r
      fTransColor := TranspColor;\r
      // Create here mask bitmap:\r
      fTransMaskBmp.Assign( @Self );\r
      fTransMaskBmp.Convert2Mask( TranspColor );\r
    end;\r
    StretchDrawMasked( DC, Rect, fTransMaskBmp.Handle );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
const\r
  ROP_DstCopy = $00AA0029;\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.StretchDrawMasked]\r
procedure TBitmap.StretchDrawMasked(DC: HDC; const Rect: TRect; Mask: HBitmap);\r
asm\r
        PUSH     EDX                    // [EBP-4] = DC\r
        PUSH     ECX                    // [EBP-8] = Rect\r
        PUSH     EBX                    // save EBX\r
        MOV      EBX, EAX\r
        PUSH     ESI                    // save ESI\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@to_exit\r
\r
        PUSH     0\r
        CALL     CreateCompatibleDC\r
        PUSH     EAX                    // [EBP-20] = MaskDC\r
\r
        PUSH     [Mask]\r
        PUSH     EAX\r
        CALL     SelectObject\r
        PUSH     EAX                    // [EBP-24] = Save4Mask\r
\r
        CALL     StartDC                // [EBP-28] = DCfrom; [EBP-32] = Save4From\r
\r
        PUSH     [EBX].fHeight\r
        PUSH     [EBX].fWidth\r
        PUSH     EAX\r
        CALL     CreateCompatibleBitmap\r
        PUSH     EAX                    // [EBP-36] = MemBmp\r
\r
        PUSH     0\r
        CALL     CreateCompatibleDC\r
        PUSH     EAX                    // [EBP-40] = MemDC\r
\r
        PUSH     dword ptr [EBP-36] //MemBmp\r
        PUSH     EAX\r
        CALL     SelectObject\r
        PUSH     EAX                    // [EBP-44] = Save4Mem\r
\r
        PUSH     SRCCOPY\r
        MOV      EAX, [EBP-20] //MaskDC\r
        CALL     @@stretch1\r
\r
        PUSH     SRCERASE\r
        MOV      EAX, [EBP-28] //DCfrom\r
        CALL     @@stretch1\r
\r
        PUSH     0\r
        PUSH     dword ptr [EBP-4] //DC\r
        CALL     SetTextColor\r
        PUSH     EAX                    // [EBP-48] = crText\r
\r
        PUSH     $FFFFFF\r
        PUSH     dword ptr [EBP-4] //DC\r
        CALL     Windows.SetBkColor\r
        PUSH     EAX                    // [EBP-52] = crBack\r
\r
        PUSH     SRCAND\r
        MOV      EAX, [EBP-20] //MaskDC\r
        CALL     @@stretch2\r
\r
        PUSH     SRCINVERT\r
        MOV      EAX, [EBP-40] //MemDC\r
        CALL     @@stretch2\r
\r
        PUSH     dword ptr [EBP-4] //DC\r
        CALL     Windows.SetBkColor\r
\r
        PUSH     dword ptr [EBP-4] //DC\r
        CALL     SetTextColor\r
\r
        MOV      ESI, offset[FinishDC]\r
        CALL     ESI\r
        CALL     DeleteObject   // DeleteObject( MemBmp )\r
\r
        CALL     ESI\r
\r
        CALL     ESI\r
@@to_exit:\r
        STC\r
        JC       @@exit\r
\r
@@stretch1:\r
        POP      ESI\r
        PUSH     [EBX].fHeight\r
        PUSH     [EBX].fWidth\r
        XOR      EDX, EDX\r
        PUSH     EDX\r
        PUSH     EDX\r
        PUSH     EAX\r
        PUSH     [EBX].fHeight\r
        PUSH     [EBX].fWidth\r
        PUSH     EDX\r
        PUSH     EDX\r
        PUSH     dword ptr [EBP-40] //MemDC\r
        JMP      @@stretch3\r
\r
@@stretch2:\r
        POP      ESI\r
        PUSH     [EBX].fHeight\r
        PUSH     [EBX].fWidth\r
        PUSH     0\r
        PUSH     0\r
        PUSH     EAX\r
        MOV      EAX, [EBP-8] //Rect\r
        MOV      EDX, [EAX].TRect.Bottom\r
        MOV      ECX, [EAX].TRect.Top\r
        SUB      EDX, ECX\r
        PUSH     EDX\r
        MOV      EDX, [EAX].TRect.Right\r
        MOV      EAX, [EAX].TRect.Left\r
        SUB      EDX, EAX\r
        PUSH     EDX\r
        PUSH     ECX\r
        PUSH     EAX\r
        PUSH     dword ptr [EBP-4] //DC\r
@@stretch3:\r
        CALL     StretchBlt\r
        JMP      ESI\r
\r
@@exit:\r
        POP      ESI\r
        POP      EBX\r
        MOV      ESP, EBP\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.StretchDrawMasked(DC: HDC; const Rect: TRect; Mask: HBitmap);\r
var\r
  DCfrom, MemDC, MaskDC: HDC;\r
  MemBmp: HBITMAP;\r
  Save4From, Save4Mem, Save4Mask: THandle;\r
  crText, crBack: TColorRef;\r
  //SavePal: HPALETTE;\r
begin\r
  if GetHandle = 0 then Exit;\r
  fDetachCanvas( @Self );\r
    //SavePal := 0;\r
\r
  DCfrom := CreateCompatibleDC( 0 );\r
  Save4From := SelectObject( DCfrom, fHandle );\r
  ASSERT( Save4From <> 0, 'Can not select source bitmap to DC' );\r
  MaskDC := CreateCompatibleDC( 0 );\r
  Save4Mask := SelectObject( MaskDC, Mask );\r
  ASSERT( Save4Mask <> 0, 'Can not select mask bitmap to DC' );\r
  MemDC := CreateCompatibleDC( 0 );\r
    //try\r
      MemBmp := CreateCompatibleBitmap( DCfrom, fWidth, fHeight );\r
      Save4Mem := SelectObject( MemDC, MemBmp );\r
      ASSERT( Save4Mem <> 0, 'Can not select memory bitmap to DC' );\r
      //SavePal := SelectPalette(DCfrom, SystemPalette16, False);\r
      //SelectPalette(DCfrom, SavePal, False);\r
      //if SavePal <> 0 then\r
      //  SavePal := SelectPalette(MemDC, SavePal, True)\r
      //else\r
      //  SavePal := SelectPalette(MemDC, SystemPalette16, True);\r
      //RealizePalette(MemDC);\r
\r
      StretchBlt( MemDC, 0, 0, fWidth, fHeight, MaskDC, 0, 0, fWidth, fHeight, SrcCopy);\r
      StretchBlt( MemDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, fWidth, fHeight, SrcErase);\r
      crText := SetTextColor(DC, $0);\r
      crBack := Windows.SetBkColor(DC, $FFFFFF);\r
      StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,\r
                  MaskDC, 0, 0, fWidth, fHeight, SrcAnd);\r
      StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,\r
                  MemDC, 0, 0, fWidth, fHeight, SrcInvert);\r
      Windows.SetBkColor( DC, crBack);\r
      SetTextColor( DC, crText);\r
\r
      if Save4Mem <> 0 then\r
         SelectObject( MemDC, Save4Mem );\r
      DeleteObject(MemBmp);\r
    //finally\r
      //if SavePal <> 0 then SelectPalette(MemDC, SavePal, False);\r
      DeleteDC(MemDC);\r
      SelectObject( DCfrom, Save4From );\r
      DeleteDC( DCfrom );\r
      SelectObject( MaskDC, Save4Mask );\r
      DeleteDC( MaskDC );\r
    //end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure ApplyBitmapBkColor2Canvas]\r
procedure ApplyBitmapBkColor2Canvas( Sender: PBitmap );\r
begin\r
  if Sender.fCanvas = nil then Exit;\r
  Sender.fCanvas.Brush.Color := Sender.BkColor;\r
end;\r
\r
//[PROCEDURE DetachBitmapFromCanvas]\r
{$IFDEF ASM_VERSION}\r
procedure DetachBitmapFromCanvas( Sender: PBitmap );\r
asm\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EAX].TBitmap.fCanvasAttached\r
        JECXZ    @@exit\r
        PUSH     ECX\r
        MOV      EAX, [EAX].TBitmap.fCanvas\r
        PUSH     [EAX].TCanvas.fHandle\r
        CALL     SelectObject\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure DetachBitmapFromCanvas( Sender: PBitmap );\r
begin\r
  if Sender.fCanvasAttached = 0 then Exit;\r
  SelectObject( Sender.fCanvas.fHandle, Sender.fCanvasAttached );\r
  Sender.fCanvasAttached := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END DetachBitmapFromCanvas]\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.GetCanvas]\r
function TBitmap.GetCanvas: PCanvas;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CALL     GetEmpty\r
        JZ       @@exit\r
        MOV      EAX, EBX\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        MOV      ECX, [EBX].fCanvas\r
        INC      ECX\r
        LOOP     @@ret_Canvas\r
\r
        MOV      [EBX].fApplyBkColor2Canvas, offset[ApplyBitmapBkColor2Canvas]\r
        PUSH     0\r
        CALL     CreateCompatibleDC\r
        CALL     NewCanvas\r
        MOV      [EBX].fCanvas, EAX\r
        MOV      [EAX].TCanvas.fOnChange.TMethod.Code, offset[CanvasChanged]\r
        MOV      [EAX].TCanvas.fOnChange.TMethod.Data, EBX\r
        CALL     TCanvas.GetBrush\r
        XOR      EDX, EDX\r
        MOV      ECX, [EBX].fBkColor\r
        CALL     TGraphicTool.SetInt\r
        \r
@@ret_Canvas:\r
        MOV      EAX, [EBX].fCanvas\r
        MOV      ECX, [EAX].TCanvas.fHandle\r
        INC      ECX\r
        LOOP     @@attach_Canvas\r
        PUSH     EAX\r
        MOV      [EBX].fCanvasAttached, ECX\r
        PUSH     ECX\r
        CALL     CreateCompatibleDC\r
        XCHG     EDX, EAX\r
        POP      EAX\r
        CALL     TCanvas.SetHandle\r
\r
@@attach_Canvas:\r
        MOV      ECX, [EBX].fCanvasAttached\r
        INC      ECX\r
        LOOP     @@2\r
        PUSH     [EBX].fHandle\r
        MOV      EAX, [EBX].fCanvas\r
        CALL     TCanvas.GetHandle\r
        PUSH     EAX\r
        CALL     SelectObject\r
        MOV      [EBX].fCanvasAttached, EAX\r
\r
@@2:    MOV      [EBX].fDetachCanvas, offset[DetachBitmapFromCanvas]\r
        MOV      EAX, [EBX].fCanvas\r
@@exit: POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.GetCanvas: PCanvas;\r
var DC: HDC;\r
begin\r
  Result := nil;\r
  if Empty then Exit;\r
  if GetHandle = 0 then Exit;\r
  if fCanvas = nil then\r
  begin\r
    fApplyBkColor2Canvas := ApplyBitmapBkColor2Canvas;\r
    DC := CreateCompatibleDC( 0 );\r
    fCanvas := NewCanvas( DC );\r
    fCanvas.fIsPaintDC := FALSE;\r
    fCanvas.OnChange := CanvasChanged;\r
    fCanvas.Brush.Color := fBkColor;\r
  end;\r
  Result := fCanvas;\r
\r
  if fCanvas.fHandle = 0 then\r
  begin\r
    DC := CreateCompatibleDC( 0 );\r
    fCanvas.Handle := DC;\r
    fCanvasAttached := 0;\r
  end;\r
\r
  if fCanvasAttached = 0 then\r
  begin\r
    fCanvasAttached := SelectObject( fCanvas.Handle, fHandle );\r
    ASSERT( fCanvasAttached <> 0, 'Can not select bitmap to DC of Canvas' );\r
  end;\r
  fDetachCanvas := DetachBitmapFromCanvas;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.GetEmpty]\r
function TBitmap.GetEmpty: Boolean;\r
asm\r
        PUSH     ECX\r
        MOV      ECX, [EAX].fWidth\r
        JECXZ    @@1\r
        MOV      ECX, [EAX].fHeight\r
@@1:    TEST     ECX, ECX\r
        POP      ECX\r
        SETZ     AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.GetEmpty: Boolean;\r
begin\r
  Result := (fWidth = 0) or (fHeight = 0);\r
  ASSERT( (fWidth >= 0) and (fHeight >= 0), 'Bitmap dimensions can be negative' );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TBitmap.GetHandle]\r
function TBitmap.GetHandle: HBitmap;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CALL     GetEmpty\r
        JZ       @@exit\r
        MOV      ECX, [EBX].fHandle\r
        INC      ECX\r
        LOOP     @@exit\r
\r
        MOV      ECX, [EBX].fDIBBits\r
        JECXZ    @@exit\r
\r
        PUSH     ECX\r
        PUSH     0\r
        CALL     GetDC\r
        PUSH     EAX\r
        PUSH     0\r
        PUSH     0\r
        LEA      EDX, [EBX].fDIBBits\r
        PUSH     EDX\r
        PUSH     DIB_RGB_COLORS\r
        PUSH     [EBX].fDIBHeader\r
        PUSH     EAX\r
        CALL     CreateDIBSection\r
        MOV      [EBX].fHandle, EAX\r
        PUSH     0\r
        CALL     ReleaseDC\r
        POP      EAX\r
        PUSH     EAX\r
        MOV      EDX, [EBX].fDIBBits\r
        MOV      ECX, [EBX].fDIBSize\r
        CALL     System.Move\r
        POP      EAX\r
        CMP      [EBX].fDIBAutoFree, 0\r
        JNZ      @@freed\r
        CALL     System.@FreeMem\r
@@freed:MOV      [EBX].fDIBAutoFree, 1\r
        XOR      EAX, EAX\r
        MOV      [EBX].fGetDIBPixels, EAX\r
        MOV      [EBX].fSetDIBPixels, EAX\r
\r
@@exit: MOV      EAX, [EBX].fHandle\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.GetHandle: HBitmap;\r
var OldBits: Pointer;\r
    DC0: HDC;\r
    {$IFDEF DEBUG}\r
    B: tagBitmap;\r
    {$ENDIF}\r
begin\r
  Result := 0;\r
  if Empty then Exit;\r
  if fHandle = 0 then\r
  begin\r
    if fDIBBits <> nil then\r
    begin\r
      OldBits := fDIBBits;\r
      DC0 := GetDC( 0 );\r
\r
      fDIBBits := nil;\r
      //fDIBHeader.bmiHeader.biCompression := 0;\r
      fHandle := CreateDIBSection( DC0, fDIBHeader^, DIB_RGB_COLORS,\r
                    fDIBBits, 0, 0 );\r
      {$IFDEF DEBUG}\r
      if fHandle = 0 then\r
        ShowMessage( 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +\r
        ', ' + SysErrorMessage( GetLastError ) );\r
      GetObject( fHandle, Sizeof( B ), @ B );\r
      {$ELSE}\r
      ASSERT( fHandle <> 0, 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +\r
      ', ' + SysErrorMessage( GetLastError ) );\r
      {$ENDIF}\r
      ReleaseDC( 0, DC0 );\r
      if fHandle <> 0 then\r
      begin\r
        Move( OldBits^, fDIBBits^, fDIBSize );\r
        if not fDIBAutoFree then\r
          FreeMem( OldBits );\r
        fDIBAutoFree := TRUE;\r
\r
        fGetDIBPixels := nil;\r
        fSetDIBPixels := nil;\r
      end\r
        else\r
        fDIBBits := OldBits;\r
    end;\r
  end;\r
  Result := fHandle;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TBitmap.GetHandleAllocated]\r
function TBitmap.GetHandleAllocated: Boolean;\r
begin\r
  Result := fHandle <> 0;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.LoadFromFile]\r
procedure TBitmap.LoadFromFile(const Filename: String);\r
asm\r
        PUSH     EAX\r
        XCHG     EAX, EDX\r
        CALL     NewReadFileStream\r
        XCHG     EDX, EAX\r
        POP      EAX\r
        PUSH     EDX\r
        CALL     LoadFromStream\r
        POP      EAX\r
        CALL     TObj.Free\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.LoadFromFile(const Filename: String);\r
var Strm: PStream;\r
begin\r
  Strm := NewReadFileStream( Filename );\r
  LoadFromStream( Strm );\r
  Strm.Free;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TBitmap.LoadFromResourceID]\r
procedure TBitmap.LoadFromResourceID(Inst: DWORD; ResID: Integer);\r
begin\r
  LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ) );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.LoadFromResourceName]\r
procedure TBitmap.LoadFromResourceName(Inst: DWORD; ResName: PChar);\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        PUSHAD\r
        CALL     Clear\r
        POPAD\r
        XOR      EAX, EAX\r
        PUSH     ECX\r
        MOVZX    ECX, [EBX].fHandleType\r
        INC      ECX\r
        LOOP     @@1\r
        MOV      AH, LR_CREATEDIBSECTION shr 8 // = $2000\r
@@1:    MOV      AL, LR_DEFAULTSIZE // = $40\r
        POP      ECX\r
        PUSH     EAX\r
        PUSH     0\r
        PUSH     0\r
        PUSH     IMAGE_BITMAP\r
        PUSH     ECX\r
        PUSH     EDX\r
        CALL     LoadImage\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        XCHG     EDX, EAX\r
        XCHG     EAX, EBX\r
        CALL     SetHandle\r
@@exit: POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.LoadFromResourceName(Inst: DWORD; ResName: PChar);\r
var ResHandle: HBitmap;\r
    Flg: DWORD;\r
begin\r
  Clear;\r
  //ResHandle := LoadBitmap( Inst, ResName );\r
  Flg := 0;\r
  if fHandleType = bmDIB then\r
    Flg := LR_CREATEDIBSECTION;\r
  ResHandle := LoadImage( Inst, ResName, IMAGE_BITMAP, 0, 0,\r
             LR_DEFAULTSIZE or Flg );\r
  if ResHandle = 0 then Exit;\r
  //Handle := CopyImage( ResHandle, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG );\r
  Handle := ResHandle;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF F_P}\r
type\r
  TBITMAPFILEHEADER = packed record\r
    bfType: Word;\r
    bfSize: DWORD;\r
    bfReserved1: Word;\r
    bfReserved2: Word;\r
    bfOffBits: DWORD;\r
  end;\r
{$ENDIF}\r
\r
{$IFDEF ASM_noVERSION} // error + 16Colors->swap(Gray,Silver) + Core\r
//[procedure TBitmap.LoadFromStream]\r
procedure TBitmap.LoadFromStream(Strm: PStream);\r
type  tBFH = TBitmapFileHeader;\r
      tBIH = TBitmapInfoHeader;\r
const szBIH = Sizeof( tBIH );\r
      szBFH = Sizeof( tBFH );\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, EAX\r
        PUSH     EDX\r
        CALL     Clear\r
        POP      ESI\r
        MOV      EAX, ESI\r
        CALL     TStream.GetPosition\r
        PUSH     EAX     // [EBP+4] = Strm.Pos (starting pos)\r
        PUSH     EBP\r
        MOV      EBP, ESP\r
        ADD      ESP, -(szBIH + szBFH)\r
\r
        // reading bitmap\r
        XOR      ECX, ECX\r
        MOV      [EBX].fHandleType, CL\r
        MOV      CL, szBFH\r
        MOV      EDX, ESP\r
        PUSH     ECX\r
        MOV      EAX, ESI\r
        CALL     TStream.Read\r
        POP      ECX\r
        SUB      ECX, EAX\r
        JNZ      @@eread1\r
\r
        CMP      [ESP].tBFH.bfType, $4D42\r
        JE       @@1\r
        MOV      EDX, [EBP+4]\r
        MOV      EAX, ESI\r
        CALL     TStream.Seek\r
        XOR      EAX, EAX\r
        XOR      EDX, EDX\r
        JMP      @@2\r
\r
@@1:\r
        MOV      EDX, [ESP].tBFH.bfSize\r
        MOV      EAX, [ESP].tBFH.bfOffBits\r
@@2:\r
        PUSH     EDX        // Push Size\r
        PUSH     EAX        // Push Off\r
        XOR      ECX, ECX\r
        MOV      CL, szBIH\r
        LEA      EDX, [EBP-szBIH]\r
        MOV      EAX, ESI\r
        PUSH     ECX\r
        CALL     TStream.Read   // read BIH\r
        POP      ECX\r
@@eread1:\r
        XOR      ECX, EAX\r
        JNZ      @@eread\r
\r
        MOVZX    EAX, [EBP-szBIH].tBIH.biBitCount\r
        MOVZX    EDX, [EBP-szBIH].tBIH.biPlanes\r
        MUL      EDX\r
        CALL     Bits2PixelFormat\r
        {$IFDEF PARANOIA}\r
        DB $3C, pf15bit\r
        {$ELSE}\r
        CMP      AL, pf15bit\r
        {$ENDIF}\r
        JNZ      @@no15bit\r
        CMP      [EBP-szBIH].tBIH.biCompression, 0\r
        JZ       @@no15bit\r
        INC      AL // AL = pf16bit\r
@@no15bit:\r
        MOV      [EBX].fNewPixelFormat, AL\r
\r
        MOV      EAX, szBIH + 1024\r
        CALL     System.@GetMem\r
        MOV      [EBX].fDIBHeader, EAX\r
        XCHG     EDX, EAX\r
        LEA      EAX, [EBP-szBIH]\r
        XOR      ECX, ECX\r
        MOV      CL, szBIH\r
        CALL     System.Move\r
\r
        MOV      EAX, [EBP-szBIH].tBIH.biWidth\r
        MOV      [EBX].fWidth, EAX\r
        MOV      EAX, [EBP-szBIH].tBIH.biHeight\r
        TEST     EAX, EAX\r
        JGE      @@20\r
        NEG      EAX\r
@@20:   MOV      [EBX].fHeight, EAX\r
\r
        MOV      EAX, EBX\r
        CALL     GetScanLineSize\r
        MOV      EDX, [EBX].fHeight\r
        MUL      EDX\r
        MOV      [EBX].fDIBSize, EAX\r
        CALL     AllocMem\r
        MOV      [EBX].fDIBBits, EAX\r
\r
        MOVZX    EAX, [EBP-szBIH].tBIH.biBitCount\r
        {$IFDEF PARANOIA}\r
        DB $3C, 8\r
        {$ELSE}\r
        CMP      AL, 8\r
        {$ENDIF}\r
        JA       @@3\r
        MOV      AL, 4\r
        MOVZX    ECX, [EBP-szBIH].tBIH.biBitCount\r
        SAL      EAX, CL\r
        XCHG     ECX, EAX\r
@@3:\r
        CMP      [EBX].TBitmap.fNewPixelFormat, pf16bit\r
        JNE      @@30\r
        XOR      ECX, ECX\r
        MOV      CL, 12 // ColorCount = 12\r
@@30:\r
        POP      EAX  // EAX = off\r
        TEST     EAX, EAX\r
        JLE      @@4\r
        SUB      EAX, szBFH + szBIH\r
        CMP      EAX, ECX\r
        JZ       @@4\r
        XCHG     ECX, EAX\r
@@4:\r
        JECXZ    @@5\r
        PUSH     ECX\r
        MOV      EDX, [EBX].fDIBHeader\r
        ADD      EDX, szBIH\r
        MOV      EAX, ESI\r
        CALL     TStream.Read\r
        POP      ECX\r
        XOR      EAX, ECX\r
        JNZ      @@eread\r
@@5:\r
        MOV      ECX, [EBX].fDIBSize\r
@@7:\r
        PUSH     ECX\r
        MOV      EAX, ESI\r
        CALL     TStream.GetPosition\r
        PUSH     EAX\r
        MOV      EAX, ESI\r
        CALL     TStream.GetSize\r
        POP      EDX\r
        SUB      EAX, EDX\r
        POP      ECX      // Size = fDIBSize\r
        CMP      EAX, ECX // Strm.Size - Strm.Position > Size ?\r
        JL       @@8\r
        XCHG     ECX, EAX\r
@@8:\r
        // ++++++++++++++ 26-Oct-2003 VK see comment in Pascal\r
        MOV      EAX, [EBX].fDIBSize\r
        CMP      ECX, EAX\r
        JGE      @@9\r
        SUB      EAX, ECX\r
        PUSH     EAX\r
        MOV      EAX, ESI\r
        PUSH     ECX\r
        CALL     TStream.GetPosition\r
        POP      ECX\r
        POP      EDX\r
        CMP      EDX, EAX\r
        JG       @@9\r
\r
        MOV      EAX, ESI\r
        NEG      EDX\r
        XOR      ECX, ECX\r
        INC      ECX\r
        CALL     TStream.Seek\r
\r
        MOV      ECX, [EBX].fDIBSize\r
@@9:\r
        // ++++++++++++++\r
\r
        PUSH     ECX\r
        MOV      EDX, [EBX].fDIBBits\r
        MOV      EAX, ESI\r
        CALL     TStream.Read\r
        POP      ECX\r
        XOR      EAX, ECX\r
        POP      EAX // Strm.Size - Position\r
        POP      ECX // fDIBSize\r
        //JNZ      @@eread\r
\r
        // end of reading bitmap\r
@@eread:\r
        MOV      ESP, EBP\r
        POP      EBP\r
        POP      EDX\r
        JZ       @@exit\r
        // not success:\r
        XCHG     EAX, ESI\r
        XOR      ECX, ECX // ECX = spBegin\r
        CALL     TStream.Seek\r
        XCHG     EAX, EBX\r
        CALL     Clear\r
@@exit: POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.LoadFromStream(Strm: PStream);\r
type\r
  TColorsArray = array[ 0..15 ] of TColor;\r
  PColorsArray = ^TColorsArray;\r
  PColor = ^TColor;\r
var Pos : Integer;\r
    BFH : TBitmapFileHeader;\r
\r
    function ReadBitmap : Boolean;\r
    var Size, Size1: Integer;\r
        BCH: TBitmapCoreHeader;\r
        RGBSize: DWORD;\r
        C: PColor;\r
        Off, HdSz, ColorCount: DWORD;\r
    begin\r
      fHandleType := bmDIB;\r
      Result := False;\r
      if Strm.Read( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit;\r
      Off := 0; Size := 0;\r
      if BFH.bfType <> $4D42 then\r
         Strm.Seek( Pos, spBegin )\r
      else\r
      begin\r
         Off := BFH.bfOffBits - Sizeof( BFH );\r
         Size := BFH.bfSize; // don't matter, just <> 0 is good\r
         //Size := Min( BFH.bfSize, Strm.Size - Strm.Position );\r
      end;\r
      RGBSize := 4;\r
      HdSz := Sizeof( TBitmapInfoHeader );\r
      fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + HdSz );\r
      if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( DWORD ) ) <> Sizeof( DWORD ) then\r
         Exit;\r
      if fDIBHeader.bmiHeader.biSize = HdSz then\r
      begin\r
        if Strm.Read( fDIBHeader.bmiHeader.biWidth, HdSz - Sizeof( DWORD ) ) <>\r
           HdSz - Sizeof( DWORD ) then\r
           Exit;\r
      end\r
        else\r
      if fDIBHeader.bmiHeader.biSize = Sizeof( TBitmapCoreHeader ) then\r
      begin\r
        RGBSize := 3;\r
        HdSz := Sizeof( TBitmapCoreHeader );\r
        if Strm.Read( BCH.bcWidth, HdSz - Sizeof( DWORD ) ) <>\r
           HdSz - Sizeof( DWORD ) then\r
           Exit;\r
        fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );\r
        fDIBHeader.bmiHeader.biWidth := BCH.bcWidth;\r
        fDIBHeader.bmiHeader.biHeight := BCH.bcHeight;\r
        fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes;\r
        fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount;\r
      end\r
        else Exit;\r
      fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount\r
                         * fDIBHeader.bmiHeader.biPlanes );\r
      if (fNewPixelFormat = pf15bit) and (fDIBHeader.bmiHeader.biCompression <> BI_RGB) then\r
      begin\r
        ASSERT( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );\r
        //fNewPixelFormat := pf16bit;\r
      end;\r
      fWidth := fDIBHeader.bmiHeader.biWidth;\r
      ASSERT( fWidth > 0, 'Bitmap width must be > 0' );\r
      fHeight := Abs(fDIBHeader.bmiHeader.biHeight);\r
      ASSERT( fHeight > 0, 'Bitmap height must be > 0' );\r
\r
      fDIBSize := ScanLineSize * fHeight;\r
      fDIBBits := AllocMem( fDIBSize );\r
      ASSERT( fDIBBits <> nil, 'No memory' );\r
\r
      ColorCount := 0;\r
      if fDIBHeader.bmiHeader.biBitCount <= 8 then\r
        ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * RGBSize\r
      else if fNewPixelFormat in [pf15bit,pf16bit] then\r
        ColorCount := 12;\r
\r
      if Off > 0 then\r
      begin\r
         Off := Off - HdSz;\r
         if (Off <> ColorCount) then\r
         if not(fNewPixelFormat in [pf15bit,pf16bit])\r
         or (Off = 0) //+++ to fix loading 15- and 16-bit bmps with mask omitted\r
         then\r
            ColorCount := Off;\r
      end;\r
      if ColorCount <> 0 then\r
      begin\r
         if Off >= ColorCount then\r
           Off := Off - ColorCount;\r
         if RGBSize = 4 then\r
         begin\r
           if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )\r
              <> DWORD( ColorCount ) then Exit;\r
         end\r
           else\r
         begin\r
           C := @ fDIBHeader.bmiColors[ 0 ];\r
           while ColorCount > 0 do\r
           begin\r
             if Strm.Read( C^, RGBSize ) <> RGBSize then Exit;\r
             Dec( ColorCount, RGBSize );\r
             Inc( C );\r
           end;\r
         end;\r
      end;\r
      if Off > 0 then\r
        Strm.Seek( Off, spCurrent );\r
\r
      if Size = 0 then\r
         Size := fDIBSize //ScanLineSize * fHeight\r
      else\r
         Size := Min( {Size - Sizeof( TBitmapFileHeader ) - Sizeof( TBitmapInfoHeader )\r
              - ColorCount} fDIBSize, Strm.Size - Strm.Position );\r
\r
      Size1 := Min( Size, fDIBSize );\r
\r
      // +++++++++++++++++++ 26-Oct-2003 by VK\r
      if (Size1 < fDIBSize)\r
         and (DWORD( fDIBSize - Size1 ) <= Strm.Position) then\r
      begin\r
        Strm.Seek( Size1 - fDIBSize, spCurrent );\r
        Size1 := fDIBSize;\r
      end;\r
      // +++++++++++++++++++ to fix some "incorrect" bitmaps while loading\r
\r
      if Strm.Read( fDIBBits^, Size1 ) <> DWORD( Size1 ) then Exit;\r
      if Size > Size1 then\r
        Strm.Seek( Size - Size1, spCurrent );\r
\r
      Result := True;\r
    end;\r
{var ColorsArray: PColorsArray;\r
    DC: HDC;\r
    Old: HBitmap;}\r
begin\r
  Clear;\r
  Pos := Strm.Position;\r
  if not ReadBitmap then\r
  begin\r
     Strm.Seek( Pos, spBegin );\r
     Clear;\r
  end;\r
    {else\r
  begin\r
    if (fDIBBits <> nil) and (fDIBHeader.bmiHeader.biBitCount >= 4) then\r
    begin\r
        ColorsArray := @ fDIBHeader.bmiColors[ 0 ];\r
        if ColorsArray[ 7 ] = $C0C0C0 then\r
        if ColorsArray[ 8 ] = $808080 then\r
        if GetHandle <> 0 then\r
        begin\r
          DC := CreateCompatibleDC( 0 );\r
          Old := SelectObject( DC, fHandle );\r
          SetDIBColorTable( DC, 0, 16, fDIBHeader.bmiColors[ 0 ] );\r
          SelectObject( DC, Old );\r
          DeleteDC( DC );\r
        end;\r
    end;\r
  end;}\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
////////////////// bitmap RLE-decoding and loading - by Vyacheslav A. Gavrik\r
\r
//[procedure DecodeRLE4]\r
procedure DecodeRLE4(Bmp:PBitmap;Data:Pointer); // by Vyacheslav A. Gavrik\r
  procedure OddMove(Src,Dst:PByte;Size:Integer);\r
  begin\r
    if Size=0 then Exit;\r
    repeat\r
      Dst^:=(Dst^ and $F0)or(Src^ shr 4);\r
      Inc(Dst);\r
      Dst^:=(Dst^ and $0F)or(Src^ shl 4);\r
      Inc(Src);\r
      Dec(Size);\r
    until Size=0;\r
  end;\r
  procedure OddFill(Mem:PByte;Size,Value:Integer);\r
  begin\r
    Value:=(Value shr 4)or(Value shl 4);\r
    Mem^:=(Mem^ and $F0)or(Value and $0F);\r
    Inc(Mem);\r
    if Size>1 then FillChar(Mem^,Size,Value);\r
    Mem^:=(Mem^ and $0F)or(Value and $F0);\r
  end;\r
var\r
  pb: PByte;\r
  x,y,z,i: Integer;\r
begin\r
  pb:=Data; x:=0; y:=0;\r
  if Bmp.fScanLineSize = 0 then\r
     Bmp.ScanLineSize;\r
  while y<Bmp.Height do\r
  begin\r
    if pb^=0 then\r
    begin\r
      Inc(pb);\r
      z:=pb^;\r
      case pb^ of\r
        0: begin\r
             Inc(y);\r
             x:=0;\r
           end;\r
        1: Break;\r
        2: begin\r
             Inc(pb); Inc(x,pb^);\r
             Inc(pb); Inc(y,pb^);\r
           end;\r
        else\r
        begin\r
          Inc(pb);\r
          i:=(z+1)shr 1;\r
          if(z and 2)=2 then Inc(i);\r
          if((x and 1)=1)and(x+i<Bmp.Width)then\r
            OddMove(pb,@PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],i)\r
          else\r
            Move(pb^,PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],i);\r
          Inc(pb,i-1);\r
          Inc(x,z);\r
        end;\r
      end;\r
    end else\r
    begin\r
      z:=pb^;\r
      Inc(pb);\r
      if((x and 1)=1)and(x+z<Bmp.Width)then\r
        OddFill(@PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],z shr 1,pb^)\r
      else\r
        FillChar(PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],z shr 1,pb^);\r
      Inc(x,z);\r
    end;\r
    Inc(pb);\r
  end;\r
end;\r
\r
//[procedure DecodeRLE8]\r
procedure DecodeRLE8(Bmp:PBitmap;Data:Pointer); // by Vyacheslav A. Gavrik\r
var\r
  pb: PByte;\r
  x,y,z,i: Integer;\r
begin\r
  pb:=Data; y:=0; x:=0;\r
  if Bmp.fScanLineSize = 0 then\r
     Bmp.ScanLineSize;\r
\r
  while y<Bmp.Height do\r
  begin\r
    if pb^=0 then\r
    begin\r
      Inc(pb);\r
      case pb^ of\r
        0: begin\r
             Inc(y);\r
             x:=0;\r
           end;\r
        1: Break;\r
        2: begin\r
             Inc(pb); Inc(x,pb^);\r
             Inc(pb); Inc(y,pb^);\r
           end;\r
        else\r
        begin\r
          i:=pb^;\r
          z:=(i+1)and(not 1);\r
          Inc(pb);\r
          Move(pb^,PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x],z);\r
          Inc(pb,z-1);\r
          Inc(x,i);\r
        end;\r
      end;\r
    end else\r
    begin\r
      i:=pb^; Inc(pb);\r
      FillChar(PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x],i,pb^);\r
      Inc(x,i);\r
    end;\r
    Inc(pb);\r
  end;\r
end;\r
\r
//[function TBitmap.LoadFromFileEx]\r
function TBitmap.LoadFromFileEx(const Filename: String): Boolean; // by Vyacheslav A. Gavrik\r
var Strm: PStream;\r
begin\r
  Strm := NewReadFileStream( Filename );\r
  Result := LoadFromStreamEx(Strm);\r
  Strm.Free;\r
end;\r
\r
//[function TBitmap.LoadFromStreamEx]\r
function TBitmap.LoadFromStreamEx(Strm: PStream): Boolean; // by Vyacheslav A. Gavrik\r
var Pos : Integer;\r
\r
    function ReadBitmap : Boolean;\r
    var Off, Size, ColorCount: Integer;\r
        BFH : TBitmapFileHeader;\r
        BFHValid: Boolean;\r
        Buffer: Pointer;\r
    begin\r
      fHandleType := bmDIB;\r
      Result := False;\r
      BFHValid := FALSE;\r
      if Strm.Read( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit;\r
      Off := 0; Size := 0;\r
      if BFH.bfType <> $4D42 then\r
         Strm.Seek( Pos, spBegin )\r
      else\r
      begin\r
         BFHValid := TRUE;\r
         Off := BFH.bfOffBits;\r
         Size := Strm.GetSize;\r
      end;\r
      GetMem( fDIBHeader, 256*sizeof(TRGBQuad) + sizeof(TBitmapInfoHeader) );\r
      if Strm.Read( fDIBHeader^, Sizeof(TBitmapInfoHeader) ) <> Sizeof(TBitmapInfoHeader) then\r
         Exit;\r
      //if fDIBHeader.bmiHeader.biCompression = BI_RGB then\r
      {if fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS then\r
                                            //BI_RGB here????\r
        Strm.Read( fDIBHeader.bmiColors[ 0 ], 3 * Sizeof( DWORD ) );}\r
\r
      fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount\r
                         * fDIBHeader.bmiHeader.biPlanes );\r
\r
      fWidth := fDIBHeader.bmiHeader.biWidth;\r
      ASSERT( fWidth > 0, 'Bitmap width must be > 0' );\r
      fHeight := Abs(fDIBHeader.bmiHeader.biHeight);\r
      ASSERT( fHeight > 0, 'Bitmap height must be > 0' );\r
\r
      fDIBSize := ScanLineSize * fHeight;\r
      GetMem( fDIBBits, fDIBSize );\r
      ASSERT( fDIBBits <> nil, 'No memory' );\r
      ASSERT( (fDIBHeader.bmiHeader.biCompression and\r
              (BI_RLE8 or BI_RLE4 or BI_RLE8 or BI_BITFIELDS) <> 0) or\r
              (fDIBHeader.bmiHeader.biCompression = BI_RGB),\r
              'Unknown compression algorithm');\r
\r
      ColorCount := 0;\r
      if fDIBHeader.bmiHeader.biBitCount <= 8 then\r
        ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad )\r
      else if fNewPixelFormat in [ pf16bit ] then\r
        ColorCount := 12;\r
\r
      if Off > 0 then\r
      begin\r
         Off := Off - SizeOf( TBitmapFileHeader ) - Sizeof( TBitmapInfoHeader );\r
         if Off <> ColorCount then\r
            ColorCount := Off;\r
      end;\r
      if fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS then\r
      begin\r
        PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := ( $00001F );\r
        PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := ( $0007E0 );\r
        TColor( fDIBHeader.bmiColors[ 0 ] ) := ( $00F800 );\r
      end;\r
\r
      if ColorCount <> 0 then\r
         if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )\r
            <> DWORD( ColorCount ) then Exit;\r
\r
      if not BFHValid then\r
        Size := fDIBSize\r
      else\r
      if(fDIBHeader.bmiHeader.biCompression = BI_RLE8)\r
         or (fDIBHeader.bmiHeader.biCompression=BI_RLE4) then\r
            Size := BFH.bfSize - BFH.bfOffBits\r
         else\r
         begin\r
           if Integer( Strm.Size - BFH.bfOffBits) - Pos > Integer(Size) then\r
             Size := fDIBSize\r
           else\r
             Size := Strm.Size - BFH.bfOffBits - DWORD( Pos );\r
         end;\r
\r
      if (fDIBHeader.bmiHeader.biCompression = BI_RGB) or\r
         (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then\r
      begin\r
        if Strm.Read( fDIBBits^, Size ) <> DWORD( Size ) then\r
          //Exit;\r
      end\r
        else\r
      begin\r
        GetMem(Buffer,Size);\r
        if Strm.Read(Buffer^,Size) <> DWORD( Size ) then Exit;\r
\r
        if fDIBHeader.bmiHeader.biCompression=BI_RLE8 then\r
           DecodeRLE8(@Self,Buffer)\r
        else\r
           DecodeRLE4(@Self,Buffer);\r
\r
        fDIBHeader.bmiHeader.biCompression := BI_RGB;\r
        FreeMem(Buffer);\r
      end;\r
\r
      Result := True;\r
    end;\r
begin\r
  Clear;\r
  Pos := Strm.Position;\r
  result := ReadBitmap;\r
  if not result then\r
  begin\r
     Strm.Seek( Pos, spBegin );\r
     Clear;\r
  end;\r
end;\r
\r
///////////////////////////\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.ReleaseHandle]\r
function TBitmap.ReleaseHandle: HBitmap;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        XOR      EDX, EDX\r
        CALL     SetHandleType\r
        MOV      EAX, EBX\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
\r
        CMP      [EBX].fDIBAutoFree, 0\r
        JZ       @@1\r
        MOV      EAX, [EBX].fDIBSize\r
        PUSH     EAX\r
        CALL     System.@GetMem\r
        MOV      EDX, EAX\r
        XCHG     EAX, [EBX].fDIBBits\r
        POP      ECX\r
        CALL     System.Move\r
@@1:\r
        XOR      EAX, EAX\r
        MOV      [EBX].fDIBAutoFree, AL\r
        XCHG     EAX, [EBX].fHandle\r
\r
@@exit: POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.ReleaseHandle: HBitmap;\r
var OldBits: Pointer;\r
begin\r
  HandleType := bmDIB;\r
  Result := GetHandle;\r
  if Result = 0 then Exit; // only when bitmap is empty\r
  if fDIBAutoFree then\r
  begin\r
    OldBits := fDIBBits;\r
    GetMem( fDIBBits, fDIBSize );\r
    Move( OldBits^, fDIBBits^, fDIBSize );\r
    fDIBAutoFree := FALSE;\r
  end;\r
  fHandle := 0;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.SaveToFile]\r
procedure TBitmap.SaveToFile(const Filename: String);\r
asm\r
        PUSH     EAX\r
        PUSH     EDX\r
        CALL     GetEmpty\r
        POP      EAX\r
        JZ       @@exit\r
        CALL     NewWriteFileStream\r
        XCHG     EDX, EAX\r
        POP      EAX\r
        PUSH     EDX\r
        CALL     SaveToStream\r
        POP      EAX\r
        CALL     TObj.Free\r
        PUSH     EAX\r
@@exit: POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.SaveToFile(const Filename: String);\r
var Strm: PStream;\r
begin\r
  if Empty then Exit;\r
  Strm := NewWritefileStream( Filename );\r
  SaveToStream( Strm );\r
  Strm.Free;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.SaveToStream]\r
procedure TBitmap.SaveToStream(Strm: PStream);\r
type  tBFH = TBitmapFileHeader;\r
      tBIH = TBitmapInfoHeader;\r
const szBIH = Sizeof( tBIH );\r
      szBFH = Sizeof( tBFH );\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, EAX\r
        MOV      ESI, EDX\r
        CALL     GetEmpty\r
        JZ       @@exit\r
        MOV      EAX, ESI\r
        CALL     TStream.GetPosition\r
        PUSH     EAX\r
\r
        MOV      EAX, EBX\r
        XOR      EDX, EDX // EDX = bmDIB\r
        CALL     SetHandleType\r
        XOR      EAX, EAX\r
        MOV      EDX, [EBX].fDIBHeader\r
        MOVZX    ECX, [EDX].TBitmapInfoHeader.biBitCount\r
        CMP      CL, 8\r
        JG       @@1\r
        MOV      AL, 4\r
        SHL      EAX, CL\r
@@1:\r
          PUSH     EAX                        // ColorsSize\r
        LEA      ECX, [EAX + szBFH + szBIH]\r
        CMP      [EDX].TBitmapInfoHeader.biCompression, 0\r
        JZ       @@10\r
        ADD      ECX, 74\r
@@10:\r
        PUSH     ECX                        // BFH.bfOffBits\r
        PUSH     0\r
        ADD      ECX, [EBX].fDIBSize\r
        PUSH     ECX\r
        MOV      CX, $4D42\r
        PUSH     CX\r
        XOR      ECX, ECX\r
        MOV      EDX, ESP\r
        MOV      CL, szBFH\r
          PUSH     ECX\r
        MOV      EAX, ESI\r
        CALL     TStream.Write\r
          POP      ECX\r
        ADD      ESP, szBFH\r
        XOR      EAX, ECX\r
          POP      ECX  // ColorsSize\r
        JNZ      @@ewrite\r
\r
        MOV      EDX, [EBX].fDIBHeader\r
        CMP      [EDX].TBitmapInfoHeader.biCompression, 0\r
        JZ       @@11\r
        ADD      ECX, 74\r
@@11:\r
\r
        ADD      ECX, szBIH\r
        PUSH     ECX\r
        MOV      EAX, ESI\r
        CALL     TStream.Write\r
        POP      ECX\r
        XOR      EAX, ECX\r
        JNZ      @@ewrite\r
\r
        MOV      ECX, [EBX].fDIBSize\r
        MOV      EDX, [EBX].fDIBBits\r
        MOV      EAX, ESI\r
        PUSH     ECX\r
        CALL     TStream.Write\r
        POP      ECX\r
        XOR      EAX, ECX\r
\r
@@ewrite:\r
        POP      EDX\r
        JZ       @@exit\r
        XCHG     EAX, ESI\r
        XOR      ECX, ECX\r
        CALL     TStream.Seek\r
@@exit:\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.SaveToStream(Strm: PStream);\r
var BFH : TBitmapFileHeader;\r
    Pos : Integer;\r
   function WriteBitmap : Boolean;\r
   var ColorsSize, BitsSize, Size : Integer;\r
   begin\r
      Result := False;\r
      if Empty then Exit;\r
      HandleType := bmDIB; // convert to DIB if DDB\r
      FillChar( BFH, Sizeof( BFH ), 0 );\r
      ColorsSize := 0;\r
      with fDIBHeader.bmiHeader do\r
           if biBitCount <= 8 then\r
              ColorsSize := (1 shl biBitCount) * Sizeof( TRGBQuad )\r
           {else\r
           if biCompression <> 0 then\r
              ColorsSize := 12};\r
      BFH.bfOffBits := Sizeof( BFH ) + Sizeof( TBitmapInfoHeader ) + ColorsSize;\r
      BitsSize := fDIBSize; //ScanLineSize * fHeight;\r
      BFH.bfSize := BFH.bfOffBits + DWord( BitsSize );\r
      BFH.bfType := $4D42; // 'BM';\r
      if fDIBHeader.bmiHeader.biCompression <> 0 then\r
      begin\r
         ColorsSize := 12 + 16*sizeof(TRGBQuad);\r
         Inc( BFH.bfOffBits, ColorsSize );\r
      end;\r
      if Strm.Write( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit;\r
      Size := Sizeof( TBitmapInfoHeader ) + ColorsSize;\r
      if Strm.Write( fDIBHeader^, Size ) <> DWORD(Size) then Exit;\r
      if Strm.Write( fDIBBits^, BitsSize ) <> DWord( BitsSize ) then Exit;\r
      Result := True;\r
   end;\r
begin\r
  Pos := Strm.Position;\r
  if not WriteBitmap then\r
     Strm.Seek( Pos, spBegin );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.SetHandle]\r
procedure TBitmap.SetHandle(const Value: HBitmap);\r
const szB = sizeof( tagBitmap );\r
asm\r
        PUSH     EAX\r
        PUSH     EDX\r
        CALL     Clear\r
        POP      ECX\r
        JECXZ    @@exit\r
        PUSH     ECX\r
        ADD      ESP, -szB\r
        PUSH     ESP\r
        PUSH     szB\r
        PUSH     ECX\r
        CALL     GetObject\r
        POP      EDX\r
        POP      EDX\r
        POP      ECX\r
        ADD      ESP, 12\r
        TEST     EAX, EAX\r
        POP      EAX\r
        JZ       @@exit\r
        XCHG     EAX, [ESP]\r
        MOV      [EAX].fWidth, EDX\r
        MOV      [EAX].fHeight, ECX\r
        POP      EDX\r
        MOV      [EAX].fHandle, EDX\r
        MOV      [EAX].fHandleType, 1\r
        PUSH     EAX\r
@@exit: POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.SetHandle(const Value: HBitmap);\r
var B: tagBitmap;\r
begin\r
  Clear;\r
  if Value = 0 then Exit;\r
  if GetObject( Value, Sizeof( B ), @B ) = 0 then Exit;\r
  fHandle := Value;\r
  fWidth := B.bmWidth;\r
  fHeight := B.bmHeight;\r
  fHandleType := bmDDB;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TBitmap.SetWidth]\r
procedure TBitmap.SetWidth(const Value: Integer);\r
begin\r
  if fWidth = Value then Exit;\r
  fWidth := Value;\r
  FormatChanged;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.SetHeight]\r
procedure TBitmap.SetHeight(const Value: Integer);\r
asm\r
        CMP      EDX, [EAX].fHeight\r
        JE       @@exit\r
        PUSHAD\r
        XOR      EDX, EDX\r
        INC      EDX\r
        CALL     SetHandleType\r
        POPAD\r
        MOV      [EAX].fHeight, EDX\r
        CALL     FormatChanged\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.SetHeight(const Value: Integer);\r
begin\r
  if fHeight = Value then Exit;\r
\r
    HandleType := bmDDB;\r
    // Not too good, but provides correct changing of height\r
    // preserving previous image\r
\r
  fHeight := Value;\r
  FormatChanged;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.SetPixelFormat]\r
procedure TBitmap.SetPixelFormat(Value: TPixelFormat);\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        //////////////////////\r
        CALL     GetEmpty   //   if Empty then Exit;\r
        JZ       @@exit     //\r
        MOV      EAX, EBX   //\r
        //////////////////////\r
        PUSH     EDX\r
        CALL     GetPixelFormat\r
        POP      EDX\r
        CMP      EAX, EDX\r
        JE       @@exit\r
        TEST     EDX, EDX\r
        MOV      EAX, EBX\r
        JNE      @@2\r
        // Value = pfDevice (=0)\r
        POP      EBX\r
        INC      EDX // EDX = bmDDB\r
        JMP      SetHandleType\r
@@2:\r
        MOV      [EBX].fNewPixelFormat, DL\r
        CMP      DL, pf16bit\r
        JNZ      @@3\r
        DEC      EDX\r
@@3:    PUSH     EDX\r
        XOR      EDX, EDX\r
        CALL     SetHandleType\r
        MOV      EAX, [EBX].fDIBHeader\r
        MOVZX    EAX, [EAX].TBitmapInfoHeader.biBitCount\r
        CALL     Bits2PixelFormat\r
        POP      EDX\r
        CMP      AL, DL\r
        XCHG     EAX, EBX\r
@@exit:\r
        POP      EBX\r
        JNE      FormatChanged\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.SetPixelFormat(Value: TPixelFormat);\r
begin\r
  if PixelFormat = Value then Exit;\r
  if Empty then Exit;\r
  if Value = pfDevice then\r
    HandleType := bmDDB\r
  else\r
  begin\r
    fNewPixelFormat := Value;\r
    //if Value = pf16bit then Value := pf15bit;\r
    HandleType := bmDIB;\r
    if Value <> Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount ) then\r
      FormatChanged;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[FUNCTION CalcScanLineSize]\r
{$IFDEF ASM_VERSION}\r
function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;\r
asm\r
        MOVZX    EDX, [EAX].TBitmapInfoHeader.biBitCount\r
        MOV      EAX, [EAX].TBitmapInfoHeader.biWidth\r
        MUL      EDX\r
        ADD      EAX, 31\r
        SHR      EAX, 3\r
        AND      EAX, -4\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;\r
begin\r
  //Result := ((Header.biBitCount * Header.biWidth + 31)\r
  //          shr 5) * 4;\r
  Result := ((Header.biBitCount * Header.biWidth + 31) shr 3) and $FFFFFFFC;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END CalcScanLineSize]\r
\r
//[PROCEDURE FillBmpWithBkColor]\r
{$IFDEF ASM_VERSION}\r
procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer );\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        XCHG     EAX, EBX\r
        PUSH     EDX // [EBP-12] = DC2\r
        PUSH     ECX // [EBP-16] = oldWidth\r
        MOV      EAX, [EBX].TBitmap.fBkColor\r
        CALL     Color2RGB\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        XCHG     ESI, EAX // ESI = Color2RGB( Bmp.fBkColor )\r
        MOV      EAX, EBX\r
        CALL     TBitmap.GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        PUSH     EAX //fHandle\r
        PUSH     dword ptr [EBP-12] //DC2\r
        CALL     SelectObject\r
        PUSH     EAX // [EBP-20] = oldBmp\r
        PUSH     ESI\r
        CALL     CreateSolidBrush\r
        XCHG     ESI, EAX // ESI = Br\r
        PUSH     [EBX].TBitmap.fHeight\r
        PUSH     [EBX].TBitmap.fWidth\r
        MOV      EAX, [oldHeight]\r
        MOV      EDX, [EBP-16] //oldWidth\r
        CMP      EAX, [EBX].TBitmap.fHeight\r
        JL       @@fill\r
        CMP      EDX, [EBX].TBitmap.fWidth\r
        JGE      @@nofill\r
@@fill: CMP      EAX, [EBX].TBitmap.fHeight\r
        JNE      @@1\r
        XOR      EAX, EAX\r
@@1:\r
        CMP      EDX, [EBX].TBitmap.fWidth\r
        JNZ      @@2\r
        CDQ\r
@@2:    PUSH     EAX\r
        PUSH     EDX\r
\r
        MOV      EDX, ESP\r
        PUSH     ESI\r
        PUSH     EDX\r
        PUSH     dword ptr [EBP-12] //DC2\r
        CALL     Windows.FillRect\r
        POP      ECX\r
        POP      ECX\r
@@nofill:\r
        POP      ECX\r
        POP      ECX\r
        PUSH     ESI //Br\r
        CALL     DeleteObject\r
        PUSH     dword ptr [EBP-12] //DC2\r
        CALL     SelectObject\r
@@exit:\r
        POP      ECX\r
        POP      EDX\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer );\r
var oldBmp: HBitmap;\r
    R: TRect;\r
    Br: HBrush;\r
begin\r
  with Bmp{-}^{+} do\r
  if Color2RGB( fBkColor ) <> 0 then\r
  if (oldWidth < fWidth) or (oldHeight < fHeight) then\r
    if GetHandle <> 0 then\r
    begin\r
      oldBmp := SelectObject( DC2, fHandle );\r
      ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );\r
      Br := CreateSolidBrush( Color2RGB( fBkColor ) );\r
      R := MakeRect( oldWidth, oldHeight, fWidth, fHeight );\r
      if oldWidth = fWidth then\r
         R.Left := 0;\r
      if oldHeight = fHeight then\r
         R.Top := 0;\r
      Windows.FillRect( DC2, R, Br );\r
      DeleteObject( Br );\r
      SelectObject( DC2, oldBmp );\r
    end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END FillBmpWithBkColor]\r
\r
const BitCounts: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.FormatChanged]\r
procedure TBitmap.FormatChanged;\r
type  tBIH = TBitmapInfoHeader;\r
      tBmp = tagBitmap;\r
const szBIH = Sizeof( tBIH );\r
      szBmp = Sizeof( tBmp );\r
asm\r
        PUSH     EAX\r
        CALL     GetEmpty\r
        POP      EAX\r
        JZ       @@exit\r
        PUSHAD\r
        MOV      EBX, EAX\r
        CALL     [EBX].fDetachCanvas\r
        XOR      EAX, EAX\r
        MOV      [EBX].fScanLineSize, EAX\r
        MOV      [EBX].fGetDIBPixels, EAX\r
        MOV      [EBX].fSetDIBPixels, EAX\r
        MOV      ESI, [EBX].fWidth    // ESI := oldWidth\r
        MOV      EDI, [EBX].fHeight   // EDI := oldHeight\r
        MOV      ECX, [EBX].fDIBBits\r
        JECXZ    @@noDIBBits\r
        MOV      EAX, [EBX].fDIBHeader\r
        MOV      ESI, [EAX].TBitmapInfo.bmiHeader.biWidth\r
        MOV      EDI, [EAX].TBitmapInfo.bmiHeader.biHeight\r
        TEST     EDI, EDI\r
        JGE      @@1\r
        NEG      EDI\r
@@1:    JMP      @@createDC2\r
@@noDIBBits:\r
        MOV      ECX, [EBX].fHandle\r
        JECXZ    @@createDC2\r
        ADD      ESP, -24 // -szBmp\r
        PUSH     ESP\r
        PUSH     24 //szBmp\r
        PUSH     ECX\r
        CALL     GetObject\r
        XCHG     ECX, EAX\r
        JECXZ    @@2\r
        MOV      ESI, [ESP].tBmp.bmWidth\r
        MOV      EDI, [ESP].tBmp.bmHeight\r
@@2:    ADD      ESP, 24 //szBmp\r
@@createDC2:\r
        PUSH     0\r
        CALL     CreateCompatibleDC\r
        PUSH     EAX                         // > DC2\r
        CMP      [EBX].fHandleType, bmDDB\r
        JNE      @@DIB_handle_type\r
        PUSH     0\r
        CALL     GetDC\r
        PUSH     EAX                         // > DC0\r
        PUSH     [EBX].fHeight\r
        PUSH     [EBX].fWidth\r
        PUSH     EAX\r
        CALL     CreateCompatibleBitmap\r
        XCHG     EBP, EAX        // EBP := NewHandle\r
        PUSH     0\r
        CALL     ReleaseDC                   // <\r
        POP      EDX\r
        PUSH     EDX             // EDX := DC2\r
        PUSH     EBP\r
        PUSH     EDX\r
        CALL     SelectObject\r
        PUSH     EAX                         // > OldBmp\r
        PUSH     [EBX].fHeight   // prepare Rect(0,0,fWidth,fHeight)\r
        PUSH     [EBX].fWidth\r
        PUSH     0\r
        PUSH     0\r
        MOV      EAX, [EBX].fBkColor\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        CALL     CreateSolidBrush\r
        MOV      EDX, ESP\r
        PUSH     EAX                         // > Br\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     dword ptr [ESP+32] // (DC2)\r
        CALL     Windows.FillRect\r
        CALL     DeleteObject                // <\r
        ADD      ESP, 16            // remove Rect\r
        MOV      ECX, [EBX].fDIBBits\r
        JECXZ    @@draw\r
        PUSH     dword ptr [ESP+4] // (DC2)\r
        CALL     SelectObject                // < (OldBmp)\r
        PUSH     DIB_RGB_COLORS    // : DIB_RGB_COLORS\r
        PUSH     [EBX].fDIBHeader  // : fDIBHeader\r
        PUSH     [EBX].fDIBBits    // : fDIBBits\r
        PUSH     [EBX].fHeight     // : fHeight\r
        PUSH     0                 // : 0\r
        PUSH     EBP               // : NewHandle\r
        PUSH     dword ptr [ESP+24] // (DC2)\r
        CALL     SetDIBits\r
        JMP      @@clearData\r
@@draw:\r
        MOV      EDX, [ESP+4]\r
        PUSH     EDX           // prepare DC2 for SelectObject\r
        MOV      EAX, EBX\r
        XOR      ECX, ECX\r
        PUSH     ECX\r
        CALL     Draw\r
        CALL     SelectObject\r
@@clearData:\r
        MOV      EAX, EBX\r
        CALL     ClearData\r
        MOV      [EBX].fHandle, EBP\r
\r
        JMP      @@fillBkColor\r
\r
@@DIB_handle_type:    // [ESP] = DC2\r
        MOVZX    EAX, [EBX].fNewPixelFormat\r
@@getBitsPixel:\r
        XCHG     ECX, EAX\r
        MOV      CL, [ECX] + offset BitCounts\r
        MOVZX    EAX, [DefaultPixelFormat]\r
        JECXZ    @@getBitsPixel\r
        XOR      EBP, EBP            // NewHandle := 0\r
        MOV      EAX, [EBX].fWidth   // EAX := fWidth\r
        MOV      EDX, [EBX].fHeight  // EDX := fHeight\r
        CALL     PrepareBitmapHeader\r
        PUSH     EAX                            // > NewHeader\r
        CMP      [EBX].fNewPixelFormat, pf16bit\r
        JNE      @@newHeaderReady\r
        CALL     PreparePF16bit\r
@@newHeaderReady:\r
        POP      EAX\r
        PUSH     EAX\r
        CALL     CalcScanLineSize\r
        MOV      EDX, [EBX].fHeight\r
        MUL      EDX\r
        PUSH     EAX                           // > sizeBits\r
\r
        {$IFDEF _FP}\r
        CALL     GetMem\r
        {$ELSE}\r
        CALL     System.@GetMem\r
        {$ENDIF}\r
        PUSH     EAX                           // > NewBits\r
        PUSH     DIB_RGB_COLORS\r
        PUSH     dword ptr [ESP+12] // (NewHeader)\r
        PUSH     EAX\r
        MOV      EAX, [EBX].fHeight\r
        CMP      EAX, EDI\r
        {$IFDEF USE_CMOV}\r
        CMOVG    EAX, EDI\r
        {$ELSE}\r
        JLE      @@3\r
        MOV      EAX, EDI\r
@@3:    {$ENDIF}\r
\r
        PUSH     EAX\r
        PUSH     0\r
        MOV      EAX, EBX\r
        CALL     GetHandle\r
        PUSH     EAX\r
        PUSH     dword ptr [ESP+36] // (DC2)\r
        CALL     GetDIBits\r
\r
        MOV      EDX, [EBX].fHeight\r
        CMP      EDX, EDI\r
        {$IFDEF USE_CMOV}\r
        CMOVG    EDX, EDI\r
        {$ELSE}\r
        JLE      @@30\r
        MOV      EDX, EDI\r
@@30:   {$ENDIF}\r
\r
        CMP      EAX, EDX\r
        JE       @@2clearData\r
\r
        POP      EAX\r
        {$IFDEF _FP}\r
        CALL     FreeMem\r
        {$ELSE}\r
        CALL     System.@FreeMem\r
        {$ENDIF}\r
\r
        XOR      EAX, EAX\r
        PUSH     EAX\r
\r
        MOV      EDX, ESP        // EDX = @NewBits\r
        MOV      ECX, [ESP+8]    // ECX = @NewHeader\r
        PUSH     EAX             // -> 0\r
        PUSH     EAX             // -> 0\r
        PUSH     EDX             // -> @NewBits\r
        PUSH     DIB_RGB_COLORS  // -> DIB_RGB_COLORS\r
        PUSH     ECX             // -> @NewHeader\r
        PUSH     dword ptr [ESP+32] // -> DC2\r
        CALL     CreateDIBSection\r
\r
        XOR      ESI, -1 // use OldWidth to store NewDIBAutoFree flag\r
\r
        XCHG     EBP, EAX        // EBP := NewHandle\r
        PUSH     EBP\r
        PUSH     dword ptr [ESP+16] // -> DC2\r
        CALL     SelectObject\r
        PUSH     EAX           // save oldBmp\r
        MOV      EDX, [ESP+16] // DC2 -> EDX (DC)\r
        XOR      ECX, ECX      // 0   -> ECX (X)\r
        PUSH     ECX           // 0   -> stack (Y)\r
        MOV      EAX, EBX\r
        CALL     TBitmap.Draw\r
        PUSH     dword ptr [ESP+16] // -> DC2\r
        CALL     SelectObject\r
\r
@@2clearData:\r
        MOV      EAX, EBX\r
        CALL     ClearData\r
\r
        POP      [EBX].fDIBBits\r
        POP      [EBX].fDIBSize\r
        POP      [EBX].fDIBHeader\r
        MOV      [EBX].fHandle, EBP\r
\r
        TEST     ESI, ESI\r
        MOV      [EBX].fDIBAutoFree, 0\r
        JGE      @@noDIBautoFree\r
        INC      [EBX].fDIBAutoFree\r
@@noDIBautoFree:\r
\r
@@fillBkColor:\r
        MOV      ECX, [EBX].fFillWithBkColor\r
        JECXZ    @@deleteDC2\r
        POP      EDX // (DC2)\r
        PUSH     EDX\r
        PUSH     EDI\r
        XCHG     ECX, ESI\r
        XCHG     EAX, EBX\r
        CALL     ESI\r
@@deleteDC2:\r
        CALL     DeleteDC\r
        POPAD\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.FormatChanged;\r
// This method is used whenever Width, Height, PixelFormat or HandleType\r
// properties are changed.\r
// Old image will be drawn here to a new one (excluding cases when\r
// old width or height was 0, and / or new width or height is 0).\r
// To avoid inserting this code into executable, try not to change\r
// properties Width / Height of bitmat after it is created using\r
// NewBitmap( W, H ) function or after it is loaded from file, stream\r
// or resource.\r
\r
var B: tagBitmap;\r
    oldBmp, NewHandle: HBitmap;\r
    DC0, DC2: HDC;\r
    NewHeader: PBitmapInfo;\r
    NewBits: Pointer;\r
    oldHeight, oldWidth, sizeBits, bitsPixel: Integer;\r
    Br: HBrush;\r
    N: Integer;\r
    NewDIBAutoFree: Boolean;\r
    Hndl: THandle;\r
begin\r
  if Empty then Exit;\r
  NewDIBAutoFree := FALSE;\r
  fDetachCanvas( @Self );\r
  fScanLineSize := 0;\r
  fGetDIBPixels := nil;\r
  fSetDIBPixels := nil;\r
\r
    oldWidth := fWidth;\r
    oldHeight := fHeight;\r
    if fDIBBits <> nil then\r
    begin\r
      oldWidth := fDIBHeader.bmiHeader.biWidth;\r
      oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);\r
    end\r
      else\r
    if fHandle <> 0 then\r
    begin\r
      if GetObject( fHandle, Sizeof( B ), @ B ) <> 0 then\r
      begin\r
        oldWidth := B.bmWidth;\r
        oldHeight := B.bmHeight;\r
      end;\r
    end;\r
\r
  DC2 := CreateCompatibleDC( 0 );\r
\r
  if fHandleType = bmDDB then\r
  begin\r
    // New HandleType is bmDDB: old bitmap can be copied using Draw method\r
    DC0 := GetDC( 0 );\r
    NewHandle := CreateCompatibleBitmap( DC0, fWidth, fHeight );\r
    ASSERT( NewHandle <> 0, 'Can not create DDB' );\r
    ReleaseDC( 0, DC0 );\r
\r
    oldBmp := SelectObject( DC2, NewHandle );\r
    ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );\r
\r
    Br := CreateSolidBrush( Color2RGB( fBkColor ) );\r
    FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br );\r
    DeleteObject( Br );\r
\r
    if fDIBBits <> nil then\r
    begin\r
      SelectObject( DC2, oldBmp );\r
      SetDIBits( DC2, NewHandle, 0, fHeight, fDIBBits, fDIBHeader^, DIB_RGB_COLORS );\r
    end\r
       else\r
    begin\r
      Draw( DC2, 0, 0 );\r
      SelectObject( DC2, oldBmp );\r
    end;\r
\r
    ClearData; // Image is cleared but fWidth and fHeight are preserved\r
    fHandle := NewHandle;\r
  end\r
     else\r
  begin\r
    // New format is DIB. GetDIBits applied to transform old data to new one.\r
    bitsPixel := BitCounts[ fNewPixelFormat ];\r
    if bitsPixel = 0 then\r
    begin\r
      bitsPixel := BitCounts[DefaultPixelFormat];\r
    end;\r
\r
    NewHandle := 0;\r
    NewHeader := PrepareBitmapHeader( fWidth, fHeight, bitsPixel );\r
    if fNewPixelFormat = pf16bit then\r
      PreparePF16bit( NewHeader );\r
\r
    sizeBits := CalcScanLineSize( @NewHeader.bmiHeader ) * fHeight;\r
\r
      GetMem( NewBits, sizeBits );\r
      ASSERT( NewBits <> nil, 'No memory' );\r
\r
      Hndl := GetHandle;\r
      if Hndl = 0 then Exit;\r
      N :=\r
      GetDIBits( DC2, Hndl, 0, Min( fHeight, oldHeight ),\r
                 NewBits, NewHeader^, DIB_RGB_COLORS );\r
      //Assert( N = Min( fHeight, oldHeight ), 'Can not get all DIB bits' );\r
      if N <> Min( fHeight, oldHeight ) then\r
      begin\r
        FreeMem( NewBits );\r
        NewBits := nil;\r
        NewHandle := CreateDIBSection( DC2, NewHeader^, DIB_RGB_COLORS, NewBits, 0, 0 );\r
        NewDIBAutoFree := TRUE;\r
        ASSERT( NewHandle <> 0, 'Can not create DIB secion for pf16bit bitmap' );\r
        oldBmp := SelectObject( DC2, NewHandle );\r
        ASSERT( oldBmp <> 0, 'Can not select pf16bit to DC' );\r
        Draw( DC2, 0, 0 );\r
        SelectObject( DC2, oldBmp );\r
      end;\r
\r
    ClearData;\r
    fDIBSize := sizeBits;\r
    fDIBBits := NewBits;\r
    fDIBHeader := NewHeader;\r
    fHandle := NewHandle;\r
    fDIBAutoFree := NewDIBAutoFree;\r
\r
  end;\r
\r
  if Assigned( fFillWithBkColor ) then\r
     fFillWithBkColor( @Self, DC2, oldWidth, oldHeight );\r
\r
  DeleteDC( DC2 );\r
\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.GetScanLine]\r
function TBitmap.GetScanLine(Y: Integer): Pointer;\r
asm\r
        MOV      ECX, [EAX].fDIBHeader\r
        JECXZ    @@exit\r
        MOV      ECX, [ECX].TBitmapInfoHeader.biHeight\r
        TEST     ECX, ECX\r
        JL       @@1\r
\r
        SUB      ECX, EDX\r
        DEC      ECX\r
        MOV      EDX, ECX\r
\r
@@1:    MOV      ECX, [EAX].fScanLineSize\r
        INC      ECX\r
        PUSH     [EAX].fDIBBits\r
        LOOP     @@2\r
\r
        PUSH     EDX\r
        CALL     GetScanLineSize\r
        POP      EDX\r
        XCHG     ECX, EAX\r
\r
@@2:    XCHG     EAX, ECX\r
        MUL      EDX\r
        POP      ECX\r
        ADD      ECX, EAX\r
\r
@@exit: XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.GetScanLine(Y: Integer): Pointer;\r
begin\r
  ASSERT( (Y >= 0) {and (Y < fHeight)}, 'ScanLine index out of bounds' );\r
  ASSERT( fDIBBits <> nil, 'No bits available' );\r
  Result := nil;\r
  if fDIBHeader = nil then Exit;\r
\r
  if fDIBHeader.bmiHeader.biHeight > 0 then\r
     Y := fHeight - 1 - Y;\r
  if fScanLineSize = 0 then\r
     ScanLineSize;\r
\r
  Result := Pointer( Integer( fDIBBits ) + fScanLineSize * Y );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.GetScanLineSize]\r
function TBitmap.GetScanLineSize: Integer;\r
asm\r
        MOV      ECX, [EAX].fDIBHeader\r
        JECXZ    @@exit\r
\r
        PUSH     EAX\r
        XCHG     EAX, ECX\r
        CALL     CalcScanLineSize\r
        XCHG     ECX, EAX\r
        POP      EAX\r
        MOV      [EAX].fScanLineSize, ECX\r
\r
@@exit: XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.GetScanLineSize: Integer;\r
begin\r
  Result := 0;\r
  if fDIBHeader = nil then Exit;\r
  FScanLineSize := CalcScanLineSize( @fDIBHeader.bmiHeader );\r
  Result := FScanLineSize;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.CanvasChanged]\r
procedure TBitmap.CanvasChanged( Sender : PObj );\r
asm\r
        PUSH     EAX\r
\r
          XCHG     EAX, EDX\r
          CALL     TCanvas.GetBrush\r
          MOV      EDX, [EAX].TGraphicTool.fData.Color\r
\r
        POP      EAX\r
        MOV      [EAX].fBkColor, EAX\r
        CALL     ClearTransImage\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.CanvasChanged( Sender : PObj );\r
begin\r
  fBkColor := PCanvas( Sender ).Brush.Color;\r
  ClearTransImage;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.Dormant]\r
procedure TBitmap.Dormant;\r
asm\r
        PUSH     EAX\r
        CALL     RemoveCanvas\r
        POP      EAX\r
        MOV      ECX, [EAX].fHandle\r
        JECXZ    @@exit\r
        CALL     ReleaseHandle\r
        PUSH     EAX\r
        CALL     DeleteObject\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.Dormant;\r
begin\r
  RemoveCanvas;\r
  if fHandle <> 0 then\r
    DeleteObject( ReleaseHandle );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.SetBkColor]\r
procedure TBitmap.SetBkColor(const Value: TColor);\r
asm\r
        CMP      [EAX].fBkColor, EDX\r
        JE       @@exit\r
        MOV      [EAX].fBkColor, EDX\r
        MOV      [EAX].fFillWithBkColor, offset[FillBmpWithBkColor]\r
        MOV      ECX, [EAX].fApplyBkColor2Canvas\r
        JECXZ    @@exit\r
        CALL     ECX\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.SetBkColor(const Value: TColor);\r
begin\r
  if fBkColor = Value then Exit;\r
  fBkColor := Value;\r
  fFillWithBkColor := FillBmpWithBkColor;\r
  if Assigned( fApplyBkColor2Canvas ) then\r
    fApplyBkColor2Canvas( @Self );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION} \r
//[function TBitmap.Assign]\r
function TBitmap.Assign(SrcBmp: PBitmap): Boolean;\r
const szBIH = sizeof(TBitmapInfoHeader);\r
asm\r
        PUSHAD\r
        XCHG     EBX, EAX\r
@@clear:\r
        MOV      ESI, EDX\r
        MOV      EAX, EBX\r
        CALL     Clear\r
        MOV      EAX, ESI\r
        OR       EAX, EAX\r
        JZ       @@exit\r
        CALL     GetEmpty\r
        JZ       @@exit\r
        MOV      EAX, [ESI].fWidth\r
        MOV      [EBX].fWidth, EAX\r
        MOV      EAX, [ESI].fHeight\r
        MOV      [EBX].fHeight, EAX\r
        MOVZX    ECX, [ESI].fHandleType\r
        MOV      [EBX].fHandleType, CL\r
          JECXZ    @@fmtDIB\r
\r
        DEC      ECX  // ECX = 0\r
        PUSH     ECX\r
        PUSH     ECX\r
        PUSH     ECX\r
        PUSH     ECX //IMAGE_BITMAP=0\r
        PUSH     [ESI].fHandle\r
        CALL     CopyImage\r
        MOV      [EBX].fHandle, EAX\r
        TEST     EAX, EAX\r
        XCHG     EDX, EAX\r
        JZ       @@clear\r
        JMP      @@exit\r
\r
@@fmtDIB:\r
        XCHG     EAX, ECX\r
        MOV      AX, szBIH+1024\r
        PUSH     EAX\r
        CALL     System.@GetMem\r
        MOV      [EBX].fDIBHeader, EAX\r
        XCHG     EDX, EAX\r
        POP      ECX\r
        MOV      EAX, [ESI].fDIBHeader\r
        CALL     System.Move\r
        MOV      EAX, [ESI].fDIBSize\r
        MOV      [EBX].fDIBSize, EAX\r
        PUSH     EAX\r
        CALL     System.@GetMem\r
        MOV      [EBX].fDIBBits, EAX\r
        XCHG     EDX, EAX\r
        POP      ECX\r
        MOV      EAX, [ESI].fDIBBits\r
        CALL     System.Move\r
\r
        INC      EBX // reset "ZF"\r
\r
@@exit:\r
        POPAD\r
        SETNZ    AL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.Assign(SrcBmp: PBitmap): Boolean;\r
begin\r
  Clear;\r
  Result := False;\r
  if SrcBmp = nil then Exit;\r
  if SrcBmp.Empty then Exit;\r
  fWidth := SrcBmp.fWidth;\r
  fHeight := SrcBmp.fHeight;\r
  fHandleType := SrcBmp.fHandleType;\r
  if SrcBmp.fHandleType = bmDDB then\r
  begin\r
    fHandle := CopyImage( SrcBmp.fHandle, IMAGE_BITMAP, 0, 0, 0 {LR_COPYRETURNORG} );\r
    ASSERT( fHandle <> 0, 'Can not copy bitmap image' );\r
    Result := fHandle <> 0;\r
    if not Result then Clear;\r
  end\r
     else\r
  begin\r
    GetMem( fDIBHeader, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );\r
    ASSERT( fDIBHeader <> nil, 'No memory' );\r
    Move( SrcBmp.fDIBHeader^, fDIBHeader^, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );\r
    fDIBSize := SrcBmp.fDIBSize;\r
    GetMem( fDIBBits, fDIBSize );\r
    ASSERT( fDIBBits <> nil, 'No memory' );\r
    Move( SrcBmp.fDIBBits^, fDIBBits^, fDIBSize );\r
    //fDIBAutoFree := TRUE;\r
    Result := True;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.RemoveCanvas]\r
procedure TBitmap.RemoveCanvas;\r
asm\r
        PUSH     EAX\r
        CALL     [EAX].fDetachCanvas\r
        POP      EDX\r
        XOR      EAX, EAX\r
        XCHG     EAX, [EDX].fCanvas\r
        CALL     TObj.Free\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.RemoveCanvas;\r
begin\r
  fDetachCanvas( @Self );\r
  fCanvas.Free;\r
  fCanvas := nil;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.DIBPalNearestEntry]\r
function TBitmap.DIBPalNearestEntry(Color: TColor): Integer;\r
const szBIH = sizeof(TBitmapInfoHeader);\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        XCHG     ESI, EAX\r
        XCHG     EAX, EDX\r
        CALL     Color2RGBQuad\r
        XCHG     EDI, EAX\r
        MOV      EAX, ESI\r
        CALL     GetDIBPalEntryCount\r
        XCHG     ECX, EAX\r
        XOR      EAX, EAX\r
        JECXZ    @@exit\r
\r
        MOV      ESI, [ESI].fDIBHeader\r
        ADD      ESI, szBIH\r
        XOR      EDX, EDX\r
        PUSH     EDX\r
        DEC      DX\r
\r
@@loo:  LODSD\r
        XOR      EAX, EDI\r
        MOV      EBX, EAX\r
        SHR      EBX, 16\r
        MOV      BH, 0\r
        ADD      AL, AH\r
        MOV      AH, 0\r
        ADC      AX, BX\r
        CMP      AX, DX\r
        JAE      @@1\r
        MOV      DX, AX\r
        POP      EBX\r
        PUSH     EDX // save better index (in high order word)\r
@@1:    ADD      EDX, $10000 // increment index\r
        LOOP     @@loo\r
\r
        XCHG     EAX, ECX\r
        POP      AX\r
        POP      AX\r
@@exit:\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.DIBPalNearestEntry(Color: TColor): Integer;\r
var I, Diff, D: Integer;\r
    C : Integer;\r
begin\r
  Color := TColor( Color2RGBQuad( Color ) );\r
  Result := 0;\r
  Diff := MaxInt;\r
  for I := 0 to DIBPalEntryCount - 1 do\r
  begin\r
    C := Color xor PInteger( Integer( @fDIBHeader.bmiColors[ 0 ] )\r
                    + I * Sizeof( TRGBQuad ) )^;\r
    D := TRGBQuad( C ).rgbBlue + TRGBQuad( C ).rgbGreen + TRGBQuad( C ).rgbRed;\r
    if D < Diff then\r
    begin\r
      Diff := D;\r
      Result := I;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.GetDIBPalEntries]\r
function TBitmap.GetDIBPalEntries(Idx: Integer): TColor;\r
const szBIH = sizeof(TBitmapInfoHeader);\r
asm\r
        MOV      ECX, [EAX].fDIBHeader\r
        JECXZ    @@exit\r
\r
        MOV      ECX, [EAX+szBIH+EDX*4]\r
        INC      ECX\r
\r
@@exit: DEC      ECX\r
        XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.GetDIBPalEntries(Idx: Integer): TColor;\r
begin\r
  Result := TColor(-1);\r
  if fDIBBits = nil then Exit;\r
  ASSERT( PixelFormat in [pf1bit..pf8bit], 'Format has no DIB palette entries available' );\r
  ASSERT( (Idx >= 0) and (Idx < (1 shl fDIBHeader.bmiHeader.biBitCount)),\r
          'DIB palette index out of bounds' );\r
  Result := PDWORD( Integer( @fDIBHeader.bmiColors[ 0 ] )\r
          + Idx * Sizeof( TRGBQuad ) )^;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.GetDIBPalEntryCount]\r
function TBitmap.GetDIBPalEntryCount: Integer;\r
asm\r
        PUSH     EAX\r
        CALL     GetEmpty\r
        POP      EAX\r
        JZ       @@ret0\r
        CALL     GetPixelFormat\r
        MOVZX    ECX, AL\r
        MOV      EAX, ECX\r
        LOOP     @@1\r
        // pf1bit:\r
        INC      EAX\r
        RET\r
@@1:\r
        LOOP     @@2\r
        // pf4bit:\r
        MOV      AL, 16\r
        RET\r
@@2:\r
        LOOP     @@ret0\r
        // pf8bit:\r
        XOR      EAX, EAX\r
        INC      AH\r
        RET\r
@@ret0:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.GetDIBPalEntryCount: Integer;\r
begin\r
  Result := 0;\r
  if Empty then Exit;\r
  case PixelFormat of\r
  pf1bit: Result := 2;\r
  pf4bit: Result := 16;\r
  pf8bit: Result := 256;\r
  else;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TBitmap.SetDIBPalEntries]\r
procedure TBitmap.SetDIBPalEntries(Idx: Integer; const Value: TColor);\r
begin\r
  if fDIBBits = nil then Exit;\r
  Dormant;\r
  PDWORD( Integer( @fDIBHeader.bmiColors[ 0 ] )\r
                    + Idx * Sizeof( TRGBQuad ) )^ := Color2RGB( Value );\r
end;\r
\r
//[procedure TBitmap.SetHandleType]\r
procedure TBitmap.SetHandleType(const Value: TBitmapHandleType);\r
{var B: tagBitmap;\r
    DC0: HDC;}\r
begin\r
  if fHandleType = Value then Exit;\r
  //++++++++++++++++ ?????????\r
  {if fHandleType = bmDDB then\r
    if PixelFormat = pfDevice then\r
    begin\r
      DC0 := GetDC( 0 );\r
      fNewPixelFormat := Bits2PixelFormat( GetDeviceCaps( DC0, BITSPIXEL ) );\r
      ReleaseDC( 0, DC0 );\r
    end\r
      else\r
    if FHandle <> 0 then\r
    begin\r
      if GetObject( FHandle, Sizeof( B ), @ B ) > 0 then\r
        fNewPixelFormat := Bits2PixelFormat( B.bmPlanes * B.bmBitsPixel );\r
    end;}\r
  //----------------\r
  fHandleType := Value;\r
  FormatChanged;\r
end;\r
\r
//[function TBitmap.GetPixelFormat]\r
function TBitmap.GetPixelFormat: TPixelFormat;\r
begin\r
  if (HandleType = bmDDB) or (fDIBBits = nil) then\r
    Result := pfDevice\r
  else\r
  begin\r
    Result := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount );\r
    if (Result = pf15bit) and (fDIBHeader.bmiHeader.biCompression <> 0) then\r
    begin\r
      Assert( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );\r
      Result := pf16bit;\r
    end;\r
  end;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.ClearTransImage]\r
procedure TBitmap.ClearTransImage;\r
asm\r
        OR       [EAX].fTransColor, -1\r
        XOR      EDX, EDX\r
        XCHG     [EAX].fTransMaskBmp, EDX\r
        XCHG     EAX, EDX\r
        CALL     TObj.Free\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.ClearTransImage;\r
begin\r
  fTransColor := clNone;\r
  fTransMaskBmp.Free;\r
  fTransMaskBmp := nil;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.Convert2Mask]\r
procedure TBitmap.Convert2Mask(TranspColor: TColor);\r
asm\r
        PUSH     EBX\r
        PUSH     ESI\r
        MOV      EBX, EAX\r
        MOV      ESI, EDX\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
\r
        PUSH     0\r
        PUSH     1\r
        PUSH     1\r
        PUSH     [EBX].fHeight\r
        PUSH     [EBX].fWidth\r
        CALL     CreateBitmap\r
        PUSH     EAX                // MonoHandle\r
        PUSH     0\r
        CALL     CreateCompatibleDC\r
        POP      EDX\r
        PUSH     EDX\r
        PUSH     EAX                // MonoDC\r
\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     SelectObject\r
        PUSH     EAX                // SaveMono\r
\r
        CALL     StartDC            // DCfrom, SaveFrom\r
        XCHG     EAX, ESI\r
        CALL     Color2RGB\r
        PUSH     EAX // Color2RGB(TranspColor)\r
        PUSH     dword ptr [ESP+8] //DCfrom\r
        CALL     Windows.SetBkColor\r
        PUSH     EAX                // SaveBkColor\r
\r
        PUSH     SRCCOPY\r
        PUSH     0\r
        PUSH     0\r
        PUSH     dword ptr [ESP+12+4+4] //DCfrom\r
        PUSH     [EBX].fHeight\r
        PUSH     [EBX].fWidth\r
        PUSH     0\r
        PUSH     0\r
        PUSH     dword ptr [ESP+32+16] //MonoDC\r
        CALL     BitBlt\r
\r
        PUSH     dword ptr [ESP+8] //DCfrom\r
        CALL     Windows.SetBkColor // ESP-> SaveFrom\r
        CALL     FinishDC           // ESP-> SaveMono\r
        CALL     FinishDC           // ESP-> MonoHandle\r
\r
        MOV      EAX, EBX\r
        CALL     ClearData\r
        POP      [EBX].fHandle\r
        MOV      [EBX].fHandleType, bmDDB\r
@@exit:\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.Convert2Mask(TranspColor: TColor);\r
var MonoHandle: HBitmap;\r
    SaveMono, SaveFrom: THandle;\r
    MonoDC, {DC0,} DCfrom: HDC;\r
    SaveBkColor: TColorRef;\r
begin\r
  if GetHandle = 0 then Exit;\r
  fDetachCanvas( @Self );\r
  ///DC0 := GetDC( 0 );\r
  MonoHandle := CreateBitmap( fWidth, fHeight, 1, 1, nil );\r
  ASSERT( MonoHandle <> 0, 'Can not create monochrome bitmap' );\r
  MonoDC := CreateCompatibleDC( 0 );\r
  SaveMono := SelectObject( MonoDC, MonoHandle );\r
  ASSERT( SaveMono <> 0, 'Can not select bitmap to DC' );\r
  DCfrom := CreateCompatibleDC( 0 );\r
  SaveFrom := SelectObject( DCfrom, fHandle );\r
  ASSERT( SaveFrom <> 0, 'Can not select source bitmap to DC' );\r
  TranspColor := Color2RGB( TranspColor );\r
  SaveBkColor := Windows.SetBkColor( DCfrom, TranspColor );\r
  BitBlt( MonoDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, SRCCOPY );\r
  {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}\r
  Windows.SetBkColor( DCfrom, SaveBkColor );\r
  SelectObject( DCfrom, SaveFrom );\r
  DeleteDC( DCfrom );\r
  SelectObject( MonoDC, SaveMono );\r
  DeleteDC( MonoDC );\r
  ///ReleaseDC( 0, DC0 );\r
  ClearData;\r
  fHandle := MonoHandle;\r
  fHandleType := bmDDB;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TBitmap.Invert]\r
procedure TBitmap.Invert;\r
begin\r
  //BitBlt( Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, DSTINVERT  )\r
  InvertRect(Canvas.Handle, BoundsRect);\r
end;\r
\r
//[procedure TBitmap.DIBDrawRect]\r
procedure TBitmap.DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect );\r
begin\r
  if fDIBBits = nil then Exit;\r
  StretchDIBits( DC, X, Y, R.Right - R.Left, R.Bottom - R.Top,\r
                 R.Left, fHeight - R.Bottom, R.Right - R.Left, R.Bottom - R.Top,\r
                 fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY );\r
end;\r
\r
//[PROCEDURE _PrepareBmp2Rotate]\r
{$IFDEF ASM_VERSION}\r
procedure _PrepareBmp2Rotate;\r
const szBIH = sizeof(TBitmapInfoHeader);\r
asm\r
        { <- BL = increment to height }\r
        XCHG     EDI, EAX\r
        MOV      ESI, EDX // ESI = SrcBmp\r
\r
        XCHG     EAX, EDX\r
        CALL     TBitmap.GetPixelFormat\r
        MOVZX    ECX, AL\r
        PUSH     ECX\r
\r
        MOV      EDX, [ESI].TBitmap.fWidth\r
        MOVZX    EBX, BL\r
        ADD      EDX, EBX\r
\r
        MOV      EAX, [ESI].TBitmap.fHeight\r
        CALL     NewDIBBitmap\r
        STOSD\r
        XCHG     EDI, EAX\r
\r
        MOV      EAX, [ESI].TBitmap.fDIBHeader\r
        ADD      EAX, szBIH\r
        MOV      EDX, [EDI].TBitmap.fDIBHeader\r
        ADD      EDX, szBIH\r
        XOR      ECX, ECX\r
        MOV      CH, 4\r
        CALL     System.Move\r
\r
        MOV      EAX, EDI\r
        XOR      EDX, EDX\r
        CALL     TBitmap.GetScanLine\r
        MOV      EBX, [EDI].TBitmap.fWidth\r
        DEC      EBX // EBX = DstBmp.fWidth - 1\r
        XCHG     EDI, EAX // EDI = DstBmp.ScanLine[ 0 ]\r
\r
        XOR      EDX, EDX\r
        INC      EDX\r
        CALL     TBitmap.GetScanLine\r
        XCHG     EDX, EAX\r
        SUB      EDX, EDI // EDX = BytesPerDstLine\r
\r
        MOV      EBP, [ESI].TBitmap.fWidth\r
        DEC      EBP // EBP = SrcBmp.fWidth - 1\r
\r
        POP      ECX // ECX = PixelFormat\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _PrepareBmp2Rotate]\r
\r
//[PROCEDURE _RotateBitmapMono]\r
{$IFDEF ASM_VERSION}\r
procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
const szBIH = sizeof(TBitmapInfoHeader);\r
asm\r
        PUSHAD\r
        MOV      BL, 7\r
        CALL     _PrepareBmp2Rotate\r
\r
        SHR      EBP, 3\r
        SHL      EBP, 8 // EBP = (WBytes-1) * 256\r
\r
        MOV      ECX, EBX // ECX and 7 = Shf\r
        SHR      EBX, 3\r
        ADD      EDI, EBX // EDI = Dst\r
\r
        XOR      EBX, EBX // EBX = temp mask\r
        XOR      EAX, EAX // Y = 0\r
@@looY:\r
        PUSH     EAX\r
        PUSH     EDI // Dst1 = Dst (Dst1 in EDI, Dst saved)\r
        PUSH     ESI // SrcBmp\r
\r
        PUSH     EDX //BytesPerDstLine\r
        PUSH     ECX //Shf\r
\r
        XCHG     EDX, EAX\r
        XCHG     EAX, ESI\r
        CALL     TBitmap.GetScanLine\r
        XCHG     ESI, EAX // ESI = Src\r
\r
        POP      ECX // CL = Shf\r
        AND      ECX, 7 // ECX = Shf\r
        OR       ECX, EBP // ECX = (Wbytes-1)*8 + Shf\r
        POP      EDX // EDX = BytesPerDstLine\r
\r
        MOV      BH, $80\r
        SHR      EBX, CL // BH = mask, BL = mask & Tmp\r
@@looX:\r
        XOR      EAX, EAX\r
\r
        LODSB\r
\r
        MOV      AH, AL\r
        SHR      EAX, CL\r
        OR       EAX,$01000000\r
\r
@@looBits:\r
        MOV      BL, AH\r
        AND      BL, BH\r
        OR       [EDI], BL\r
        ADD      EDI, EDX\r
        ADD      EAX, EAX\r
        JNC      @@looBits\r
\r
        SUB      ECX, 256\r
        JGE      @@looX\r
\r
        POP      ESI // ESI = SrcBmp\r
        POP      EDI // EDI = Dst\r
        POP      EAX // EAX = Y\r
\r
        ADD      ECX, 256-1\r
        JGE      @@1\r
        DEC      EDI\r
@@1:\r
        INC      EAX\r
        CMP      EAX, [ESI].TBitmap.fHeight\r
        JL       @@looY\r
\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
var X, Y, Z, Shf, Wbytes, BytesPerDstLine: Integer;\r
    Src, Dst, Dst1: PByte;\r
    Tmp: Byte;\r
begin\r
\r
  DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 7) and not 7, pf1bit );\r
  Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 2 * Sizeof( TRGBQuad ) );\r
\r
  // Calculate ones:\r
  Dst := DstBmp.ScanLine[ 0 ];\r
  BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );\r
  Wbytes := (SrcBmp.fWidth + 7) shr 3;\r
\r
  Inc( Dst, (DstBmp.fWidth - 1) shr 3 );\r
  Shf := (DstBmp.fWidth - 1) and 7;\r
\r
  // Rotating bits:\r
  for Y := 0 to SrcBmp.fHeight - 1 do\r
  begin\r
    Src := SrcBmp.ScanLine[ Y ];\r
    Dst1 := Dst;\r
    for X := Wbytes downto 1 do\r
    begin\r
      Tmp := Src^;\r
      Inc( Src );\r
      for Z := 8 downto 1 do\r
      begin\r
        Dst1^ := Dst1^ or ( (Tmp and $80) shr Shf );\r
        Tmp := Tmp shl 1;\r
        Inc( Dst1, BytesPerDstLine );\r
      end;\r
    end;\r
    Dec( Shf );\r
    if Shf < 0 then\r
    begin\r
      Shf := 7;\r
      Dec( Dst );\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _RotateBitmapMono]\r
\r
//[PROCEDURE _RotateBitmap4bit]\r
{$IFDEF ASM_VERSION}\r
procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
const szBIH = sizeof(TBitmapInfoHeader);\r
asm\r
        PUSHAD\r
        MOV      BL, 1\r
        CALL     _PrepareBmp2Rotate\r
\r
        SHR      EBP, 1 // EBP = WBytes - 1\r
        SHL      EBP, 8 // EBP = (WBytes - 1) * 256\r
\r
        // EBX = DstBmp.fWidth - 1\r
        MOV      ECX, EBX\r
        SHL      ECX, 2 // ECX and 7 = Shf (0 or 4)\r
        SHR      EBX, 1\r
        ADD      EDI, EBX // EDI = Dst\r
\r
        XOR      EAX, EAX // Y = 0\r
        XOR      EBX, EBX\r
\r
@@looY:\r
        PUSH     EAX // save Y\r
        PUSH     EDI // Dst1 = Dst (Dst1 in EDI, Dst saved)\r
        PUSH     ESI // SrcBmp\r
\r
        PUSH     EDX // BytesPerDstLine\r
        PUSH     ECX // Shf\r
\r
        XCHG     EDX, EAX\r
        XCHG     EAX, ESI\r
        CALL     TBitmap.GetScanLine\r
        XCHG     ESI, EAX // ESI = Src\r
\r
        POP      ECX\r
        AND      ECX, 7 // CL = Shf\r
        OR       ECX, EBP // ECX = (WBytes-1)*256 + Shf\r
        POP      EDX // EDX = BytesPerDstLine\r
\r
        MOV      BH, $F0\r
        SHR      EBX, CL // shift mask right 4 or 0\r
\r
@@looX:\r
        XOR      EAX, EAX\r
        LODSB\r
        MOV      AH, AL\r
        SHR      EAX, CL\r
\r
        MOV      BL, AH\r
        AND      BL, BH\r
        OR       [EDI], BL\r
        ADD      EDI, EDX\r
\r
        SHL      EAX, 4\r
        AND      AH, BH\r
        OR       [EDI], AH\r
        ADD      EDI, EDX\r
\r
        SUB      ECX, 256\r
        JGE      @@looX\r
\r
        POP      ESI // ESI = SrcBmp\r
        POP      EDI // EDI = Dst\r
        POP      EAX // EAX = Y\r
\r
        ADD      ECX, 256 - 4\r
        JGE      @@1\r
\r
        DEC      EDI\r
@@1:\r
        INC      EAX\r
        CMP      EAX, [ESI].TBitmap.fHeight\r
        JL       @@looY\r
\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
var X, Y, Shf, Wbytes, BytesPerDstLine: Integer;\r
    Src, Dst, Dst1: PByte;\r
    Tmp: Byte;\r
begin\r
\r
  DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 1) and not 1, pf4bit );\r
  Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 16 * Sizeof( TRGBQuad ) );\r
\r
  // Calculate ones:\r
  Dst := DstBmp.ScanLine[ 0 ];\r
  BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );\r
  Wbytes := (SrcBmp.fWidth + 1) shr 1;\r
\r
  Inc( Dst, (DstBmp.fWidth - 1) shr 1 );\r
  Shf := ((DstBmp.fWidth - 1) and 1) shl 2;\r
\r
  // Rotating bits:\r
  for Y := 0 to SrcBmp.fHeight - 1 do\r
  begin\r
    Src := SrcBmp.ScanLine[ Y ];\r
    Dst1 := Dst;\r
    for X := Wbytes downto 1 do\r
    begin\r
      Tmp := Src^;\r
      Inc( Src );\r
      Dst1^ := Dst1^ or ( (Tmp and $F0) shr Shf );\r
      Inc( Dst1, BytesPerDstLine );\r
      Dst1^ := Dst1^ or ( ((Tmp shl 4) and $F0) shr Shf );\r
      Inc( Dst1, BytesPerDstLine );\r
    end;\r
    Dec( Shf, 4 );\r
    if Shf < 0 then\r
    begin\r
      Shf := 4;\r
      Dec( Dst );\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _RotateBitmap4bit]\r
\r
//[PROCEDURE _RotateBitmap8bit]\r
{$IFDEF ASM_VERSION}\r
procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
const szBIH = sizeof(TBitmapInfoHeader);\r
asm\r
        PUSHAD\r
        XOR      EBX, EBX\r
        CALL     _PrepareBmp2Rotate\r
\r
        ADD      EDI, EBX // EDI = Dst\r
\r
        MOV      EBX, EDX // EBX = BytesPerDstLine\r
        DEC      EBX\r
        MOV      EBP, ESI // EBP = SrcBmp\r
\r
        XOR      EDX, EDX // Y = 0\r
\r
@@looY:\r
        PUSH     EDX\r
        PUSH     EDI\r
\r
        MOV      EAX, EBP\r
        CALL     TBitmap.GetScanLine\r
        XCHG     ESI, EAX\r
        MOV      ECX, [EBP].TBitmap.fWidth\r
\r
@@looX:\r
        MOVSB\r
        ADD      EDI, EBX\r
        LOOP     @@looX\r
\r
        POP      EDI\r
        POP      EDX\r
\r
        DEC      EDI\r
        INC      EDX\r
        CMP      EDX, [EBP].TBitmap.fHeight\r
        JL       @@looY\r
\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
var X, Y, Wbytes, BytesPerDstLine: Integer;\r
    Src, Dst, Dst1: PByte;\r
    Tmp: Byte;\r
begin\r
\r
  DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );\r
  Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 256 * Sizeof( TRGBQuad ) );\r
\r
  // Calculate ones:\r
  Wbytes := SrcBmp.fWidth;\r
  Dst := DstBmp.ScanLine[ 0 ];\r
  BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );\r
\r
  Inc( Dst, DstBmp.fWidth - 1 );\r
\r
  // Rotating bits:\r
  for Y := 0 to SrcBmp.fHeight - 1 do\r
  begin\r
    Src := SrcBmp.ScanLine[ Y ];\r
    Dst1 := Dst;\r
    for X := Wbytes downto 1 do\r
    begin\r
      Tmp := Src^;\r
      Inc( Src );\r
      Dst1^ := Tmp;\r
      Inc( Dst1, BytesPerDstLine );\r
    end;\r
    Dec( Dst );\r
  end;\r
\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _RotateBitmap8bit]\r
\r
//[PROCEDURE _RotateBitmap16bit]\r
{$IFDEF ASM_VERSION}\r
procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
asm\r
        PUSHAD\r
        XOR      EBX, EBX\r
        CALL     _PrepareBmp2Rotate\r
\r
        ADD      EBX, EBX\r
        ADD      EDI, EBX // EDI = Dst\r
        MOV      EBX, EDX // EBX = BytesPerDstLine\r
        DEC      EBX\r
        DEC      EBX\r
        MOV      EBP, ESI // EBP = SrcBmp\r
\r
        XOR      EDX, EDX // Y = 0\r
\r
@@looY:\r
        PUSH     EDX\r
        PUSH     EDI\r
\r
        MOV      EAX, EBP\r
        CALL     TBitmap.GetScanLine\r
        XCHG     ESI, EAX\r
        MOV      ECX, [EBP].TBitmap.fWidth\r
\r
@@looX:\r
        MOVSW\r
        ADD      EDI, EBX\r
        LOOP     @@looX\r
\r
        POP      EDI\r
        POP      EDX\r
\r
        DEC      EDI\r
        DEC      EDI\r
        INC      EDX\r
        CMP      EDX, [EBP].TBitmap.fHeight\r
        JL       @@looY\r
\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
var X, Y, Wwords, BytesPerDstLine: Integer;\r
    Src, Dst, Dst1: PWord;\r
    Tmp: Word;\r
begin\r
\r
  DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );\r
\r
  // Calculate ones:\r
  Wwords := SrcBmp.fWidth;\r
  Dst := DstBmp.ScanLine[ 0 ];\r
  BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );\r
\r
  Inc( Dst, DstBmp.fWidth - 1 );\r
\r
  // Rotating bits:\r
  for Y := 0 to SrcBmp.fHeight - 1 do\r
  begin\r
    Src := SrcBmp.ScanLine[ Y ];\r
    Dst1 := Dst;\r
    for X := Wwords downto 1 do\r
    begin\r
      Tmp := Src^;\r
      Inc( Src );\r
      Dst1^ := Tmp;\r
      Inc( PByte(Dst1), BytesPerDstLine );\r
    end;\r
    Dec( Dst );\r
  end;\r
\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _RotateBitmap16bit]\r
\r
//[PROCEDURE _RotateBitmap2432bit]\r
{$IFDEF ASM_VERSION}\r
procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
asm\r
        PUSHAD\r
        XOR      EBX, EBX\r
        CALL     _PrepareBmp2Rotate\r
\r
        SUB      ECX, pf24bit\r
        JNZ      @@10\r
        LEA      EBX, [EBX+EBX*2]\r
        JMP      @@11\r
@@10:\r
        LEA      EBX, [EBX*4]\r
@@11:   ADD      EDI, EBX // EDI = Dst\r
\r
        MOV      EBX, EDX // EBX = BytesPerDstLine\r
        DEC      EBX\r
        DEC      EBX\r
        DEC      EBX\r
\r
        MOV      EBP, ESI // EBP = SrcBmp\r
\r
        XOR      EDX, EDX // Y = 0\r
\r
@@looY:\r
        PUSH     EDX\r
        PUSH     EDI\r
        PUSH     ECX // ECX = 0 if pf24bit (1 if pf32bit)\r
\r
        MOV      EAX, EBP\r
        CALL     TBitmap.GetScanLine\r
        XCHG     ESI, EAX\r
        MOV      ECX, [EBP].TBitmap.fWidth\r
        POP      EAX\r
        PUSH     EAX\r
\r
@@looX:\r
        MOVSW\r
        MOVSB\r
        ADD      ESI, EAX\r
        ADD      EDI, EBX\r
        LOOP     @@looX\r
\r
        POP      ECX\r
        POP      EDI\r
        POP      EDX\r
\r
        DEC      EDI\r
        DEC      EDI\r
        DEC      EDI\r
        SUB      EDI, ECX\r
        INC      EDX\r
        CMP      EDX, [EBP].TBitmap.fHeight\r
        JL       @@looY\r
\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
var X, Y, Wwords, BytesPerDstLine, IncW: Integer;\r
    Src, Dst, Dst1: PDWord;\r
    Tmp: DWord;\r
begin\r
\r
  DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );\r
\r
  // Calculate ones:\r
  IncW := 4;\r
  if DstBmp.PixelFormat = pf24bit then\r
     IncW := 3;\r
  Wwords := SrcBmp.fWidth;\r
  Dst := DstBmp.ScanLine[ 0 ];\r
  BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );\r
\r
  Inc( PByte(Dst), (DstBmp.fWidth - 1) * IncW );\r
\r
  // Rotating bits:\r
  for Y := 0 to SrcBmp.fHeight - 1 do\r
  begin\r
    Src := SrcBmp.ScanLine[ Y ];\r
    Dst1 := Dst;\r
    for X := Wwords downto 1 do\r
    begin\r
      Tmp := Src^ and $FFFFFF;\r
      Inc( PByte(Src), IncW );\r
      Dst1^ := Dst1^ or Tmp;\r
      Inc( PByte(Dst1), BytesPerDstLine );\r
    end;\r
    Dec( PByte(Dst), IncW );\r
  end;\r
\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _RotateBitmap2432bit]\r
\r
type\r
  TRotateBmpRefs = packed record\r
    proc_RotateBitmapMono: procedure( var Dst: PBitmap; Src: PBitmap );\r
    proc_RotateBitmap4bit: procedure( var Dst: PBitmap; Src: PBitmap );\r
    proc_RotateBitmap8bit: procedure( var Dst: PBitmap; Src: PBitmap );\r
    proc_RotateBitmap16bit: procedure( var Dst: PBitmap; Src: PBitmap );\r
    proc_RotateBitmap2432bit: procedure( var Dst: PBitmap; Src: PBitmap );\r
  end;\r
\r
var\r
  RotateProcs: TRotateBmpRefs;\r
\r
//[PROCEDURE _RotateBitmapRight]\r
{$IFDEF ASM_VERSION}\r
procedure _RotateBitmapRight( SrcBmp: PBitmap );\r
asm\r
        PUSH     EBX\r
        PUSH     EDI\r
        MOV      EBX, EAX\r
        CMP      [EBX].TBitmap.fHandleType, bmDIB\r
        JNZ      @@exit\r
\r
        CALL     TBitmap.GetPixelFormat\r
        MOVZX    ECX, AL\r
        LOOP     @@not1bit\r
        MOV      EAX, [RotateProcs.proc_RotateBitmapMono]\r
@@not1bit:\r
        LOOP     @@not4bit\r
        MOV      EAX, [RotateProcs.proc_RotateBitmap4bit]\r
@@not4bit:\r
        LOOP     @@not8bit\r
        MOV      EAX, [RotateProcs.proc_RotateBitmap8bit]\r
@@not8bit:\r
        LOOP     @@not15bit\r
        INC      ECX\r
@@not15bit:\r
        LOOP     @@not16bit\r
        MOV      EAX, [RotateProcs.proc_RotateBitmap16bit]\r
@@not16bit:\r
        LOOP     @@not24bit\r
        INC      ECX\r
@@not24bit:\r
        LOOP     @@not32bit\r
        MOV      EAX, [RotateProcs.proc_RotateBitmap2432bit]\r
@@not32bit:\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
\r
        PUSH     ECX\r
        XCHG     ECX, EAX\r
        MOV      EAX, ESP\r
        MOV      EDX, EBX\r
        CALL     ECX\r
\r
        POP      EDI\r
        MOV      EAX, [EBX].TBitmap.fWidth\r
        CMP      EAX, [EDI].TBitmap.fHeight\r
        JGE      @@noCutHeight\r
\r
        MOV      EDX, [EDI].TBitmap.fScanLineSize\r
        MUL      EDX\r
        MOV      [EDI].TBitmap.fDIBSize, EAX\r
\r
        MOV      EDX, [EDI].TBitmap.fDIBHeader\r
        MOV      EDX, [EDX].TBitmapInfoHeader.biHeight\r
        TEST     EDX, EDX\r
        JL       @@noCorrectImg\r
\r
        PUSH     EAX\r
\r
        MOV      EDX, [EDI].TBitmap.fHeight\r
        DEC      EDX\r
        MOV      EAX, EDI\r
        CALL     TBitmap.GetScanLine\r
        PUSH     EAX\r
\r
        MOV      EDX, [EBX].TBitmap.fWidth\r
        DEC      EDX\r
        MOV      EAX, EDI\r
        CALL     TBitmap.GetScanLine\r
        POP      EDX\r
\r
        POP      ECX\r
        CALL     System.Move\r
\r
@@noCorrectImg:\r
        MOV      EAX, [EBX].TBitmap.fWidth\r
        MOV      [EDI].TBitmap.fHeight, EAX\r
        MOV      EDX, [EDI].TBitmap.fDIBHeader\r
        MOV      [EDX].TBitmapInfoHeader.biHeight, EAX\r
\r
@@noCutHeight:\r
        MOV      EAX, EBX\r
        CALL     TBitmap.ClearData\r
\r
        XOR      EAX, EAX\r
        XCHG     EAX, [EDI].TBitmap.fDIBHeader\r
        XCHG     [EBX].TBitmap.fDIBHeader, EAX\r
\r
        XCHG     EAX, [EDI].TBitmap.fDIBBits\r
        XCHG     [EBX].TBitmap.fDIBBits, EAX\r
\r
        MOV      AL, [EDI].TBitmap.fDIBAutoFree\r
        MOV      [EBX].TBitmap.fDIBAutoFree, AL\r
\r
        MOV      EAX, [EDI].TBitmap.fDIBSize\r
        MOV      [EBX].TBitmap.fDIBSize, EAX\r
\r
        MOV      EAX, [EDI].TBitmap.fWidth\r
        MOV      [EBX].TBitmap.fWidth, EAX\r
\r
        MOV      EAX, [EDI].TBitmap.fHeight\r
        MOV      [EBX].TBitmap.fHeight, EAX\r
\r
        XCHG     EAX, EDI\r
        CALL     TObj.Free\r
@@exit:\r
        POP      EDI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _RotateBitmapRight( SrcBmp: PBitmap );\r
var DstBmp: PBitmap;\r
    RotateProc: procedure( var DstBmp: PBitmap; SrcBmp: PBitmap );\r
begin\r
  if SrcBmp.fHandleType <> bmDIB then Exit;\r
\r
  case SrcBmp.PixelFormat of\r
  pf1bit: RotateProc := RotateProcs.proc_RotateBitmapMono;\r
  pf4bit: RotateProc := RotateProcs.proc_RotateBitmap4bit;\r
  pf8bit: RotateProc := RotateProcs.proc_RotateBitmap8bit;\r
  pf15bit, pf16bit: RotateProc := RotateProcs.proc_RotateBitmap16bit;\r
  else RotateProc := RotateProcs.proc_RotateBitmap2432bit;\r
  end;\r
\r
  if not Assigned( RotateProc ) then Exit;\r
  RotateProc( DstBmp, SrcBmp );\r
\r
  if DstBmp.fHeight > SrcBmp.fWidth then\r
  begin\r
    DstBmp.fDIBSize := DstBmp.fScanLineSize * SrcBmp.fWidth;\r
    //if DWORD( DstBmp.ScanLine[ 0 ] ) > DWORD( DstBmp.ScanLine[ 1 ] ) then\r
    if DstBmp.fDIBHeader.bmiHeader.biHeight > 0 then\r
      Move( DstBmp.ScanLine[ SrcBmp.fWidth - 1 ]^, DstBmp.ScanLine[ DstBmp.fHeight - 1 ]^,\r
            DstBmp.fDIBSize );\r
    DstBmp.fHeight := SrcBmp.fWidth;\r
    DstBmp.fDIBHeader.bmiHeader.biHeight := DstBmp.fHeight;\r
  end;\r
\r
  SrcBmp.ClearData;\r
\r
  //SrcBmp.fNewPixelFormat := DstBmp.PixelFormat;\r
  SrcBmp.fDIBHeader := DstBmp.fDIBHeader;\r
  DstBmp.fDIBHeader := nil;\r
\r
  SrcBmp.fDIBBits := DstBmp.fDIBBits;\r
  DstBmp.fDIBBits := nil;\r
  SrcBmp.fDIBAutoFree := DstBmp.fDIBAutoFree;\r
\r
  SrcBmp.fDIBSize := DstBmp.fDIBSize;\r
\r
  SrcBmp.fWidth := DstBmp.fWidth;\r
  SrcBmp.fHeight := DstBmp.fHeight;\r
  DstBmp.Free;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _RotateBitmapRight]\r
\r
//[procedure TBitmap.RotateRight]\r
procedure TBitmap.RotateRight;\r
const AllRotators: TRotateBmpRefs = (\r
        proc_RotateBitmapMono: _RotateBitmapMono;\r
        proc_RotateBitmap4bit: _RotateBitmap4bit;\r
        proc_RotateBitmap8bit: _RotateBitmap8bit;\r
        proc_RotateBitmap16bit: _RotateBitmap16bit;\r
        proc_RotateBitmap2432bit: _RotateBitmap2432bit );\r
begin\r
  RotateProcs := AllRotators;\r
  _RotateBitmapRight( @Self );\r
end;\r
\r
//[procedure _RotateBitmapLeft]\r
procedure _RotateBitmapLeft( Src: PBitmap );\r
begin\r
  _RotateBitmapRight( Src );\r
  _RotateBitmapRight( Src );\r
  _RotateBitmapRight( Src );\r
end;\r
\r
//[procedure TBitmap.RotateLeft]\r
procedure TBitmap.RotateLeft;\r
begin\r
  RotateRight;\r
  _RotateBitmapRight( @Self );\r
  _RotateBitmapRight( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateLeftMono]\r
procedure TBitmap.RotateLeftMono;\r
begin\r
  if PixelFormat <> pf1bit then Exit;\r
  RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono;\r
  _RotateBitmapRight( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateRightMono]\r
procedure TBitmap.RotateRightMono;\r
begin\r
  if PixelFormat <> pf1bit then Exit;\r
  RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono;\r
  _RotateBitmapLeft( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateLeft16bit]\r
procedure TBitmap.RotateLeft16bit;\r
begin\r
  if PixelFormat <> pf16bit then Exit;\r
  RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit;\r
  _RotateBitmapLeft( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateLeft4bit]\r
procedure TBitmap.RotateLeft4bit;\r
begin\r
  if PixelFormat <> pf4bit then Exit;\r
  RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit;\r
  _RotateBitmapLeft( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateLeft8bit]\r
procedure TBitmap.RotateLeft8bit;\r
begin\r
  if PixelFormat <> pf8bit then Exit;\r
  RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit;\r
  _RotateBitmapLeft( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateLeftTrueColor]\r
procedure TBitmap.RotateLeftTrueColor;\r
begin\r
  if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit;\r
  RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit;\r
  _RotateBitmapLeft( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateRight16bit]\r
procedure TBitmap.RotateRight16bit;\r
begin\r
  if PixelFormat <> pf16bit then Exit;\r
  RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit;\r
  _RotateBitmapRight( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateRight4bit]\r
procedure TBitmap.RotateRight4bit;\r
begin\r
  if PixelFormat <> pf4bit then Exit;\r
  RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit;\r
  _RotateBitmapRight( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateRight8bit]\r
procedure TBitmap.RotateRight8bit;\r
begin\r
  if PixelFormat <> pf8bit then Exit;\r
  RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit;\r
  _RotateBitmapRight( @Self );\r
end;\r
\r
//[procedure TBitmap.RotateRightTrueColor]\r
procedure TBitmap.RotateRightTrueColor;\r
begin\r
  if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit;\r
  RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit;\r
  _RotateBitmapRight( @Self );\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.GetPixels]\r
function TBitmap.GetPixels(X, Y: Integer): TColor;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        PUSH     ECX\r
        PUSH     EDX\r
        CALL     GetEmpty\r
        PUSHFD\r
        OR       EAX, -1\r
        POPFD\r
        JZ       @@exit\r
\r
        CALL     StartDC\r
        PUSH     dword ptr [ESP+12]\r
        PUSH     dword ptr [ESP+12]\r
        PUSH     EAX\r
        CALL     Windows.GetPixel\r
        XCHG     EBX, EAX\r
        CALL     FinishDC\r
        XCHG     EAX, EBX\r
@@exit:\r
        POP      EDX\r
        POP      EDX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.GetPixels(X, Y: Integer): TColor;\r
var DC: HDC;\r
    Save: THandle;\r
begin\r
  Result := clNone;\r
  //if GetHandle = 0 then Exit;\r
  if Empty then Exit;\r
  fDetachCanvas( @Self );\r
  DC := CreateCompatibleDC( 0 );\r
  Save := SelectObject( DC, GetHandle );\r
  ASSERT( Save <> 0, 'Can not select bitmap to DC' );\r
  Result := Windows.GetPixel( DC, X, Y );\r
  SelectObject( DC, Save );\r
  DeleteDC( DC );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.SetPixels]\r
procedure TBitmap.SetPixels(X, Y: Integer; const Value: TColor);\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        PUSH     ECX\r
        PUSH     EDX\r
        CALL     GetEmpty\r
        JZ       @@exit\r
\r
        CALL     StartDC\r
        MOV      EAX, Value\r
        CALL     Color2RGB\r
        PUSH     EAX\r
        PUSH     dword ptr [ESP+16]\r
        PUSH     dword ptr [ESP+16]\r
        PUSH     dword ptr [ESP+16]\r
        CALL     Windows.SetPixel\r
        CALL     FinishDC\r
@@exit:\r
        POP      EDX\r
        POP      ECX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.SetPixels(X, Y: Integer; const Value: TColor);\r
var DC: HDC;\r
    Save: THandle;\r
begin\r
  //if GetHandle = 0 then Exit;\r
  if Empty then Exit;\r
  fDetachCanvas( @Self );\r
  DC := CreateCompatibleDC( 0 );\r
  Save := SelectObject( DC, GetHandle );\r
  ASSERT( Save <> 0, 'Can not select bitmap to DC' );\r
  Windows.SetPixel( DC, X, Y, Color2RGB( Value ) );\r
  SelectObject( DC, Save );\r
  DeleteDC( DC );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[FUNCTION _GetDIBPixelsPalIdx]\r
{$IFDEF ASM_VERSION}\r
function _GetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer ): TColor;\r
const szBIH = Sizeof(TBitmapInfoHeader);\r
asm\r
        PUSH     EBX\r
        PUSH     EDI\r
        PUSH     EDX\r
        XCHG     EBX, EAX\r
\r
        XCHG     EAX, EDX\r
        MOV      EDI, [EBX].TBitmap.fPixelsPerByteMask\r
        INC      EDI\r
        CDQ\r
        DIV      EDI\r
        DEC      EDI\r
        XCHG     ECX, EAX // EAX = Y, ECX = X div (Bmp.fPixeldPerByteMask+1)\r
\r
        MOV      EDX, [EBX].TBitmap.fScanLineDelta\r
        IMUL     EDX\r
\r
        ADD      EAX, [EBX].TBitmap.fScanLine0\r
        MOVZX    EAX, byte ptr[EAX+ECX]\r
\r
        POP      EDX\r
        MOV      ECX, [EBX].TBitmap.fPixelsPerByteMask\r
        AND      EDX, ECX\r
        SUB      ECX, EDX\r
\r
        PUSH     EAX\r
        MOV      EDI, [EBX].TBitmap.fDIBHeader\r
        MOVZX    EAX, [EDI].TBitmapInfoHeader.biBitCount\r
        MUL      ECX\r
        XCHG     ECX, EAX\r
        POP      EAX\r
        SHR      EAX, CL\r
        AND      EAX, [EBX].TBitmap.fPixelMask\r
\r
        MOV      EAX, [EDI+szBIH+EAX*4]\r
        CALL     Color2RGBQuad\r
\r
        POP      EDI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function _GetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer ): TColor;\r
var Pixel: Byte;\r
begin\r
  Pixel := PByte( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta\r
             + (X div (Bmp.fPixelsPerByteMask + 1)) )^;\r
  Pixel := ( Pixel shr ( (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask))\r
                       * Bmp.fDIBHeader.bmiHeader.biBitCount ) )\r
           and Bmp.fPixelMask;\r
  Result := TColor( Color2RGBQuad( TColor( PRGBQuad( DWORD(@Bmp.fDIBHeader.bmiColors[ 0 ])\r
                           + Pixel * Sizeof( TRGBQuad ) )^ ) ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _GetDIBPixelsPalIdx]\r
\r
//[FUNCTION _GetDIBPixels16bit]\r
{$IFDEF ASM_VERSION}\r
function _GetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer ): TColor;\r
asm\r
        PUSH     [EAX].TBitmap.fPixelMask\r
        PUSH     EDX // X\r
        PUSH     EAX\r
        MOV      EAX, [EAX].TBitmap.fScanLineDelta\r
        IMUL     ECX\r
        POP      EDX\r
        ADD      EAX, [EDX].TBitmap.fScanLine0\r
        POP      ECX\r
        MOVZX    EAX, word ptr [EAX+ECX*2]\r
        POP      EDX\r
        CMP      DL, 15\r
        JNE      @@16bit\r
\r
        MOV      EDX, EAX\r
        SHR      EDX, 7\r
        SHL      EAX, 6\r
        MOV      DH, AH\r
        AND      DH, $F8\r
        SHL      EAX, 13\r
        JMP      @@1516bit\r
\r
@@16bit:\r
        MOV      DL, AH\r
        SHL      EAX, 5\r
        MOV      DH, AH\r
        SHL      EAX, 14\r
@@1516bit:\r
        AND      EAX, $F80000\r
        OR       EAX, EDX\r
        AND      AX, $FCF8\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function _GetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer ): TColor;\r
var Pixel: Word;\r
begin\r
  Pixel := PWord( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X * 2 )^;\r
  if Bmp.fPixelMask = 15 then\r
    Result := (Pixel shr 7) and $F8 or (Pixel shl 6) and $F800\r
           or (Pixel shl 19) and $F80000\r
  else\r
    Result := (Pixel shr 8) and $F8 or (Pixel shl 5) and $FC00\r
           or (Pixel shl 19) and $F80000;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _GetDIBPixels16bit]\r
\r
//[FUNCTION _GetDIBPixelsTrueColor]\r
{$IFDEF ASM_VERSION}\r
function _GetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer ): TColor;\r
asm\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        PUSH     EDX\r
        MOV      EAX, [EBX].TBitmap.fScanLineDelta\r
        IMUL     ECX\r
        XCHG     ECX, EAX\r
        POP      EDX\r
        MOV      EAX, [EBX].TBitmap.fBytesPerPixel\r
        MUL      EDX\r
        ADD      EAX, [EBX].TBitmap.fScanLine0\r
        MOV      EAX, [EAX+ECX]\r
        AND      EAX, $FFFFFF\r
        CALL     Color2RGBQuad\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function _GetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer ): TColor;\r
var Pixel: DWORD;\r
begin\r
  Pixel := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta +\r
                   X * Bmp.fBytesPerPixel )^ and $FFFFFF;\r
  Result := TColor( Color2RGBQuad( TColor( Pixel ) ) );\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _GetDIBPixelsTrueColor]\r
\r
{$IFDEF ASM_VERSION}\r
//[function TBitmap.GetDIBPixels]\r
function TBitmap.GetDIBPixels(X, Y: Integer): TColor;\r
asm\r
        CMP      word ptr [EAX].fGetDIBPixels+2, 0\r
        JNZ      @@assigned\r
\r
        // if not assigned, this preparing will be performed for first call:\r
        CMP      [EAX].fHandleType, bmDDB\r
        JZ       @@GetPixels\r
\r
        PUSHAD\r
        MOV      EBX, EAX\r
        XOR      EDX, EDX\r
        CALL     GetScanLine\r
        MOV      [EBX].fScanLine0, EAX\r
        XOR      EDX, EDX\r
        INC      EDX\r
        MOV      EAX, EBX\r
        CALL     GetScanLine\r
        SUB      EAX, [EBX].fScanLine0\r
        MOV      [EBX].fScanLineDelta, EAX\r
        MOV      EAX, EBX\r
        CALL     GetPixelFormat\r
        MOVZX    ECX, AL\r
        MOV      DX, $0F00\r
        MOV      byte ptr [EBX].fBytesPerPixel, 4\r
        XOR      EAX, EAX\r
        LOOP     @@if4bit\r
        MOV      DX, $0107\r
        JMP      @@1bit4bit8bit\r
@@if4bit:\r
        LOOP     @@if8bit\r
        INC      EDX // MOV      DX, $0F01\r
        JMP      @@1bit4bit8bit\r
@@if8bit:\r
        LOOP     @@if15bit\r
        MOV      DH, $FF //MOV      DX, $FF00\r
@@1bit4bit8bit:\r
        MOV      EAX, offset[_GetDIBPixelsPalIdx]\r
@@if15bit:\r
        LOOP     @@if16bit\r
        //MOV      DH, $0F\r
        DEC      DH\r
        INC      ECX\r
@@if16bit:\r
        LOOP     @@if24bit\r
        INC      DH\r
        MOV      EAX, offset[_GetDIBPixels16bit]\r
@@if24bit:\r
        LOOP     @@if32bit\r
        DEC      [EBX].fBytesPerPixel\r
        INC      ECX\r
        DEC      EDX\r
@@if32bit:\r
        LOOP     @@iffin\r
        INC      EDX\r
        MOV      EAX, offset[_GetDIBPixelsTrueColor]\r
@@iffin:\r
        MOV      byte ptr [EBX].fPixelMask, DH\r
        MOV      byte ptr [EBX].fPixelsPerByteMask, DL\r
        MOV      [EBX].fGetDIBPixels, EAX\r
        TEST     EAX, EAX\r
        POPAD\r
@@GetPixels:\r
        JZ       GetPixels\r
\r
@@assigned:\r
        JMP      [EAX].fGetDIBPixels\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBitmap.GetDIBPixels(X, Y: Integer): TColor;\r
begin\r
  if not Assigned( fGetDIBPixels ) then\r
  begin\r
    if fHandleType = bmDIB then\r
    begin\r
      fScanLine0 := ScanLine[ 0 ];\r
      fScanLineDelta := Integer(ScanLine[ 1 ]) - Integer(fScanLine0);\r
      case PixelFormat of\r
      pf1bit:\r
        begin\r
          fPixelMask := $01;\r
          fPixelsPerByteMask := 7;\r
          fGetDIBPixels := _GetDIBPixelsPalIdx;\r
        end;\r
      pf4bit:\r
        begin\r
          fPixelMask := $0F;\r
          fPixelsPerByteMask := 1;\r
          fGetDIBPixels := _GetDIBPixelsPalIdx;\r
        end;\r
      pf8bit:\r
        begin\r
          fPixelMask := $FF;\r
          fPixelsPerByteMask := 0;\r
          fGetDIBPixels := _GetDIBPixelsPalIdx;\r
        end;\r
      pf15bit:\r
        begin\r
          fPixelMask := 15;\r
          fGetDIBPixels := _GetDIBPixels16bit;\r
        end;\r
      pf16bit:\r
        begin\r
          fPixelMask := 16;\r
          fGetDIBPixels := _GetDIBPixels16bit;\r
        end;\r
      pf24bit:\r
        begin\r
          fPixelsPerByteMask := 0;\r
          fBytesPerPixel := 3;\r
          fGetDIBPixels := _GetDIBPixelsTrueColor;\r
        end;\r
      pf32bit:\r
        begin\r
          fPixelsPerByteMask := 1;\r
          fBytesPerPixel := 4;\r
          fGetDIBPixels := _GetDIBPixelsTrueColor;\r
        end;\r
      else;\r
      end;\r
    end;\r
    if not Assigned( fGetDIBPixels ) then\r
    begin\r
      Result := Pixels[ X, Y ];\r
      Exit;\r
    end;\r
  end;\r
  Result := fGetDIBPixels( @Self, X, Y );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[PROCEDURE _SetDIBPixels1bit]\r
{$IFDEF ASM_VERSION}\r
procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );\r
asm\r
        PUSH     EDX\r
        PUSH     [EAX].TBitmap.fScanLine0\r
        PUSH     ECX\r
        PUSH     [EAX].TBitmap.fScanLineDelta\r
        MOV      EAX, Value\r
        CALL     Color2RGB\r
        MOV      EDX, EAX\r
        SHR      EAX, 16\r
        ADD      AL, DL\r
        ADC      AL, DH\r
        CMP      EAX, 170\r
        SETGE    CL\r
        AND      ECX, 1\r
        SHL      ECX, 7\r
        POP      EAX\r
        POP      EDX\r
        IMUL     EDX\r
        POP      EDX\r
        ADD      EAX, EDX\r
        POP      EDX\r
        PUSH     ECX\r
        MOV      ECX, EDX\r
        SHR      EDX, 3\r
        ADD      EAX, EDX\r
        AND      ECX, 7\r
        MOV      DX, $FF7F\r
        SHR      EDX, CL\r
        AND      byte ptr [EAX], DL\r
        POP      EDX\r
        SHR      EDX, CL\r
        OR       byte ptr [EAX], DL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );\r
var Pixel: Byte;\r
    Pos: PByte;\r
    Shf: Integer;\r
begin\r
  Value := Color2RGB( Value );\r
  if ((Value shr 16) and $FF) + ((Value shr 8) and $FF) + (Value and $FF)\r
     < 255 * 3 div 2 then Pixel := 0 else Pixel := $80;\r
  Pos := PByte( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X div 8 );\r
  Shf := X and 7;\r
  Pos^ := Pos^ and ($FF7F shr Shf) or (Pixel shr Shf);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _SetDIBPixels1bit]\r
\r
//[PROCEDURE _SetDIBPixelsPalIdx]\r
{$IFDEF ASM_VERSION}\r
procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor );\r
asm\r
        XCHG     EAX, EBP\r
        PUSH     EDX // -> X\r
        PUSH     ECX // -> Y\r
        MOV      ECX, [EBP].TBitmap.fPixelsPerByteMask\r
        INC      ECX\r
        XCHG     EAX, EDX\r
        CDQ\r
        DIV      ECX\r
        XCHG     ECX, EAX // ECX = X div (fPixelsPerByteMask+1)\r
        POP      EAX // <- Y\r
        MOV      EDX, [EBP].TBitmap.fScanLineDelta\r
        IMUL     EDX\r
        ADD      ECX, EAX\r
        ADD      ECX, [EBP].TBitmap.fScanLine0 // ECX = Pos\r
        PUSH     ECX // -> Pos\r
\r
        MOV      EDX, [ESP+16] // Value\r
        MOV      EAX, EBP\r
        CALL     TBitmap.DIBPalNearestEntry // EAX = Pixel\r
\r
        POP      ECX // <- Pos\r
        POP      EDX // <- X\r
\r
        PUSH     EAX // -> Pixel\r
\r
        MOV      EAX, [EBP].TBitmap.fPixelsPerByteMask\r
        AND      EDX, EAX\r
        SUB      EAX, EDX\r
        MOV      EDX, [EBP].TBitmap.fDIBHeader\r
        MOVZX    EDX, [EDX].TBitmapInfoHeader.biBitCount\r
        MUL      EDX // EAX = Shf\r
\r
        XCHG     ECX, EAX // ECX = Shf, EAX = Pos\r
        MOV      EDX, [EBP].TBitmap.fPixelMask\r
        SHL      EDX, CL\r
        NOT      EDX\r
        AND      byte ptr [EAX], DL\r
\r
        POP      EDX // <- Pixel\r
        SHL      EDX, CL\r
        OR       byte ptr [EAX], DL\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor );\r
var Pixel: Byte;\r
    Pos: PByte;\r
    Shf: Integer;\r
begin\r
  Pixel := Bmp.DIBPalNearestEntry( Value );\r
  Pos := PByte( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta\r
                + X div (Bmp.fPixelsPerByteMask + 1) );\r
  Shf := (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask))\r
         * Bmp.fDIBHeader.bmiHeader.biBitCount;\r
  Pos^ := Pos^ and not (Bmp.fPixelMask shl Shf) or (Pixel shl Shf);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _SetDIBPixelsPalIdx]\r
\r
//[PROCEDURE _SetDIBPixels16bit]\r
{$IFDEF ASM_VERSION}\r
procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );\r
asm\r
        ADD      EDX, EDX\r
        ADD      EDX, [EAX].TBitmap.fScanLine0\r
        PUSH     EDX // -> X*2 + Bmp.fScanLine0\r
        PUSH     [EAX].TBitmap.fPixelMask\r
        MOV      EAX, [EAX].TBitmap.fScanLineDelta\r
        IMUL     ECX\r
        PUSH     EAX  // -> Y* Bmp.fScanLineDelta\r
        MOV      EAX, Value\r
        CALL     Color2RGB\r
        POP      EBP  // <- Y* Bmp.fScanLineDelta\r
        POP      EDX\r
        XOR      ECX, ECX\r
        SUB      DL, 16\r
        JZ       @@16bit\r
\r
        MOV      CH, AL\r
        SHR      CH, 1\r
        SHR      EAX, 6\r
        MOV      EDX, EAX\r
        AND      DX, $3E0\r
        SHR      EAX, 13\r
        JMP      @@1516\r
\r
@@16bit:\r
        {$IFDEF PARANOIA}\r
        DB $24, $F8\r
        {$ELSE}\r
        AND      AL, $F8\r
        {$ENDIF}\r
        MOV      CH, AL\r
        SHR      EAX, 5\r
        MOV      EDX, EAX\r
        AND      DX, $7E0\r
        SHR      EAX, 14\r
\r
@@1516:\r
        MOV      AH, CH\r
        AND      AX, $FC1F\r
        OR       AX, DX\r
\r
        POP      EDX\r
        MOV      [EBP+EDX], AX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );\r
var RGB16: Word;\r
    Pos: PWord;\r
begin\r
  Value := Color2RGB( Value );\r
  if Bmp.fPixelMask = 15 then\r
    RGB16 := (Value shr 19) and $001F or (Value shr 6) and $03E0\r
          or (Value shl 7) and $7C00\r
  else\r
    RGB16 := (Value shr 19) and $001F or (Value shr 5) and $07E0\r
          or (Value shl 8) and $F800;\r
  Pos := PWord( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X * 2 );\r
  Pos^ := RGB16;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _SetDIBPixels16bit]\r
\r
//[PROCEDURE _SetDIBPixelsTrueColor]\r
{$IFDEF ASM_VERSION}\r
procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor );\r
asm\r
        PUSH     [EAX].TBitmap.fScanLineDelta\r
        PUSH     [EAX].TBitmap.fScanLine0\r
        MOV      EAX, [EAX].TBitmap.fBytesPerPixel\r
        MUL      EDX\r
        POP      EDX\r
        ADD      EDX, EAX\r
        POP      EAX\r
        PUSH     EDX\r
        IMUL     ECX\r
        POP      EDX\r
        ADD      EDX, EAX\r
        PUSH     EDX\r
        MOV      EAX, Value\r
        CALL     Color2RGBQuad\r
        POP      EDX\r
        AND      dword ptr [EDX], $FF000000\r
        OR       [EDX], EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor );\r
var RGB: TRGBQuad;\r
    Pos: PDWord;\r
begin\r
  //Value := Color2RGB( Value );\r
  RGB := Color2RGBQuad( Value );\r
  Pos := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta\r
                 + X * Bmp.fBytesPerPixel );\r
  Pos^ := Pos^ and $FF000000 or DWORD(RGB);\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END _SetDIBPixelsTrueColor]\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.SetDIBPixels]\r
procedure TBitmap.SetDIBPixels(X, Y: Integer; const Value: TColor);\r
asm\r
        CMP      word ptr [EAX].fSetDIBPixels+2, 0\r
        JNZ      @@assigned\r
        PUSHAD\r
        MOV      EBX, EAX\r
        XOR      EDX, EDX\r
        CMP      [EBX].fHandleType, DL // bmDIB = 0\r
        JNE      @@ddb\r
        CALL     GetScanLine\r
        MOV      [EBX].fScanLine0, EAX\r
        XOR      EDX, EDX\r
        INC      EDX\r
        MOV      EAX, EBX\r
        CALL     GetScanLine\r
        SUB      EAX, [EBX].fScanLine0\r
        MOV      [EBX].fScanLineDelta, EAX\r
        MOV      EAX, EBX\r
        CALL     GetPixelFormat\r
        MOVZX    ECX, AL\r
        MOV      DX, $0F01\r
        MOV      EAX, offset[_SetDIBPixelsPalIdx]\r
        MOV      byte ptr [EBX].fBytesPerPixel, 4\r
        LOOP     @@if4bit\r
        MOV      EAX, offset[_SetDIBPixels1bit]\r
@@if4bit:\r
        LOOP     @@if8bit\r
@@if8bit:\r
        LOOP     @@if15bit\r
        DEC      DL\r
        MOV      DH, $FF\r
@@if15bit:\r
        LOOP     @@if16bit\r
        DEC      DH\r
        INC      ECX\r
@@if16bit:\r
        LOOP     @@if24bit\r
        INC      DH\r
        MOV      EAX, offset[_SetDIBPixels16bit]\r
@@if24bit:\r
        LOOP     @@if32bit\r
        DEC      EDX\r
        DEC      [EBX].fBytesPerPixel\r
        INC      ECX\r
@@if32bit:\r
        LOOP     @@ifend\r
        INC      EDX\r
        MOV      EAX, offset[_SetDIBPixelsTrueColor]\r
@@ifend:\r
        MOV      byte ptr [EBX].fPixelMask, DH\r
        MOV      byte ptr [EBX].fPixelsPerByteMask, DL\r
        MOV      [EBX].fSetDIBPixels, EAX\r
        TEST     EAX, EAX\r
@@ddb:\r
        POPAD\r
        JNZ      @@assigned\r
        PUSH     Value\r
        CALL     SetPixels\r
        JMP      @@exit\r
@@assigned:\r
        PUSH     Value\r
        CALL     [EAX].fSetDIBPixels\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.SetDIBPixels(X, Y: Integer; const Value: TColor);\r
begin\r
  if not Assigned( fSetDIBPixels ) then\r
  begin\r
    if fHandleType = bmDIB then\r
    begin\r
      fScanLine0 := ScanLine[ 0 ];\r
      fScanLineDelta := Integer(ScanLine[ 1 ]) - Integer(fScanLine0);\r
      case PixelFormat of\r
      pf1bit:\r
        begin\r
          //fPixelMask := $01;\r
          //fPixelsPerByteMask := 7;\r
          fSetDIBPixels := _SetDIBPixels1bit;\r
        end;\r
      pf4bit:\r
        begin\r
          fPixelMask := $0F;\r
          fPixelsPerByteMask := 1;\r
          fSetDIBPixels := _SetDIBPixelsPalIdx;\r
        end;\r
      pf8bit:\r
        begin\r
          fPixelMask := $FF;\r
          fPixelsPerByteMask := 0;\r
          fSetDIBPixels := _SetDIBPixelsPalIdx;\r
        end;\r
      pf15bit:\r
        begin\r
          fPixelMask := 15;\r
          fSetDIBPixels := _SetDIBPixels16bit;\r
        end;\r
      pf16bit:\r
        begin\r
          fPixelMask := 16;\r
          fSetDIBPixels := _SetDIBPixels16bit;\r
        end;\r
      pf24bit:\r
        begin\r
          fPixelsPerByteMask := 0;\r
          fBytesPerPixel := 3;\r
          fSetDIBPixels := _SetDIBPixelsTrueColor;\r
        end;\r
      pf32bit:\r
        begin\r
          fPixelsPerByteMask := 1;\r
          fBytesPerPixel := 4;\r
          fSetDIBPixels := _SetDIBPixelsTrueColor;\r
        end;\r
      else;\r
      end;\r
    end;\r
    if not Assigned( fSetDIBPixels ) then\r
    begin\r
      Pixels[ X, Y ] := Value;\r
      Exit;\r
    end;\r
  end;\r
  fSetDIBPixels( @Self, X, Y, Value );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.FlipVertical]\r
procedure TBitmap.FlipVertical;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        MOV      ECX, [EBX].fHandle\r
        JECXZ    @@noHandle\r
\r
        CALL     StartDC\r
        PUSH     SrcCopy\r
        MOV      EDX, [EBX].fHeight\r
        PUSH     EDX\r
        MOV      ECX, [EBX].fWidth\r
        PUSH     ECX\r
        PUSH     0\r
        PUSH     0\r
        PUSH     EAX\r
        NEG      EDX\r
        PUSH     EDX\r
        PUSH     ECX\r
        NEG      EDX\r
        DEC      EDX\r
        PUSH     EDX\r
        PUSH     0\r
        PUSH     EAX\r
        CALL     StretchBlt\r
        CALL     FinishDC\r
        POP      EBX\r
        RET\r
\r
@@noHandle:\r
        MOV      ECX, [EBX].fDIBBits\r
        JECXZ    @@exit\r
\r
        PUSHAD   //----------------------------------------\\r
        XOR      EBP, EBP // Y = 0\r
        //+++++++++++++++++++++++++++ provide fScanLineSize\r
        MOV      EAX, EBX\r
        MOV      EDX, EBP\r
        CALL     GetScanLine //\r
        SUB      ESP, [EBX].fScanLineSize\r
\r
@@loo:  LEA      EAX, [EBP*2]\r
        CMP      EAX, [EBX].fHeight\r
        JG       @@finloo\r
\r
        MOV      EAX, EBX\r
        MOV      EDX, EBP\r
        CALL     GetScanLine\r
        MOV      ESI, EAX // ESI = ScanLine[ Y ]\r
        MOV      EDX, ESP\r
        MOV      ECX, [EBX].fScanLineSize\r
        PUSH     ECX\r
        CALL     System.Move\r
\r
        MOV      EAX, EBX\r
        MOV      EDX, [EBX].fHeight\r
        SUB      EDX, EBP\r
        DEC      EDX\r
        CALL     GetScanLine\r
        MOV      EDI, EAX\r
        MOV      EDX, ESI\r
        POP      ECX\r
        PUSH     ECX\r
        CALL     System.Move\r
\r
        POP      ECX\r
        MOV      EAX, ESP\r
        MOV      EDX, EDI\r
        CALL     System.Move\r
\r
        INC      EBP\r
        JMP      @@loo\r
\r
@@finloo:\r
        ADD      ESP, [EBX].fScanLineSize\r
        POPAD\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.FlipVertical;\r
var DC: HDC;\r
    Save: THandle;\r
    TmpScan: PByte;\r
    Y: Integer;\r
begin\r
  if fHandle <> 0 then\r
  begin\r
    fDetachCanvas( @Self );\r
    DC := CreateCompatibleDC( 0 );\r
    Save := SelectObject( DC, fHandle );\r
    StretchBlt( DC, 0, fHeight - 1, fWidth, -fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );\r
    SelectObject( DC, Save );\r
    DeleteDC( DC );\r
  end\r
     else\r
  if fDIBBits <> nil then\r
  begin\r
    GetMem( TmpScan, ScanLineSize );\r
    for Y := 0 to fHeight div 2 do\r
    begin\r
      Move( ScanLine[ Y ]^, TmpScan^, fScanLineSize );\r
      Move( ScanLine[ fHeight - Y - 1 ]^, ScanLine[ Y ]^, fScanLineSize );\r
      Move( TmpScan^, ScanLine[ fHeight - Y - 1 ]^, fScanLineSize );\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.FlipHorizontal]\r
procedure TBitmap.FlipHorizontal;\r
asm\r
        PUSH     EBX\r
        MOV      EBX, EAX\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
\r
        CALL     StartDC\r
        PUSH     SrcCopy\r
        MOV      EDX, [EBX].fHeight\r
        PUSH     EDX\r
        MOV      ECX, [EBX].fWidth\r
        PUSH     ECX\r
        PUSH     0\r
        PUSH     0\r
        PUSH     EAX\r
        PUSH     EDX\r
        NEG      ECX\r
        PUSH     ECX\r
        PUSH     0\r
        NEG      ECX\r
        DEC      ECX\r
        PUSH     ECX\r
        PUSH     EAX\r
        CALL     StretchBlt\r
        CALL     FinishDC\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.FlipHorizontal;\r
var DC: HDC;\r
    Save: THandle;\r
begin\r
  if GetHandle <> 0 then\r
  begin\r
    fDetachCanvas( @Self );\r
    DC := CreateCompatibleDC( 0 );\r
    Save := SelectObject( DC, fHandle );\r
    StretchBlt( DC, fWidth - 1, 0, -fWidth, fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );\r
    SelectObject( DC, Save );\r
    DeleteDC( DC );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TBitmap.CopyRect]\r
procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap;\r
  const SrcRect: TRect);\r
asm\r
        PUSHAD\r
        MOV      EBX, EAX\r
        MOV      ESI, ECX\r
        MOV      EDI, EDX\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        MOV      EAX, ESI\r
        CALL     GetHandle\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
        CALL     StartDC\r
        XCHG     EBX, ESI\r
        CMP      EBX, ESI\r
        JNZ      @@diff1\r
        PUSH     EAX\r
        PUSH     0\r
        JMP      @@nodiff1\r
@@diff1:\r
        CALL     StartDC\r
@@nodiff1:\r
        PUSH     SrcCopy                  // ->\r
        MOV      EBP, [SrcRect]\r
        MOV      EAX, [EBP].TRect.Bottom\r
        MOV      EDX, [EBP].TRect.Top\r
        SUB      EAX, EDX\r
        PUSH     EAX                      // ->\r
        MOV      EAX, [EBP].TRect.Right\r
        MOV      ECX, [EBP].TRect.Left\r
        SUB      EAX, ECX\r
        PUSH     EAX                      // ->\r
        PUSH     EDX                      // ->\r
        PUSH     ECX                      // ->\r
        PUSH     dword ptr [ESP+24]       // -> DCsrc\r
        MOV      EAX, [EDI].TRect.Bottom\r
        MOV      EDX, [EDI].TRect.Top\r
        SUB      EAX, EDX\r
        PUSH     EAX                      // ->\r
        MOV      EAX, [EDI].TRect.Right\r
        MOV      ECX, [EDI].TRect.Left\r
        SUB      EAX, ECX\r
        PUSH     EAX                      // ->\r
        PUSH     EDX                      // ->\r
        PUSH     ECX                      // ->\r
        PUSH     dword ptr [ESP+13*4]     // -> DCdst\r
        CALL     StretchBlt\r
        CMP      EBX, ESI\r
        JNE      @@diff2\r
        POP      ECX\r
        POP      ECX\r
        JMP      @@nodiff2\r
@@diff2:\r
        CALL     FinishDC\r
@@nodiff2:\r
        CALL     FinishDC\r
@@exit:\r
        POPAD\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap;\r
  const SrcRect: TRect);\r
var DCsrc, DCdst: HDC;\r
    SaveSrc, SaveDst: THandle;\r
begin\r
  if (GetHandle = 0) or (SrcBmp.GetHandle = 0) then Exit;\r
  fDetachCanvas( @Self );\r
  fDetachCanvas( SrcBmp );\r
  DCsrc := CreateCompatibleDC( 0 );\r
  SaveSrc := SelectObject( DCsrc, SrcBmp.fHandle );\r
  DCdst := DCsrc;\r
  SaveDst := 0;\r
  if SrcBmp <> @Self then\r
  begin\r
    DCdst := CreateCompatibleDC( 0 );\r
    SaveDst := SelectObject( DCdst, fHandle );\r
  end;\r
  StretchBlt( DCdst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,\r
              DstRect.Bottom - DstRect.Top, DCsrc, SrcRect.Left, SrcRect.Top,\r
              SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,\r
              SRCCOPY );\r
  if SrcBmp <> @Self then\r
  begin\r
    SelectObject( DCdst, SaveDst );\r
    DeleteDC( DCdst );\r
  end;\r
  SelectObject( DCsrc, SaveSrc );\r
  DeleteDC( DCsrc );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
\r
//[function TBitmap.CopyToClipboard]\r
function TBitmap.CopyToClipboard: Boolean;\r
var DibMem: PChar;\r
    HdrSize: Integer;\r
    Gbl: HGlobal;\r
begin\r
  Result := FALSE;\r
  if Applet = nil then Exit;\r
  if not OpenClipboard( Applet.GetWindowHandle ) then\r
    Exit;\r
  if EmptyClipboard then\r
  begin\r
    HandleType := bmDIB;\r
    HdrSize := sizeof( TBitmapInfoHeader );\r
    if fDIBHeader.bmiHeader.biBitCount <= 8 then\r
       Inc( HdrSize,\r
       (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad ) );\r
    Gbl := GlobalAlloc( GMEM_MOVEABLE, HdrSize + fDIBSize );\r
    DibMem := GlobalLock( Gbl );\r
    if DibMem <> nil then\r
    begin\r
      Move( fDIBHeader^, DibMem^, HdrSize );\r
      Move( fDIBBits^, Pointer( Integer( DibMem ) + HdrSize )^, fDIBSize );\r
      if not GlobalUnlock( Gbl ) and (GetLastError = NO_ERROR) then\r
      begin\r
        Result := SetClipboardData( CF_DIB, Gbl ) <> 0;\r
      end;\r
    end;\r
  end;\r
  CloseClipboard;\r
end;\r
\r
//[function TBitmap.PasteFromClipboard]\r
function TBitmap.PasteFromClipboard: Boolean;\r
var Gbl: HGlobal;\r
    //DIBPtr: PChar;\r
    Size {, HdrSize}: Integer;\r
    Mem: PChar;\r
    Strm: PStream;\r
begin\r
  Result := FALSE;\r
  if Applet = nil then Exit;\r
  if not OpenClipboard( Applet.GetWindowHandle ) then Exit;\r
  TRY\r
  if IsClipboardFormatAvailable( CF_DIB ) then\r
  begin\r
    Gbl := GetClipboardData( CF_DIB );\r
    if Gbl <> 0 then\r
    begin\r
      Size := GlobalSize( Gbl );\r
      Mem := GlobalLock( Gbl );\r
      TRY\r
      if (Size > 0) and (Mem <> nil) then\r
      begin\r
        Strm := NewMemoryStream;\r
        Strm.Write( Mem^, Size );\r
        Strm.Position := 0;\r
        LoadFromStreamEx( Strm );\r
        Strm.Free;\r
        Result := not Empty;\r
      end;\r
      FINALLY\r
      GlobalUnlock( Gbl );\r
      END;\r
    end;\r
  end;\r
  FINALLY\r
  CloseClipboard;\r
  END;\r
end;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
///////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                             I  C  O  N\r
//\r
//\r
///////////////////////////////////////////////////////////////////////\r
\r
{ -- icon -- }\r
\r
//[function NewIcon]\r
function NewIcon: PIcon;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := TIcon.Create;*){--}\r
  Result.FSize := 32;\r
end;\r
\r
{ TIcon }\r
\r
//[PROCEDURE asmIconEmpty]\r
{$IFDEF ASM_VERSION}\r
procedure asmIconEmpty( Icon: PIcon );\r
asm\r
        CMP      [EAX].TIcon.fHandle, 0\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END asmIconEmpty]\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TIcon.Clear]\r
procedure TIcon.Clear;\r
asm     //cmd    //opd\r
        XOR      ECX, ECX\r
        XCHG     ECX, [EAX].fHandle\r
        JECXZ    @@1\r
        CMP      [EAX].fShareIcon, 0\r
        JNZ      @@1\r
        PUSH     EAX\r
        PUSH     ECX\r
        CALL     DestroyIcon\r
        POP      EAX\r
@@1:    MOV      [EAX].fShareIcon, 0\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TIcon.Clear;\r
begin\r
  if fHandle <> 0 then\r
  begin\r
    if not FShareIcon then\r
      //DeleteObject( fHandle );\r
      DestroyIcon( fHandle );\r
    fHandle := 0;\r
  end;\r
  fShareIcon := False;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[function TIcon.Convert2Bitmap]\r
function TIcon.Convert2Bitmap(TranColor: TColor): HBitmap;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        PUSH     ESI\r
        PUSH     EDI\r
        PUSH     EBP\r
        MOV      EBX, EAX\r
        MOV      EBP, EDX\r
        XOR      EDX, EDX\r
        CALL     asmIconEmpty\r
        JZ       @@ret_0\r
        PUSH     0\r
        CALL     GetDC\r
        PUSH     EAX //> DC0\r
        PUSH     EAX\r
        CALL     CreateCompatibleDC\r
        XCHG     EDI, EAX\r
        MOV      EDX, [EBX].fSize\r
\r
        POP      EAX\r
        PUSH     EAX\r
        PUSH     EDX //>Bottom\r
        PUSH     EDX //>Right\r
        PUSH     0   //>Top\r
        PUSH     0   //>Left\r
\r
        PUSH     EDX\r
        PUSH     EDX\r
        PUSH     EAX\r
        CALL     CreateCompatibleBitmap\r
        XCHG     EBP, EAX\r
\r
        CALL     Color2RGB\r
        PUSH     EAX\r
\r
        PUSH     EBP\r
        PUSH     EDI\r
        CALL     SelectObject\r
        XCHG     ESI, EAX\r
\r
        CALL     CreateSolidBrush\r
\r
        MOV      EDX, ESP\r
        PUSH     EAX\r
        PUSH     EAX\r
        PUSH     EDX\r
        PUSH     EDI\r
        CALL     Windows.FillRect\r
        CALL     DeleteObject\r
\r
        XCHG     EAX, EBX\r
        MOV      EDX, EDI\r
        XOR      ECX, ECX\r
        PUSH     ECX\r
        CALL     Draw\r
\r
        PUSH     EDI\r
        PUSH     ESI\r
        CALL     FinishDC\r
\r
        ADD      ESP, 16\r
        PUSH     0\r
        CALL     ReleaseDC\r
        MOV      EDX, EBP\r
\r
@@ret_0:\r
        XCHG     EAX, EDX\r
        POP      EBP\r
        POP      EDI\r
        POP      ESI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TIcon.Convert2Bitmap(TranColor: TColor): HBitmap;\r
var DC0, DC2: HDC;\r
    Save: THandle;\r
    Br: HBrush;\r
begin\r
  Result := 0;\r
  if Empty then Exit;\r
  DC0 := GetDC( 0 );\r
  DC2 := CreateCompatibleDC( DC0 );\r
  Result := CreateCompatibleBitmap( DC0, fSize, fSize );\r
  Save := SelectObject( DC2, Result );\r
  Br := CreateSolidBrush( Color2RGB( TranColor ) );\r
  FillRect( DC2, MakeRect( 0, 0, fSize, fSize ), Br );\r
  DeleteObject( Br );\r
  Draw( DC2, 0, 0 );\r
  SelectObject( DC2, Save );\r
  DeleteDC( DC2 );\r
  ReleaseDC( 0, DC0 );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[destructor TIcon.Destroy]\r
destructor TIcon.Destroy;\r
asm     //cmd    //opd\r
        PUSH     EAX\r
        CALL     Clear\r
        POP      EAX\r
        CALL     TObj.Destroy\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
destructor TIcon.Destroy;\r
begin\r
  Clear;\r
  inherited;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TIcon.Draw]\r
procedure TIcon.Draw(DC: HDC; X, Y: Integer);\r
asm     //cmd    //opd\r
        CALL     asmIconEmpty\r
        JZ       @@exit\r
        PUSH     DI_NORMAL\r
        PUSH     0\r
        PUSH     0\r
        PUSH     [EAX].fSize\r
        PUSH     [EAX].fSize\r
        PUSH     [EAX].fHandle\r
        PUSH     Y\r
        PUSH     ECX\r
        PUSH     EDX\r
        CALL     DrawIconEx\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TIcon.Draw(DC: HDC; X, Y: Integer);\r
begin\r
  if Empty then Exit;\r
  DrawIconEx( DC, X, Y, fHandle, fSize, fSize, 0, 0, DI_NORMAL );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TIcon.StretchDraw]\r
procedure TIcon.StretchDraw(DC: HDC; Dest: TRect);\r
asm     //cmd    //opd\r
        CALL     asmIconEmpty\r
        JZ       @@exit\r
        PUSH     DI_NORMAL\r
        PUSH     0\r
        PUSH     0\r
        PUSH     ECX\r
        PUSH     ECX\r
        PUSH     [EAX].fHandle\r
        PUSH     [ECX].TRect.Top\r
        PUSH     [ECX].TRect.Left\r
        PUSH     EDX\r
        MOV      EAX, [ECX].TRect.Bottom\r
        SUB      EAX, [ECX].TRect.Top\r
        MOV      [ESP+20], EAX\r
        MOV      EAX, [ECX].TRect.Right\r
        SUB      EAX, [ECX].TRect.Left\r
        MOV      [ESP+16], EAX\r
        CALL     DrawIconEx\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TIcon.StretchDraw(DC: HDC; Dest: TRect);\r
begin\r
  if Empty then Exit;\r
  DrawIconEx( DC, Dest.Left, Dest.Top, FHandle, Dest.Right - Dest.Left,\r
              Dest.Bottom - Dest.Top, 0, 0, DI_NORMAL );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TIcon.GetEmpty]\r
function TIcon.GetEmpty: Boolean;\r
begin\r
  Result := fHandle = 0;\r
end;\r
\r
//*\r
//[function TIcon.GetHotSpot]\r
function TIcon.GetHotSpot: TPoint;\r
var II : TIconInfo;\r
begin\r
  Result := MakePoint( 0, 0 );\r
  if FHandle = 0 then Exit;\r
  GetIconInfo( FHandle, II );\r
  Result.x := II.xHotspot;\r
  Result.y := II.yHotspot;\r
  if II.hbmMask <> 0 then\r
    DeleteObject( II.hbmMask );\r
  if II.hbmColor <> 0 then\r
    DeleteObject( II.hbmColor );\r
end;\r
\r
//*\r
//[procedure TIcon.LoadFromFile]\r
procedure TIcon.LoadFromFile(const FileName: String);\r
var Strm : PStream;\r
begin\r
  Strm := NewReadFileStream( Filename );\r
  LoadFromStream( Strm );\r
  Strm.Free;\r
end;\r
\r
//*\r
//[procedure TIcon.LoadFromStream]\r
procedure TIcon.LoadFromStream(Strm: PStream);\r
var DesiredSize : Integer;\r
    Pos : DWord;\r
    Mem : PStream;\r
    ImgBmp, MskBmp : PBitmap;\r
    TmpBmp: PBitmap;\r
  function ReadIcon : Boolean;\r
  var IH : TIconHeader;\r
      IDI, FoundIDI : TIconDirEntry;\r
      I, SumSz, FoundSz, D : Integer;\r
      II : TIconInfo;\r
      BIH : TBitmapInfoheader;\r
  begin\r
     Result := False;\r
     if Strm.Read( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit;\r
     if (IH.idReserved <> 0) or ((IH.idType <> 1) and (IH.idType <> 2)) or\r
        (IH.idCount < 1) then Exit;\r
     SumSz := Sizeof( IH );\r
     FoundSz := 1000;\r
     for I := 1 to IH.idCount do\r
     begin\r
        if Strm.Read( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit;\r
        if (IDI.bWidth <> IDI.bHeight) and\r
           (IDI.bWidth * 2 <> IDI.bHeight) or\r
           (IDI.bWidth = 0) {or\r
           (IDI.bReserved <> 0) or (IDI.wPlanes <> 0) or (IDI.wBitCount <> 0)} then\r
           Exit;\r
        Inc( SumSz, IDI.dwBytesInRes + Sizeof( IDI ) );\r
        D := IDI.bWidth - DesiredSize;\r
        if D < 0 then D := -D;\r
        if D < FoundSz then\r
        begin\r
           FoundSz := D;\r
           FoundIDI := IDI;\r
        end;\r
     end;\r
     if FoundSz = 1000 then Exit;\r
     Strm.Seek( Integer( Pos ) + FoundIDI.dwImageOffset, spBegin );\r
     fSize := FoundIDI.bWidth;\r
\r
     if Strm.Read( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit;\r
     if (BIH.biWidth <> fSize) or\r
        (BIH.biHeight <> fSize * 2) and\r
        (BIH.biHeight <> fSize) then Exit;\r
     BIH.biHeight := fSize;\r
\r
     Mem := NewMemoryStream;\r
     Mem.Write( BIH, Sizeof( BIH ) );\r
     if (FoundIDI.bColorCount >= 2) or (FoundIDI.bReserved = 1) or\r
        (FoundIDI.bColorCount = 0) then\r
     begin\r
       I := 0;\r
       if BIH.biBitCount <= 8 then\r
          I := (1 shl BIH.biBitCount) * Sizeof( TRGBQuad );\r
       if I > 0 then\r
          if Stream2Stream( Mem, Strm, I ) <> DWORD(I) then Exit;\r
       I := ((BIH.biBitCount * fSize + 31) div 32) * 4 * fSize;\r
       if Stream2Stream( Mem, Strm, I ) <> DWORD(I) then Exit;\r
       ImgBmp := NewBitmap( fSize, fSize );\r
       Mem.Seek( 0, spBegin );\r
       ImgBmp.LoadFromStream( Mem );\r
       if ImgBmp.Empty then Exit;\r
     end;\r
\r
     BIH.biBitCount := 1;\r
     Mem.Seek( 0, spBegin );\r
     Mem.Write( BIH, Sizeof( BIH ) );\r
     I := 0;\r
     Mem.Write( I, Sizeof( I ) );\r
     I := $FFFFFF;\r
     Mem.Write( I, Sizeof( I ) );\r
     I := ((fSize + 31) div 32) * 4 * fSize;\r
     if Stream2Stream( Mem, Strm, I ) <> DWORD(I) then Exit;\r
\r
     MskBmp := NewBitmap( fSize, fSize );\r
     Mem.Seek( 0, spBegin );\r
     MskBmp.LoadFromStream( Mem );\r
     if MskBmp.Empty then Exit;\r
\r
     II.fIcon := True;\r
     II.xHotspot := 0;\r
     II.yHotspot := 0;\r
     II.hbmMask := MskBmp.Handle;\r
     II.hbmColor := 0;\r
     if ImgBmp <> nil then\r
     begin\r
        II.hbmColor := ImgBmp.Handle;\r
        {TmpBmp := NewBitmap( ImgBmp.Width, ImgBmp.Height );\r
        TmpBmp.HandleType := bmDIB;\r
        ImgBmp.Draw( TmpBmp.Canvas.Handle, 0, 0 );\r
        II.hbmColor := TmpBmp.Handle;}\r
     end;\r
     fHandle := CreateIconIndirect( II );\r
     //fShareIcon := False;\r
     Strm.Seek( Integer( Pos ) + SumSz, spBegin );\r
     Result := fHandle <> 0;\r
  end;\r
begin\r
  DesiredSize := fSize;\r
  if DesiredSize = 0 then\r
     DesiredSize := GetSystemMetrics( SM_CXICON );\r
  Clear;\r
  Pos := Strm.Position;\r
\r
  Mem := nil;\r
  ImgBmp := nil;\r
  MskBmp := nil;\r
  TmpBmp := nil;\r
\r
  if not ReadIcon then\r
  begin\r
     Clear;\r
     Strm.Seek( Pos, spBegin );\r
  end;\r
\r
  Mem.Free;\r
  ImgBmp.Free;\r
  MskBmp.Free;\r
  TmpBmp.Free;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TIcon.SaveToFile]\r
procedure TIcon.SaveToFile(const FileName: String);\r
asm     //cmd    //opd\r
        PUSH     EAX\r
        MOV      EAX, ESP\r
        MOV      ECX, EDX\r
        XOR      EDX, EDX\r
        CALL     SaveIcons2File\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TIcon.SaveToFile(const FileName: String);\r
begin\r
  SaveIcons2File( [ @Self ], FileName );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TIcon.SaveToStream]\r
procedure TIcon.SaveToStream(Strm: PStream);\r
asm     //cmd    //opd\r
        PUSH     EAX\r
        MOV      EAX, ESP\r
        MOV      ECX, EDX\r
        XOR      EDX, EDX\r
        CALL     SaveIcons2Stream\r
        POP      EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TIcon.SaveToStream(Strm: PStream);\r
begin\r
  SaveIcons2Stream( [ @Self ], Strm );\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
{$IFDEF ASM_noVERSION}\r
//[procedure TIcon.SetHandle]\r
procedure TIcon.SetHandle(const Value: HIcon);\r
const szII = sizeof( TIconInfo );\r
      szBIH = sizeof(TBitmapInfoHeader);\r
asm     //cmd    //opd\r
        CMP      EDX, [EAX].fHandle\r
        JE       @@exit\r
        PUSHAD\r
        PUSH     EDX\r
        MOV      EBX, EAX\r
        CALL     Clear\r
        POP      ECX\r
        MOV      [EBX].fHandle, ECX\r
        JECXZ    @@fin\r
        ADD      ESP, -szBIH\r
        PUSH     ESP\r
        PUSH     ECX\r
        CALL     GetIconInfo\r
        MOV      ESI, [ESP].TIconInfo.hbmMask\r
        MOV      EDI, [ESP].TIconInfo.hbmColor\r
        PUSH     ESP\r
        PUSH     szBIH\r
        PUSH     ESI\r
        CALL     GetObject\r
        POP      EAX\r
        POP      [EBX].fSize\r
        ADD      ESP, szBIH-8\r
        TEST     ESI, ESI\r
        JZ       @@1\r
        PUSH     ESI\r
        CALL     DeleteObject\r
@@1:    TEST     EDI, EDI\r
        JZ       @@fin\r
        PUSH     EDI\r
        CALL     DeleteObject\r
@@fin:  POPAD\r
@@exit:\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TIcon.SetHandle(const Value: HIcon);\r
var II : TIconInfo;\r
    B: TagBitmap;\r
begin\r
  if FHandle = Value then Exit;\r
  Clear;\r
  FHandle := Value;\r
  if Value <> 0 then\r
  begin\r
     GetIconInfo( FHandle, II );\r
     GetObject( II.hbmMask, Sizeof( B ), @B );\r
     fSize := B.bmWidth;\r
     if II.hbmMask <> 0 then\r
       DeleteObject( II.hbmMask );\r
     if II.hbmColor <> 0 then\r
       DeleteObject( II.hbmColor );\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//*\r
//[procedure TIcon.SetSize]\r
procedure TIcon.SetSize(const Value: Integer);\r
begin\r
  if FSize = Value then Exit;\r
  Clear;\r
  FSize := Value;\r
end;\r
\r
const PossibleColorBits : array[1..7] of Byte = ( 1, 4, 8, 16, 24, 32, 0 );\r
//[FUNCTION ColorBits]\r
{$IFDEF ASM_VERSION}\r
function ColorBits( ColorsCount : Integer ) : Integer;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        MOV      EDX, offset[PossibleColorBits]\r
@@loop: MOVZX    ECX, byte ptr [EDX]\r
        JECXZ    @@e_loop\r
        INC      EDX\r
        XOR      EBX, EBX\r
        INC      EBX\r
        SHL      EBX, CL\r
        CMP      EBX, EAX\r
        JL       @@loop\r
@@e_loop:\r
        XCHG     EAX, ECX\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function ColorBits( ColorsCount : Integer ) : Integer;\r
var I : Integer;\r
begin\r
   for I := 1 to 6 do\r
   begin\r
      Result := PossibleColorBits[ I ];\r
      if (1 shl Result) >= ColorsCount then break;\r
   end;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END ColorBits]\r
\r
//[function SaveIcons2StreamEx]\r
function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean;\r
var I, Off : Integer;\r
   IDI : TIconDirEntry;\r
   BIH : TBitmapInfoHeader;\r
   B: TagBitmap;\r
  function RGBArraySize : Integer;\r
  begin\r
     Result := 0;\r
     if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then\r
        Result := (IDI.bColorCount + (IDI.bReserved shl 8)) * Sizeof( TRGBQuad );\r
  end;\r
  function ColorDataSize( W, H: Integer ) : Integer;\r
  var N: Integer;\r
  begin\r
     if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then\r
       N := (ColorBits( IDI.bColorCount + (IDI.bReserved shl 8) ) )\r
     else\r
     begin\r
       N := IDI.wBitCount;\r
     end;\r
     Result := ((N * W + 31) div 32) * 4\r
                   * H;\r
  end;\r
  function MaskDataSize( W, H: Integer ) : Integer;\r
  begin\r
     Result := ((W + 31) div 32) * 4 * H;\r
  end;\r
var BColor, BMask: HBitmap;\r
    W, H: Integer;\r
    ImgBmp, MskBmp: PBitmap;\r
    IH : TIconHeader;\r
    Colors : PList;\r
begin\r
  Assert( (High(BmpHandles) >= 0) and (High(BmpHandles) and 1 <> 0),\r
          'Incorrect parameters count in call to SaveIcons2StreamEx' );\r
  Result := False;\r
  IH.idReserved := 0;\r
  IH.idType := 1;\r
  IH.idCount := (High( BmpHandles )+1) div 2;\r
  if Strm.Write( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit;\r
  Off := Sizeof( IH ) + IH.idCount * Sizeof( IDI );\r
  Colors := NewList;\r
  ImgBmp := NewBitmap( 0, 0 );\r
  MskBmp := NewBitmap( 0, 0 );\r
  TRY\r
\r
    for I := 0 to High( BmpHandles ) div 2 do\r
    begin\r
      BColor := BmpHandles[ I * 2 ];\r
      BMask  := BmpHandles[ I * 2 + 1 ];\r
      if (BColor = 0) and (BMask = 0) then break;\r
      Assert( BMask <> 0, 'Mask bitmap not provided for saving icons in SaveIcons2StreamEx' );\r
      GetObject( BMask, Sizeof( B ), @ B );\r
      W := B.bmWidth;\r
      H := B.bmHeight;\r
      if BColor <> 0 then\r
      begin\r
        GetObject( BColor, Sizeof( B ), @B );\r
        Assert( (B.bmWidth = W) and (B.bmHeight = H),\r
                'Mask bitmap size must much color bitmap size in SaveIcons2StreamEx' );\r
      end;\r
      FillChar( IDI, Sizeof( IDI ), 0 );\r
\r
      IDI.bWidth := W;\r
      IDI.bHeight := H;\r
      if BColor = 0 then\r
        IDI.bColorCount := 2\r
      else\r
      begin\r
        ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H,\r
                         LR_CREATEDIBSECTION );\r
        FillChar( BIH, Sizeof( BIH ), 0 );\r
        BIH.biSize := Sizeof( BIH );\r
        GetObject( ImgBmp.Handle, Sizeof( B ), @B );\r
        //if ImgBmp.HandleType = bmDDB then\r
        begin\r
          if (B.bmPlanes = 1) and (B.bmBitsPixel >= 15) then\r
          begin\r
            //ImgBmp.PixelFormat := pf24bit;\r
            IDI.bColorCount := 0;\r
            IDI.bReserved := 0;\r
            IDI.wBitCount := B.bmBitsPixel;\r
          end\r
            else\r
          if B.bmPlanes * (1 shl B.bmBitsPixel) < 16 then\r
          begin\r
             ImgBmp.PixelFormat := pf1bit;\r
             IDI.bColorCount := 2;\r
          end\r
             else\r
          if B.bmPlanes * (1 shl B.bmBitsPixel) < 256 then\r
          begin\r
             ImgBmp.PixelFormat := pf4bit;\r
             IDI.bColorCount := 16;\r
          end\r
             else\r
          begin\r
             ImgBmp.PixelFormat := pf8bit;\r
             IDI.bColorCount := 0;\r
             IDI.bReserved := 1;\r
          end;\r
          //GetObject( ImgBmp.Handle, Sizeof( BIH ), @BIH );\r
        end;\r
        //IDI.bColorCount := (1 shl BIH.biBitCount) * BIH.biPlanes;\r
      end;\r
      Colors.Add( Pointer(IDI.bColorCount + (IDI.bReserved shl 8)) );\r
      IDI.dwBytesInRes := Sizeof( BIH ) +  RGBArraySize +\r
                          ColorDataSize( W, H ) + MaskDataSize( W, H );\r
      IDI.dwImageOffset := Off;\r
      if Strm.Write( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit;\r
      Inc( Off, IDI.dwBytesInRes );\r
    end;\r
    for I := 0 to High( BmpHandles ) div 2 do\r
    begin\r
      BColor := BmpHandles[ I * 2 ];\r
      BMask  := BmpHandles[ I * 2 + 1 ];\r
      if (BColor = 0) and (BMask = 0) then break;\r
      GetObject( BMask, Sizeof( B ), @ B );\r
      W := B.bmWidth;\r
      H := B.bmHeight;\r
\r
      FillChar( BIH, Sizeof( BIH ), 0 );\r
      BIH.biSize := Sizeof( BIH );\r
      BIH.biWidth := W;\r
      BIH.biHeight := H;\r
      if BColor <> 0 then\r
        BIH.biHeight := W * 2;\r
      BIH.biPlanes := 1;\r
      PWord( @ IDI.bColorCount )^ := DWord( Colors.Items[ I ] );\r
      if IDI.wBitCount = 0 then\r
        IDI.wBitCount := ColorBits( PWord( @ IDI.bColorCount )^ );\r
      BIH.biBitCount := IDI.wBitCount;\r
      BIH.biSizeImage := Sizeof( BIH ) + ColorDataSize( W, H ) + MaskDataSize( W, H );\r
      if Strm.Write( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit;\r
      if BColor <> 0 then\r
      begin\r
\r
        ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H, 0 );\r
        case BIH.biBitCount of\r
        1 : ImgBmp.PixelFormat := pf1bit;\r
        4 : ImgBmp.PixelFormat := pf4bit;\r
        8 : ImgBmp.PixelFormat := pf8bit;\r
        16: ImgBmp.PixelFormat := pf16bit;\r
        24: ImgBmp.PixelFormat := pf24bit;\r
        32: ImgBmp.PixelFormat := pf32bit;\r
        end;\r
      end\r
        else\r
      begin\r
        ImgBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 );\r
        ImgBmp.PixelFormat := pf1bit;\r
      end;\r
      if ImgBmp.FDIBBits <> nil then\r
      begin\r
        if Strm.Write( Pointer(Integer(ImgBmp.FDIBHeader) + Sizeof(TBitmapInfoHeader))^,\r
           PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) ) <>\r
           PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) then Exit;\r
        if Strm.Write( ImgBmp.FDIBBits^, ColorDataSize( W, H ) ) <>\r
           DWord( ColorDataSize( W, H ) ) then Exit;\r
      end;\r
    MskBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 );\r
\r
    MskBmp.PixelFormat := pf1bit;\r
    if Strm.Write( MskBmp.FDIBBits^, MaskDataSize( W, H ) ) <>\r
      DWord( MaskDataSize( W, H ) ) then Exit;\r
    end;\r
\r
  FINALLY\r
    Colors.Free;\r
    ImgBmp.Free;\r
    MskBmp.Free;\r
  END;\r
  Result := True;\r
end;\r
\r
{$IFDEF FPC}\r
  {$DEFINE _D3orFPC}\r
{$ENDIF}\r
{$IFDEF _D2orD3}\r
  {$DEFINE _D3orFPC}\r
{$ENDIF}\r
//[procedure SaveIcons2Stream]\r
procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream );\r
var I, J, Pos : Integer;\r
    {$IFDEF _D3orFPC}\r
    Bitmaps: array[ 0..63 ] of HBitmap;\r
    {$ELSE DELPHI}\r
    Bitmaps: array of HBitmap;\r
    {$ENDIF FPC/DELPHI}\r
    II: TIconInfo;\r
    Bmp: HBitmap;\r
begin\r
  for I := 0 to High( Icons ) do\r
  begin\r
     if Icons[ I ].Handle = 0 then Exit;\r
     for J := I + 1 to High( Icons ) do\r
        if Icons[ I ].Size = Icons[ J ].Size then Exit;\r
  end;\r
  Pos := Strm.Position;\r
\r
  {$IFDEF _D3orFPC}\r
  for I := 0 to High( Bitmaps ) do\r
    Bitmaps[ I ] := 0;\r
  {$ELSE DELPHI}\r
  SetLength( Bitmaps, Length( Icons ) * 2 );\r
  {$ENDIF FPC/DELPHI}\r
  for I := 0 to High( Icons ) do\r
  begin\r
    GetIconInfo( Icons[ I ].Handle, II );\r
    Bitmaps[ I * 2 ] := II.hbmColor;\r
    Bitmaps[ I * 2 + 1 ] := II.hbmMask;\r
  end;\r
\r
  if not SaveIcons2StreamEx( Bitmaps, Strm ) then\r
     Strm.Seek( Pos, spBegin );\r
\r
  for I := 0 to High( Bitmaps ) do\r
  begin\r
    Bmp := Bitmaps[ I ];\r
    if Bmp <> 0 then\r
      DeleteObject( Bmp );\r
  end;\r
end;\r
(*\r
var I, J, Pos : Integer;\r
    IH : TIconHeader;\r
    Colors : PList;\r
    ImgBmp,\r
    MskBmp : PBitmap;\r
   function WriteIcons : Boolean;\r
   var I, Off : Integer;\r
       IDI : TIconDirEntry;\r
       BIH : TBitmapInfoHeader;\r
       II : TIconInfo;\r
       B: TagBitmap;\r
      function RGBArraySize : Integer;\r
      begin\r
         Result := 0;\r
         if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then\r
            Result := (IDI.bColorCount + (IDI.bReserved shl 8)) * Sizeof( TRGBQuad );\r
      end;\r
      function ColorDataSize : Integer;\r
      var N: Integer;\r
      begin\r
         //Result := 0;\r
         if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then\r
           N := (ColorBits( IDI.bColorCount + (IDI.bReserved shl 8) ) )\r
         else\r
           N := IDI.wBitCount;\r
         Result := ((N * Icons[ I ].Size + 31) div 32) * 4\r
                       * Icons[ I ].Size;\r
      end;\r
      function MaskDataSize : Integer;\r
      begin\r
         Result := ((Icons[ I ].Size + 31) div 32) * 4\r
                   * Icons[ I ].Size;\r
      end;\r
   begin\r
     Result := False;\r
     if Strm.Write( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit;\r
     Off := Sizeof( IH ) + IH.idCount * Sizeof( IDI );\r
     for I := Low( Icons ) to High( Icons ) do\r
     begin\r
       FillChar( IDI, Sizeof( IDI ), 0 );\r
       IDI.bWidth := Icons[ I ].Size;\r
       IDI.bHeight := Icons[ I ].Size;\r
       GetIconInfo( Icons[ I ].Handle, II );\r
       if II.hbmColor = 0 then\r
          IDI.bColorCount := 2\r
       else\r
       begin\r
         {ImgBmp.Handle := CopyImage( II.hbmColor, IMAGE_BITMAP, Icons[ I ].Size,\r
                          Icons[ I ].Size, LR_CREATEDIBSECTION );}\r
         ImgBmp.Handle := II.hbmColor;\r
         II.hbmColor := 0;\r
         FillChar( BIH, Sizeof( BIH ), 0 );\r
         BIH.biSize := Sizeof( BIH );\r
         GetObject( ImgBmp.Handle, Sizeof( B ), @B );\r
         //if ImgBmp.HandleType = bmDDB then\r
         begin\r
            if (B.bmPlanes = 1) and (B.bmBitsPixel >= 15) then\r
            begin\r
              //ImgBmp.PixelFormat := pf24bit;\r
              IDI.bColorCount := 0;\r
              IDI.bReserved := 0;\r
              IDI.wBitCount := B.bmBitsPixel;\r
            end\r
              else\r
            if B.bmPlanes * (1 shl B.bmBitsPixel) < 16 then\r
            begin\r
               ImgBmp.PixelFormat := pf1bit;\r
               IDI.bColorCount := 2;\r
            end\r
               else\r
            if B.bmPlanes * (1 shl B.bmBitsPixel) < 256 then\r
            begin\r
               ImgBmp.PixelFormat := pf4bit;\r
               IDI.bColorCount := 16;\r
            end\r
               else\r
            begin\r
               ImgBmp.PixelFormat := pf8bit;\r
               IDI.bColorCount := 0;\r
               IDI.bReserved := 1;\r
            end;\r
            //GetObject( ImgBmp.Handle, Sizeof( BIH ), @BIH );\r
         end;\r
         //IDI.bColorCount := (1 shl BIH.biBitCount) * BIH.biPlanes;\r
         //--//DeleteObject( II.hbmColor );\r
       end;\r
       if II.hbmMask <> 0 then\r
         DeleteObject( II.hbmMask );\r
       Colors.Add( Pointer(IDI.bColorCount + (IDI.bReserved shl 8)) );\r
       IDI.dwBytesInRes := Sizeof( BIH ) +  RGBArraySize +\r
                           ColorDataSize + MaskDataSize;\r
       IDI.dwImageOffset := Off;\r
       if Strm.Write( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit;\r
       Inc( Off, IDI.dwBytesInRes );\r
     end;\r
     for I := Low( Icons ) to High( Icons ) do\r
     begin\r
       FillChar( BIH, Sizeof( BIH ), 0 );\r
       BIH.biSize := Sizeof( BIH );\r
       BIH.biWidth := Icons[ I ].Size;\r
       BIH.biHeight := Icons[ I ].Size;\r
       //GetObject( Icons[ I ].Handle, Sizeof( II ), @II );\r
       GetIconInfo( Icons[ I ].Handle, II );\r
       if II.hbmColor <> 0 then\r
          BIH.biHeight := Icons[ I ].Size * 2;\r
       BIH.biPlanes := 1;\r
       PWord( @ IDI.bColorCount )^ := DWord( Colors.Items[ I - Low( Icons ) ] );\r
       if IDI.wBitCount = 0 then\r
         IDI.wBitCount := ColorBits( PWord( @ IDI.bColorCount )^ );\r
       BIH.biBitCount := IDI.wBitCount;\r
       BIH.biSizeImage := Sizeof( BIH ) + ColorDataSize + MaskDataSize;\r
       if Strm.Write( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit;\r
       if II.hbmColor <> 0 then\r
       begin\r
\r
          ImgBmp.Handle := {CopyImage( II.hbmColor, IMAGE_BITMAP, Icons[ I ].Size,\r
                          Icons[ I ].Size, 0 );}\r
                          II.hbmColor;\r
                          II.hbmColor := 0;\r
          case BIH.biBitCount of\r
          1 : ImgBmp.PixelFormat := pf1bit;\r
          4 : ImgBmp.PixelFormat := pf4bit;\r
          8 : ImgBmp.PixelFormat := pf8bit;\r
          16: ImgBmp.PixelFormat := pf16bit;\r
          24: ImgBmp.PixelFormat := pf24bit;\r
          32: ImgBmp.PixelFormat := pf32bit;\r
          end;\r
       end\r
          else\r
       begin\r
          ImgBmp.Handle := CopyImage( II.hbmMask, IMAGE_BITMAP, Icons[ I ].Size,\r
                          Icons[ I ].Size, 0 );\r
          ImgBmp.PixelFormat := pf1bit;\r
       end;\r
       if ImgBmp.FDIBBits <> nil then\r
       begin\r
          if Strm.Write( Pointer(Integer(ImgBmp.FDIBHeader) + Sizeof(TBitmapInfoHeader))^,\r
             PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) ) <>\r
             PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) then Exit;\r
          if Strm.Write( ImgBmp.FDIBBits^, ColorDataSize ) <>\r
             DWord( ColorDataSize ) then Exit;\r
       end;\r
       MskBmp.Handle := CopyImage( II.hbmMask, IMAGE_BITMAP, Icons[ I ].Size,\r
                          Icons[ I ].Size, 0 {LR_COPYRETURNORG} );\r
       //***\r
       if II.hbmMask <> 0 then\r
         DeleteObject( II.hbmMask );\r
       if II.hbmColor <> 0 then\r
         DeleteObject( II.hbmColor );\r
       //***\r
\r
       MskBmp.PixelFormat := pf1bit;\r
       if Strm.Write( MskBmp.FDIBBits^, MaskDataSize ) <>\r
          DWord( MaskDataSize ) then Exit;\r
     end;\r
     Result := True;\r
   end;\r
begin\r
  for I := Low( Icons ) to High( Icons ) do\r
  begin\r
     if Icons[ I ].Handle = 0 then Exit;\r
     for J := I + 1 to High( Icons ) do\r
        if Icons[ I ].Size = Icons[ J ].Size then Exit;\r
  end;\r
  IH.idReserved := 0;\r
  IH.idType := 1;\r
  IH.idCount := High( Icons ) - Low( Icons ) + 1;\r
  Pos := Strm.Position;\r
  Colors := NewList;\r
  ImgBmp := NewBitmap( 0, 0 );\r
  MskBmp := NewBitmap( 0, 0 );\r
\r
  if not WriteIcons then\r
     Strm.Seek( Pos, spBegin );\r
\r
  ImgBmp.Free;\r
  MskBmp.Free;\r
  Colors.Free;\r
end;\r
*)\r
\r
//[procedure SaveIcons2File]\r
procedure SaveIcons2File( const Icons : array of PIcon; const FileName : String );\r
var Strm: PStream;\r
begin\r
  Strm := NewWriteFileStream( FileName );\r
  SaveIcons2Stream( Icons, Strm );\r
  Strm.Free;\r
end;\r
\r
//[procedure TIcon.LoadFromExecutable]\r
procedure TIcon.LoadFromExecutable(const FileName: String; IconIdx: Integer);\r
var I: Integer;\r
begin\r
  Clear;\r
  I := ExtractIcon( hInstance, PChar( FileName ), IconIdx );\r
  if I > 1 then\r
    Handle := I;\r
end;\r
\r
//[function GetFileIconCount]\r
function GetFileIconCount( const FileName: String ): Integer;\r
begin\r
  Result := ExtractIcon( hInstance, PChar( FileName ), DWORD(-1) );\r
end;\r
\r
//[procedure TIcon.LoadFromResourceID]\r
procedure TIcon.LoadFromResourceID(Inst, ResID, DesiredSize: Integer);\r
begin\r
  LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ), DesiredSize );\r
end;\r
\r
//[procedure TIcon.LoadFromResourceName]\r
procedure TIcon.LoadFromResourceName(Inst: Integer; ResName: PChar; DesiredSize: Integer);\r
begin\r
  Handle := LoadImage( Inst, ResName, IMAGE_ICON, DesiredSize, DesiredSize,\r
                       $8000 {LR_SHARED} );\r
  {if Handle = 0 then\r
    Handle := LoadIcon( Inst, ResName )\r
  else}\r
  if fHandle <> 0 then FShareIcon := True;\r
end;\r
\r
//[function LoadImgIcon]\r
function LoadImgIcon( RsrcName: PChar; Size: Integer ): HIcon;\r
begin\r
  Result := LoadImage( hInstance, RsrcName, IMAGE_ICON, Size, Size, $8000 {LR_SHARED} );\r
end;\r
\r
\r
////////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                         M  E T A F I L E\r
//\r
//\r
////////////////////////////////////////////////////////////////////////\r
\r
{++}(*\r
//[API SetEnhMetaFileBits]\r
function SetEnhMetaFileBits; external gdi32 name 'SetEnhMetaFileBits';\r
function PlayEnhMetaFile; external gdi32 name 'PlayEnhMetaFile';\r
*){--}\r
\r
//[function NewMetafile]\r
function NewMetafile: PMetafile;\r
begin\r
  {-}\r
  new( Result, Create );\r
  {+}{++}(*Result := PMetafile.Create;*){--}\r
end;\r
//[END NewMetafile]\r
\r
{ TMetafile }\r
\r
//[procedure TMetafile.Clear]\r
procedure TMetafile.Clear;\r
begin\r
  if fHandle <> 0 then\r
    DeleteEnhMetaFile( fHandle );\r
  fHandle := 0;\r
end;\r
\r
//[destructor TMetafile.Destroy]\r
destructor TMetafile.Destroy;\r
begin\r
  if fHeader <> nil then\r
    FreeMem( fHeader );\r
  Clear;\r
  inherited;\r
end;\r
\r
//[procedure TMetafile.Draw]\r
procedure TMetafile.Draw(DC: HDC; X, Y: Integer);\r
begin\r
  StretchDraw( DC, MakeRect( X, Y, X + Width, Y + Height ) );\r
end;\r
\r
//[function TMetafile.Empty]\r
function TMetafile.Empty: Boolean;\r
begin\r
  Result := fHandle = 0;\r
end;\r
\r
//[function TMetafile.GetHeight]\r
function TMetafile.GetHeight: Integer;\r
begin\r
  Result := 0;\r
  if Empty then Exit;\r
  RetrieveHeader;\r
  Result := fHeader.rclBounds.Bottom - fHeader.rclBounds.Top;\r
end;\r
\r
//[function TMetafile.GetWidth]\r
function TMetafile.GetWidth: Integer;\r
begin\r
  Result := 0;\r
  if Empty then Exit;\r
  RetrieveHeader;\r
  Result := fHeader.rclBounds.Right - fHeader.rclBounds.Left;\r
end;\r
\r
//[function TMetafile.LoadFromFile]\r
function TMetafile.LoadFromFile(const Filename: String): Boolean;\r
var Strm: PStream;\r
begin\r
  Strm := NewReadFileStream( FileName );\r
  Result := LoadFromStream( Strm );\r
  Strm.Free;\r
end;\r
\r
//[function ComputeAldusChecksum]\r
function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;\r
type\r
  PWord = ^Word;\r
var\r
  pW: PWord;\r
  pEnd: PWord;\r
begin\r
  Result := 0;\r
  pW := @WMF;\r
  pEnd := @WMF.CheckSum;\r
  while Longint(pW) < Longint(pEnd) do\r
  begin\r
    Result := Result xor pW^;\r
    Inc(Longint(pW), SizeOf(Word));\r
  end;\r
end;\r
\r
//[function TMetafile.LoadFromStream]\r
function TMetafile.LoadFromStream(Strm: PStream): Boolean;\r
var WMF: TMetaFileHeader;\r
    WmfHdr: TMetaHeader;\r
    EnhHdr: TEnhMetaHeader;\r
    Pos, Pos1: Integer;\r
    Sz: Integer;\r
    MemStrm: PStream;\r
    MFP: TMetafilePict;\r
begin\r
  Result := FALSE;\r
  Pos := Strm.Position;\r
\r
  if Strm.Read( WMF, Sizeof( WMF ) ) <> Sizeof( WMF ) then\r
  begin\r
    Strm.Position := Pos;\r
    Exit;\r
  end;\r
\r
  MemStrm := NewMemoryStream;\r
\r
  if WMF.Key = WMFKey then\r
  begin // Windows metafile\r
\r
    if WMF.CheckSum <> ComputeAldusChecksum( WMF ) then\r
    begin\r
      Strm.Position := Pos;\r
      Exit;\r
    end;\r
\r
    Pos1 := Strm.Position;\r
    if Strm.Read( WmfHdr, Sizeof( WmfHdr ) ) <> Sizeof( WmfHdr ) then\r
    begin\r
      Strm.Position := Pos;\r
      Exit;\r
    end;\r
\r
    Strm.Position := Pos1;\r
    Sz := WMFHdr.mtSize * 2;\r
    Stream2Stream( MemStrm, Strm, Sz );\r
    FillChar( MFP, Sizeof( MFP ), 0 );\r
    MFP.mm := MM_ANISOTROPIC;\r
    fHandle := SetWinMetafileBits( Sz, MemStrm.Memory, 0, MFP );\r
\r
  end\r
    else\r
  begin // may be enchanced?\r
\r
    Strm.Position := Pos;\r
    if Strm.Read( EnhHdr, Sizeof( EnhHdr ) ) < 8 then\r
    begin\r
      Strm.Position := Pos;\r
      Exit;\r
    end;\r
    // yes, enchanced\r
    Strm.Position := Pos;\r
    Sz := EnhHdr.nBytes;\r
    Stream2Stream( MemStrm, Strm, Sz );\r
    fHandle := SetEnhMetaFileBits( Sz, MemStrm.Memory );\r
\r
  end;\r
\r
  MemStrm.Free;\r
  Result := fHandle <> 0;\r
  if not Result then\r
    Strm.Position := Pos;\r
\r
end;\r
\r
//[procedure TMetafile.RetrieveHeader]\r
procedure TMetafile.RetrieveHeader;\r
var SzHdr: Integer;\r
begin\r
  if fHeader <> nil then\r
    FreeMem( fHeader );\r
  SzHdr := GetEnhMetaFileHeader( fHandle, 0, nil );\r
  GetMem( fHeader, SzHdr );\r
  GetEnhMetaFileHeader( fHandle, SzHdr, fHeader );\r
end;\r
\r
//[procedure TMetafile.SetHandle]\r
procedure TMetafile.SetHandle(const Value: THandle);\r
begin\r
  Clear;\r
  fHandle := Value;\r
end;\r
\r
//[procedure TMetafile.StretchDraw]\r
procedure TMetafile.StretchDraw(DC: HDC; const R: TRect);\r
begin\r
  if Empty then Exit;\r
  PlayEnhMetaFile( DC, fHandle, R );\r
end;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
//*\r
//[procedure AlignChildrenProc]\r
procedure AlignChildrenProc( Sender: PObj );\r
type\r
  TAligns = set of TControlAlign;\r
var P: PControl;\r
    CR: TRect;\r
  procedure DoAlign( Allowed: TAligns );\r
  var I: Integer;\r
      C: PControl;\r
      R, R1: TRect;\r
      W, H: Integer;\r
      ChgPos, ChgSiz: Boolean;\r
  begin\r
    for I := 0 to P.fChildren.fCount - 1 do\r
    begin\r
      C := P.fChildren.fItems[ I ];\r
      if not C.ToBeVisible then continue;\r
      // important: not fVisible, and even not Visible, but ToBeVisible!\r
      if C.fNotUseAlign then continue;\r
      if C.FAlign in Allowed then\r
      begin\r
        R := C.BoundsRect;\r
        R1 := R;\r
        W := R.Right - R.Left;\r
        H := R.Bottom - R.Top;\r
        case C.FAlign of\r
        caTop:\r
          begin\r
            OffsetRect( R, 0, -R.Top + CR.Top + P.Margin );\r
            Inc( CR.Top, H + P.Margin );\r
            R.Left := CR.Left + P.Margin;\r
            R.Right := CR.Right - P.Margin;\r
          end;\r
        caBottom:\r
          begin\r
            OffsetRect( R, 0, -R.Bottom + CR.Bottom - P.Margin );\r
            Dec( CR.Bottom, H + P.Margin );\r
            R.Left := CR.Left + P.Margin;\r
            R.Right := CR.Right - P.Margin;\r
          end;\r
        caLeft:\r
          begin\r
            OffsetRect( R, -R.Left + CR.Left + P.Margin, 0 );\r
            Inc( CR.Left, W + P.Margin );\r
            R.Top := CR.Top + P.Margin;\r
            R.Bottom := CR.Bottom - P.Margin;\r
          end;\r
        caRight:\r
          begin\r
            OffsetRect( R, -R.Right + CR.Right - P.Margin, 0 );\r
            Dec( CR.Right, W + P.Margin );\r
            R.Top := CR.Top + P.Margin;\r
            R.Bottom := CR.Bottom - P.Margin;\r
          end;\r
        caClient:\r
          begin\r
            R := CR;\r
            InflateRect( R, -P.Margin, -P.Margin );\r
          end;\r
        end;\r
        if R.Right < R.Left then R.Right := R.Left;\r
        if R.Bottom < R.Top then R.Bottom := R.Top;\r
        ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top);\r
        ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H);\r
        if ChgPos or ChgSiz then\r
        begin\r
          C.BoundsRect := R;\r
          if ChgSiz then\r
            AlignChildrenProc( C );\r
        end;\r
      end;\r
    end;\r
  end;\r
begin\r
  P := Pointer( Sender );\r
  if P = nil then Exit; // Called for form - ignore.\r
  CR := P.ClientRect;\r
  DoAlign( [ caTop, caBottom ] );\r
  DoAlign( [ caLeft, caRight ] );\r
  DoAlign( [ caClient ] );\r
end;\r
\r
//*\r
//[procedure TControl.Set_Align]\r
procedure TControl.Set_Align(const Value: TControlAlign);\r
begin\r
  Global_Align := AlignChildrenProc;\r
  if fNotUseAlign then Exit;\r
  if FAlign = Value then Exit;\r
  FAlign := Value;\r
  //Global_Align( Parent );\r
  AlignChildrenProc( Parent );\r
end;\r
\r
//*\r
//[function TControl.SetAlign]\r
function TControl.SetAlign(AAlign: TControlAlign): PControl;\r
begin\r
  Set_Align( AAlign );\r
  Result := @Self;\r
end;\r
\r
//*\r
//[function WndProcPreventResizeFlicks]\r
function WndProcPreventResizeFlicks( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
type TRectsArray = array[0..2] of TRect;\r
     PRectsArray = ^TRectsArray;\r
     TChange = ( ChgL, ChgT, ChgR, ChgB );\r
     TChanges = Set of TChange;\r
var Rects : PRectsArray;\r
    Changes : Set of TChange;\r
    Resizing : Boolean;\r
    X, Y, DX, DY : Integer;\r
    EntireRect, Src, Dst : TRect;\r
\r
    function GetClientAfter : TRect;\r
    var R : TRect;\r
    begin\r
      R := Rects[ 2 ];\r
      OffsetRect( R, Rects[ 0 ].Left - Rects[ 1 ].Left,\r
                  Rects[ 0 ].Top - Rects[ 1 ].Top );\r
      if Rects[ 0 ].Right - Rects[ 0 ].Left <> Rects[ 1 ].Right - Rects[ 1 ].Left then\r
         R.Right := R.Left + (R.Right - R.Left)\r
                           + (Rects[ 0 ].Right - Rects[ 0 ].Left)\r
                           - (Rects[ 1 ].Right - Rects[ 1 ].Left);\r
      if Rects[ 0 ].Bottom - Rects[ 0 ].Top <> Rects[ 1 ].Bottom - Rects[ 1 ].Top then\r
         R.Bottom := R.Top + (R.Bottom - R.Top)\r
                           + (Rects[ 0 ].Bottom - Rects[ 0 ].Top)\r
                           - (Rects[ 1 ].Bottom - Rects[ 1 ].Top);\r
      Result := R;\r
    end;\r
\r
    procedure DoResize( F : PControl; Changes : TChanges );\r
    var ClientAfter : TRect;\r
\r
        procedure CollectClipRgn( V : PControl; Changes : TChanges );\r
        var C : PControl;\r
            I : Integer;\r
        begin\r
           for I := 0 to V.FChildren.FCount - 1 do\r
           begin\r
               C := V.FChildren.FItems[ I ];\r
               if not C.Visible then Continue;\r
\r
               if C.fNotUseAlign then\r
               begin\r
                 C.Update;\r
               end;\r
           end;\r
        end; // of CollectClipRgn\r
\r
\r
    begin // DoResize\r
         ClientAfter := GetClientAfter;\r
         //ClipRgn := CreateRectRgn( ClientAfter.Left, ClientAfter.Top,\r
         //           ClientAfter.Right, ClientAfter.Bottom );\r
         CollectClipRgn( F, Changes );\r
         //ScrollWithoutClipRgn;\r
         //DeleteObject( ClipRgn );\r
    end; // of DoResize\r
\r
var PR: PRect;\r
    R: TRect;\r
begin // Procedure WndProcResizeFlicks\r
  Result := False;\r
  case Msg.message of\r
  WM_NCCALCSIZE:\r
    if Msg.wParam <> 0 then\r
    begin\r
      Rects := Pointer( Msg.lParam );\r
      Changes := [];\r
      if Rects[ 0 ].Left <> Rects[ 1 ].Left then\r
         Changes := Changes + [ ChgL ];\r
      if Rects[ 0 ].Top <> Rects[ 1 ].Top then\r
         Changes := Changes + [ ChgT ];\r
      if Rects[ 0 ].Right <> Rects[ 1 ].Right then\r
         Changes := Changes + [ ChgR ];\r
      if Rects[ 0 ].Bottom <> Rects[ 1 ].Bottom then\r
         Changes := Changes + [ ChgB ];\r
      Resizing := Changes * [ ChgL, ChgT ] <> [ ];\r
      if Resizing and not Sender.fNotUseAlign then\r
      begin\r
        EntireRect := GetClientAfter;\r
        OffsetRect( EntireRect, -EntireRect.Left, -EntireRect.Top );\r
        if EntireRect.Right - EntireRect.Left < Rects[ 2 ].Right - Rects[ 2 ].Left then\r
           EntireRect.Right := Rects[ 2 ].Right - Rects[ 2 ].Left;\r
        if EntireRect.Bottom - EntireRect.Top < Rects[ 2 ].Bottom - Rects[ 2 ].Top then\r
           EntireRect.Bottom := Rects[ 2 ].Bottom - Rects[ 2 ].Top;\r
        X := Min( Rects[ 0 ].Left, Rects[ 1 ].Left ) + Rects[ 2 ].Left - Rects[ 1 ].Left;\r
        Y := Min( Rects[ 0 ].Top, Rects[ 1 ].Top ) + Rects[ 2 ].Top - Rects[ 2 ].Top;\r
        OffsetRect( EntireRect, X, Y );\r
        DX := 0; DY := 0;\r
        if ChgL in Changes then\r
          DX := Rects[ 0 ].Left - Rects[ 1 ].Left;\r
        if ChgR in Changes then\r
          DX := Rects[ 0 ].Right - Rects[ 1 ].Right;\r
        if ChgT in Changes then\r
          DY := Rects[ 0 ].Top - Rects[ 1 ].Top;\r
        if ChgB in Changes then\r
          DY := Rects[ 0 ].Bottom - Rects[ 1 ].Bottom;\r
        DoResize( Sender, Changes );\r
        if (Changes = [ChgL]) {and (Rects[0].Left <> Rects[1].Left)} then\r
        begin\r
          Rslt := WVR_VALIDRECTS;\r
          Src := Rects[ 2 ];\r
          Dst := GetClientAfter;\r
          Src.Right := Src.Left - DX;\r
          Dst.Right := Dst.Left - DX;\r
          Rects[ 1 ] := Src;\r
          Rects[ 2 ] := Dst;\r
        end\r
          else\r
        if (Changes = [ChgR]) {and (Rects[0].Right > Rects[1].Right)} then\r
        begin\r
          Rslt := WVR_VALIDRECTS;\r
          Src := Rects[ 2 ];\r
          Dst := GetClientAfter;\r
          Src.Left := Src.Right - DX;\r
          Dst.Left := Dst.Right - DX;\r
          Rects[ 1 ] := Src;\r
          Rects[ 2 ] := Dst;\r
        end\r
           else\r
        if (Changes = [ChgT]) {and (Rects[0].Top <> Rects[1].Top)} then\r
        begin\r
          Rslt := WVR_VALIDRECTS;\r
          Src := Rects[ 2 ];\r
          Dst := GetClientAfter;\r
          Src.Bottom := Src.Top - DY;\r
          Dst.Bottom := Dst.Top - DY;\r
          Rects[ 1 ] := Src;\r
          Rects[ 2 ] := Dst;\r
        end\r
           else\r
        if Changes = [ChgL,ChgT] then\r
        begin\r
          Rslt := WVR_VALIDRECTS;\r
          Src := Rects[ 2 ];\r
          Dst := GetClientAfter;\r
          Src.Left := Src.Right - DX;\r
          Dst.Left := Dst.Right - DX;\r
          Src.Bottom := Src.Top - DY;\r
          Dst.Bottom := Dst.Top - DY;\r
          Rects[ 1 ] := Src;\r
          Rects[ 2 ] := Dst;\r
        end;\r
        PostMessage( Sender.fHandle, CM_UPDATE, 0, 0 );\r
      end\r
         {else\r
      if Sender.fNotUseAlign then\r
      begin\r
      end};\r
    end;\r
  CM_UPDATE:\r
    begin\r
      if Sender.fNotUpdate then\r
      begin\r
        Sender.fNotUpdate := False;\r
        Sender.Invalidate;\r
      end;\r
      Sender.Update;\r
    end;\r
  WM_SIZING:\r
    begin\r
      if (Msg.wParam = WMSZ_TOPLEFT) or (Msg.wParam = WMSZ_BOTTOMLEFT) or (Msg.wParam = WMSZ_TOPRIGHT) then\r
      begin\r
        PR := Pointer( Msg.lParam );\r
        GetWindowRect( Sender.fHandle, R );\r
        PostMessage( Sender.fHandle, CM_SIZEPOS, LoWord( PR.Left) or (PR.Top shl 16),\r
                     LoWord( PR.Right - PR.Left ) or ( (PR.Bottom - PR.Top) shl 16) );\r
        if Msg.wParam = WMSZ_TOPLEFT then\r
          if Abs( R.Top - PR.Top ) < Abs( R.Left - PR.Left ) then\r
            PR.Top := R.Top\r
          else\r
            PR.Left := R.Left\r
        else\r
        if Msg.wParam = WMSZ_BOTTOMLEFT then\r
          if Abs( R.Bottom - PR.Bottom ) < Abs( R.Left - PR.Left ) then\r
            PR.Bottom := R.Bottom\r
          else\r
            PR.Left := R.Left\r
        else // WMSZ_TOPRIGHT\r
          if Abs( R.Top - PR.Top ) < Abs( R.Right - PR.Right ) then\r
            PR.Top := R.Top\r
          else\r
            PR.Right := R.Right;\r
        Sender.fNotUpdate := True;\r
        Rslt := 1;\r
        Result := TRUE;\r
      end;\r
    end;\r
  CM_SIZEPOS:\r
    begin\r
      Sender.fNotUpdate := False;\r
      SetWindowPos( Sender.fHandle, 0, SmallInt( LoWord( Msg.wParam ) ),\r
                    SmallInt( HiWord( Msg.wParam ) ), SmallInt( LoWord( Msg.lParam ) ),\r
                    SmallInt( HiWord( Msg.lParam ) ), SWP_NOZORDER or SWP_NOACTIVATE );\r
    end;\r
  WM_PAINT:\r
    begin\r
      if Sender.fNotUpdate then\r
      begin\r
        Rslt := 0;\r
        Result := True;\r
      end;\r
    end;\r
  WM_ERASEBKGND:\r
    begin\r
      if Sender.fNotUpdate then\r
      begin\r
        Rslt := 1;\r
        Result := True;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//*\r
//[function TControl.PreventResizeFlicks]\r
function TControl.PreventResizeFlicks: PControl;\r
begin\r
  fWndProcResizeFlicks := WndProcPreventResizeFlicks;\r
  Result := @Self;\r
end;\r
\r
//*\r
//[procedure TControl.Update]\r
procedure TControl.Update;\r
var I: Integer;\r
    C: PControl;\r
begin\r
  if fUpdateCount > 0 then\r
    Exit;\r
  if fNotUpdate then Exit;\r
  if fHandle = 0 then Exit;\r
  UpdateWindow( fHandle );\r
  for I := 0 to fChildren.fCount - 1 do\r
  begin\r
    C := fChildren.fItems[ I ];\r
    C.Update;\r
  end;\r
end;\r
\r
//[FUNCTION WndProcUpdate]\r
{$IFDEF ASM_VERSION}\r
function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        XCHG     EBX, EAX\r
        MOV      EAX, [EBX].TControl.fUpdateCount\r
        TEST     EAX, EAX\r
        JZ       @@exit\r
\r
        XOR      EAX, EAX\r
        MOV      EDX, [EDX].TMsg.message\r
        CMP      DX, WM_PAINT\r
        JNE      @@chk_erasebkgnd\r
\r
        MOV      [ECX], EAX\r
        PUSH     EAX\r
        PUSH     [EBX].TControl.fHandle\r
        CALL     ValidateRect\r
        JMP      @@rslt_1\r
@@chk_erasebkgnd:\r
        CMP      DX, WM_ERASEBKGND\r
        JNE      @@exit\r
        INC      EAX\r
        MOV      [ECX], EAX\r
@@rslt_1:\r
        MOV      AL, 1\r
@@exit:\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  if Sender.fUpdateCount > 0 then\r
  begin\r
    case Msg.message of\r
    WM_PAINT:\r
      begin\r
        ValidateRect( Sender.Handle, nil );\r
        Rslt := 0;\r
      end;\r
    WM_ERASEBKGND: Rslt := 1;\r
    else begin\r
           Result := FALSE;\r
           Exit;\r
         end;\r
    end;\r
    Result := TRUE;\r
  end\r
    else Result := FALSE;\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END WndProcUpdate]\r
\r
//[procedure TControl.BeginUpdate]\r
procedure TControl.BeginUpdate;\r
begin\r
  Inc( fUpdateCount );\r
  AttachProc( @WndProcUpdate );\r
end;\r
\r
//[procedure TControl.EndUpdate]\r
procedure TControl.EndUpdate;\r
begin\r
  Dec( fUpdateCount );\r
  if fUpdateCount <= 0 then\r
  begin\r
    Invalidate;\r
    //Update;\r
  end;\r
end;\r
\r
//*\r
//[function TControl.GetSelection]\r
function TControl.GetSelection: String;\r
var L: Integer;\r
begin\r
  if fCommandActions.aGetSelection <> 0 then\r
  begin\r
    L := SelLength;\r
    SetString( Result, nil, L + 1 );\r
    Perform( fCommandActions.aGetSelection, 0, Integer( @Result[ 1 ] ) );\r
  end\r
     else\r
  Result := Copy( Text, SelStart + 1, SelLength );\r
end;\r
\r
//*\r
//[procedure TControl.SetSelection]\r
procedure TControl.SetSelection(const Value: String);\r
begin\r
  ReplaceSelection( Value, True );\r
end;\r
\r
//*\r
//[procedure TControl.ReplaceSelection]\r
procedure TControl.ReplaceSelection(const Value: String; aCanUndo: Boolean);\r
begin\r
  if fCommandActions.aReplaceSel <> 0 then\r
  begin\r
    Perform( fCommandActions.aReplaceSel, Integer( aCanUndo ), Integer( Pchar( Value ) ) );\r
  end;\r
end;\r
\r
//[procedure TControl.DeleteLines]\r
procedure TControl.DeleteLines(FromLine, ToLine: Integer);\r
var I1, I2: Integer;\r
    SStart, SLength: Integer;\r
begin\r
  if FromLine > ToLine then Exit;\r
  Assert( FromLine >= 0, 'Incorrect line index' );\r
  I1 := Item2Pos( FromLine );\r
  I2 := Item2Pos( ToLine+1 );\r
  SStart := SelStart;\r
  SLength := SelLength;\r
  SelStart := I1;\r
  SelLength := I2 - I1;\r
  ReplaceSelection( '', TRUE );\r
  if SStart >= I2 then\r
  begin\r
    SStart := SStart - (I2 - I1);\r
  end\r
    else\r
  if SStart >= I1 then\r
  begin\r
    SLength := SLength - (I2 - SStart);\r
    SStart := I1;\r
  end\r
    else\r
  if SStart + SLength >= I2 then\r
  begin\r
    SLength := SLength - (I2 - I1);\r
  end\r
    else\r
  if SStart + SLength >= I1 then\r
  begin\r
    SLength := I1 - SLength;\r
  end;\r
  SelStart := SStart;\r
  SelLength := Max( 0, SLength );\r
end;\r
\r
//*\r
//[procedure TControl.SetTabOrder]\r
procedure TControl.SetTabOrder(const Value: Integer);\r
var CL: PList;\r
    I : Integer;\r
    C: PControl;\r
begin\r
  if Value = fTabOrder then Exit;\r
  CL := CollectTabControls( ParentForm );\r
  for I := 0 to CL.fCount - 1 do\r
  begin\r
    C := CL.fItems[ I ];\r
    if C.fTabOrder >= Value then\r
      Inc( C.fTabOrder );\r
  end;\r
  fTabOrder := Value;\r
  CL.Free;\r
end;\r
\r
//*\r
//[function TControl.GetFocused]\r
function TControl.GetFocused: Boolean;\r
begin\r
  if fIsControl then\r
    Result := ParentForm.fCurrentControl = @Self\r
  else\r
    Result := GetForegroundWindow = fHandle;\r
end;\r
\r
//*\r
//[procedure TControl.SetFocused]\r
procedure TControl.SetFocused(const Value: Boolean);\r
begin\r
  if not Value then Exit;\r
  if fIsControl then\r
  begin\r
    ParentForm.fCurrentControl := @Self;\r
    SetFocus( GetWindowHandle );\r
  end\r
    else\r
  begin\r
    SetForegroundWindow( GetWindowHandle );\r
  end;\r
end;\r
\r
type\r
  PCharFormat = ^TCharFormat;\r
\r
\r
\r
\r
\r
\r
//////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                  R  I  C  H     E  D  I  T\r
//\r
//\r
//////////////////////////////////////////////////////////////////////\r
\r
{ -- rich edit -- }\r
\r
//*\r
//[function TControl.REGetFont]\r
function TControl.REGetFont: PGraphicTool;\r
var CF: PCharFormat;\r
    FS: TFontStyle;\r
begin\r
  CF := @fRECharFormatRec;\r
  FillChar( CF^, 82 {sizeof( TCharFormat2 )}, 0 );\r
  CF.cbSize := sizeof( RichEdit.TCharFormat ) + fCharFmtDeltaSz;\r
  if fTmpFont = nil then\r
    fTmpFont := NewFont;\r
  Result := fTmpFont;\r
  Result.OnChange := nil;\r
  Perform( EM_GETCHARFORMAT, 1, Integer( CF ) );\r
  Result.FontHeight := CF.yHeight;\r
  FS := [ ];\r
  if LongBool(CF.dwEffects and CFE_BOLD) then\r
    FS := [ fsBold ];\r
  if LongBool(CF.dwEffects and CFE_ITALIC) then\r
    FS := FS + [ fsItalic ];\r
  if LongBool(CF.dwEffects and CFE_STRIKEOUT) then\r
    FS := FS + [ fsStrikeOut ];\r
  if LongBool(CF.dwEffects and CFE_UNDERLINE) then\r
    FS := FS + [ fsUnderline ];\r
  Result.FontStyle := FS;\r
  if not LongBool(CF.dwEffects and CFE_AUTOCOLOR) then\r
    Result.Color := CF.crTextColor;\r
  Result.FontPitch := TFontPitch( CF.bPitchAndFamily and 3 );\r
  Result.FontCharset := CF.bCharSet;\r
  Result.FontName := CF.szFaceName;\r
  Result.OnChange := RESetFont;\r
end;\r
\r
const RichAreas: array[ TRichFmtArea ] of Integer = ( SCF_SELECTION,\r
      SCF_WORD, 4 {SCF_ALL} );\r
\r
//*\r
//[procedure TControl.RESetFontEx]\r
procedure TControl.RESetFontEx(const Index: Integer);\r
var CF: PCharFormat;\r
    FS: TFontStyle;\r
begin\r
  CF := @fRECharFormatRec;\r
  FillChar( CF^, {82} sizeof( TCharFormat2 ), 0 );\r
  CF.cbSize := 60 { sizeof( TCharFormat ) } + fCharFmtDeltaSz;\r
  CF.dwMask := CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC\r
            or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE;\r
  CF.yHeight := fTmpFont.FontHeight;\r
  FS := fTmpFont.FontStyle;\r
  if fsBold in FS then CF.dwEffects := CFE_BOLD;\r
  if fsItalic in FS then CF.dwEffects := CF.dwEffects or CFE_ITALIC;\r
  if fsStrikeOut in FS then CF.dwEffects := CF.dwEffects or CFE_STRIKEOUT;\r
  if fsUnderline in FS then CF.dwEffects := CF.dwEffects or CFE_UNDERLINE;\r
  CF.crTextColor := Color2RGB(fTmpFont.Color);\r
  CF.bCharSet := fTmpFont.FontCharset;\r
  CF.bPitchAndFamily := Ord( fTmpFont.FontPitch );\r
  StrLCopy( CF.szFaceName, PChar( fTmpFont.FontName ), 31 );\r
  Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( CF ) );\r
end;\r
\r
//*\r
//[procedure TControl.RESetFont]\r
procedure TControl.RESetFont(Value: PGraphicTool);\r
var H: Integer;\r
begin\r
  if Value <> fTmpFont then\r
    REGetFont;\r
  H := fTmpFont.fData.Font.Height;\r
  fTmpFont := fTmpFont.Assign( Value );\r
  if fTmpFont.fData.Font.Height = 0 then\r
    fTmpFont.fData.Font.Height := H;\r
  RESetFontEx( Integer( CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC\r
            or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE ) );\r
end;\r
\r
//*\r
//[function TControl.REGetFontMask]\r
function TControl.REGetFontMask( const Index: Integer ): Boolean;\r
begin\r
  REGetFont;\r
  Result := LongBool( fRECharFormatRec.dwMask and Index );\r
end;\r
\r
//*\r
//[function TControl.REGetFontEffects]\r
function TControl.REGetFontEffects(const Index: Integer): Boolean;\r
begin\r
  REGetFont;\r
  Result := LongBool( fRECharFormatRec.dwEffects and Index );\r
end;\r
\r
//*\r
//[procedure TControl.RESetFontEffect]\r
procedure TControl.RESetFontEffect(const Index: Integer;\r
  const Value: Boolean);\r
var CF: PCharFormat;\r
begin\r
  ReGetFont;\r
  CF := @fRECharFormatRec;\r
  CF.dwEffects := $FFFFFFFF and Index;\r
  if not Value then CF.dwEffects := 0;\r
  CF.dwMask := Index;\r
  Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( CF ) );\r
end;\r
\r
//*\r
//[function TControl.REGetFontAttr]\r
function TControl.REGetFontAttr(const Index: Integer): Integer;\r
var CF: PDWORD;\r
    Mask: DWORD;\r
begin\r
  REGetFont;\r
  CF := Pointer( Integer( @fRECharFormatRec ) + (HiWord(Index) and $7E) );\r
  Mask := $FFFFFFFF;\r
  if LongBool( HiWord(Index) and $1 ) then\r
    Mask := $FF;\r
  Result := CF^ and Mask;\r
end;\r
\r
//*\r
//[procedure TControl.RESetFontAttr]\r
procedure TControl.RESetFontAttr(const Index, Value: Integer);\r
{const\r
  CFE_MASK = CFE_AUTOCOLOR or CFE_BOLD or CFE_ITALIC or CFE_PROTECTED or CFE_STRIKEOUT or\r
             CFE_UNDERLINE or CFE_LINK or CFE_SUBSCRIPT or CFE_SUPERSCRIPT or}\r
var CF: PDWORD;\r
    Mask: DWORD;\r
begin\r
  REGetFont;\r
  CF := Pointer( Integer( @fRECharFormatRec ) + (HiWord(Index) and $7E) );\r
  Mask := 0;\r
  if LongBool( HiWord(Index) and $1 ) then\r
    Mask := $FFFFFF00;\r
  CF^ := CF^ and Mask or DWORD(Value);\r
  fRECharFormatRec.dwMask := Index and $FF81FFFF;\r
  if LongBool( fRECharFormatRec.dwMask and (CFM_COLOR or CFM_BACKCOLOR) ) then\r
    fRECharFormatRec.dwEffects := fRECharFormatRec.dwEffects and\r
                               not (CFE_AUTOCOLOR or CFE_AUTOBACKCOLOR);\r
  {fRECharFormatRec.dwEffects := fRECharFormatRec.dwEffects and CFE_MASK;}\r
  Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( @fRECharFormatRec ) );\r
end;\r
\r
//[procedure TControl.RESetFontAttr1]\r
procedure TControl.RESetFontAttr1(const Index, Value: Integer);\r
begin\r
  RESetFontAttr( Index, Color2RGB( Value ) );\r
end;\r
\r
//*\r
//[function TControl.REGetFontSizeValid]\r
function TControl.REGetFontSizeValid: Boolean;\r
begin\r
  Result := REGetFontMask( Integer( CFM_SIZE ) );\r
end;\r
\r
//*\r
//[function TControl.REGetFontName]\r
function TControl.REGetFontName: String;\r
begin\r
  ReGetFont;\r
  Result := fRECharFormatRec.szFaceName;\r
end;\r
\r
//*\r
//[procedure TControl.RESetFontName]\r
procedure TControl.RESetFontName(const Value: String);\r
begin\r
  ReGetFont;\r
  StrLCopy( fRECharFormatRec.szFaceName, PChar( Value ), Sizeof( fRECharFormatRec.szFaceName ) - 1 );\r
  fRECharFormatRec.dwMask := CFM_FACE;\r
  Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( @fRECharFormatRec ) );\r
end;\r
\r
//*\r
//[procedure TControl.SelectAll]\r
procedure TControl.SelectAll;\r
begin\r
  SelStart := 0;\r
  SelLength := -1; // this can be not working for some controls... //*//*\r
end;\r
\r
//*\r
//[function TControl.REGetCharformat]\r
function TControl.REGetCharformat: TCharFormat;\r
begin\r
  REGetFont;\r
  Result := fRECharFormatRec;\r
end;\r
\r
//*\r
//[procedure TControl.RESetCharFormat]\r
procedure TControl.RESetCharFormat(const Value: TCharFormat);\r
begin\r
  Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( @Value ) );\r
end;\r
\r
//*\r
//[function REOut2Stream]\r
function REOut2Stream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger )\r
  :DWORD; stdcall;\r
begin\r
  if Sz + Sender.fREStream.Position > Sender.fREStream.Size then\r
    Sender.fREStream.Size := Sender.fREStream.Size + DWORD( {Min(} Sz {, 8192 )} );\r
  pSz^ := Sender.fREStream.Write( Buf^, Sz );\r
  if Assigned( Sender.fOnProgress ) then\r
    Sender.fOnProgress( Sender );\r
  Result := 0;\r
end;\r
\r
const TextTypes: array[ TRETextFormat ] of WORD = ( SF_RTF, SF_TEXT,\r
      SF_RTF or SFF_PLAINRTF, SF_RTFNOOBJS, SF_RTFNOOBJS or SFF_PLAINRTF,\r
      SF_TEXTIZED );\r
\r
//*\r
//[function TControl.RE_SaveToStream]\r
function TControl.RE_SaveToStream(Stream: PStream; Format: TRETextFormat;\r
  SelectionOnly: Boolean): Boolean;\r
var ES: TEditStream;\r
    SelFlag: Integer;\r
begin\r
  fREStream := Stream;\r
  ES.dwCookie := Integer( @Self );\r
  ES.dwError := 0;\r
  ES.pfnCallback := @REOut2Stream;\r
  SelFlag := 0;\r
  if SelectionOnly then\r
    SelFlag := SFF_SELECTION;\r
  Perform( EM_STREAMOUT, TextTypes[ Format ] or SelFlag, Integer( @ES ) );\r
  fREStream := nil;\r
  fREError := ES.dwError;\r
  Result := fREError = 0;\r
end;\r
\r
//[procedure RE_AddText]\r
procedure RE_AddText( Self_: PControl; const S: String );\r
begin\r
  Self_.SelStart := Self_.TextSize;\r
  Self_.RE_Text[ reText, True ] := S;\r
end;\r
\r
//*\r
//[function TControl.REReadText]\r
function TControl.REReadText(Format: TRETextFormat;\r
  SelectionOnly: Boolean): String;\r
var B0: Integer;\r
    MS: PStream;\r
begin\r
  fCommandActions.aAddText := RE_AddText;\r
  MS := NewMemoryStream;\r
  RE_SaveToStream( MS, Format, SelectionOnly );\r
  B0 := 0;\r
  MS.Write( B0, 1 );\r
  Result := PChar( MS.fMemory );\r
  MS.Free;\r
end;\r
\r
//*\r
//[function REInFromStream]\r
function REInFromStream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger )\r
  :DWORD; stdcall;\r
begin\r
  {$IFDEF _D3} if Sender.fREStrLoadLen >= 0 then {$ENDIF}\r
  if Sz > Sender.fREStrLoadLen then\r
    Sz := Sender.fREStrLoadLen;\r
  pSz^ := Sender.fREStream.Read( Buf^, Sz );\r
  Dec( Sender.fREStrLoadLen, pSz^ );\r
  if Assigned( Sender.fOnProgress ) then\r
    Sender.fOnProgress( Sender );\r
  Result := 0;\r
end;\r
\r
//*\r
//[function TControl.RE_LoadFromStream]\r
function TControl.RE_LoadFromStream(Stream: PStream; Length: Integer;\r
  Format: TRETextFormat; SelectionOnly: Boolean): Boolean;\r
var ES: TEditStream;\r
    SelFlag: Integer;\r
begin\r
  fREStream := Stream;\r
  fREStrLoadLen := DWORD( Length );\r
  ES.dwCookie := Integer( @Self );\r
  ES.dwError := 0;\r
  ES.pfnCallback := @REInFromStream;\r
  SelFlag := 0;\r
  if SelectionOnly then\r
    SelFlag := SFF_SELECTION;\r
  Perform( EM_STREAMIN, TextTypes[ Format ] or SelFlag, Integer( @ES ) );\r
  fREStream := nil;\r
  fREError := ES.dwError;\r
  Result := fREError = 0;\r
end;\r
\r
//*\r
//[procedure TControl.REWriteText]\r
procedure TControl.REWriteText(Format: TRETextFormat;\r
  SelectionOnly: Boolean; const Value: String);\r
var MS: PStream;\r
begin\r
  fCommandActions.aAddText := RE_AddText;\r
  MS := NewMemoryStream;\r
  MS.fMemory := PChar( Value );\r
  MS.fData.fSize := Length( Value );\r
  MS.fData.fCapacity := MS.fData.fSize;\r
  RE_LoadFromStream( MS, MS.fData.fSize, Format, SelectionOnly );\r
  MS.fMemory := nil;\r
  MS.Free;\r
end;\r
\r
//*\r
//[function TControl.RE_LoadFromFile]\r
function TControl.RE_LoadFromFile(const Filename: String;\r
  Format: TRETextFormat; SelectionOnly: Boolean): Boolean;\r
var Strm: PStream;\r
begin\r
  Strm := NewReadFileStream( Filename );\r
  Result := RE_LoadFromStream( Strm, -1, Format, SelectionOnly );\r
  Strm.Free;\r
end;\r
\r
//*\r
//[function TControl.RE_SaveToFile]\r
function TControl.RE_SaveToFile(const Filename: String;\r
  Format: TRETextFormat; SelectionOnly: Boolean): Boolean;\r
var Strm: PStream;\r
begin\r
  Strm := NewWriteFileStream( Filename );\r
  Result := RE_SaveToStream( Strm, Format, SelectionOnly );\r
  Strm.Free;\r
end;\r
\r
//*\r
//[function TControl.REGetParaFmt]\r
function TControl.REGetParaFmt: TParaFormat;\r
begin\r
  FillChar( Result, sizeof( TParaFormat2 ), 0 );\r
  Result.cbSize := sizeof( RichEdit.TParaFormat ) + fParaFmtDeltaSz;\r
  Perform( EM_GETPARAFORMAT, 0, Integer( @Result ) );\r
end;\r
\r
//*\r
//[procedure TControl.RESetParaFmt]\r
procedure TControl.RESetParaFmt(const Value: TParaFormat);\r
begin\r
  //Value.cbSize := szTParaFmtRec;\r
  Perform( EM_SETPARAFORMAT, 0, Integer( @Value ) );\r
end;\r
\r
//*\r
//[function TControl.REGetNumbering]\r
function TControl.REGetNumbering: Boolean;\r
begin\r
  Result := LongBool( ReGetParaAttr( 9 shl 16 ) );\r
end;\r
\r
//*\r
//[function TControl.REGetParaAttr]\r
function TControl.REGetParaAttr( const Index: Integer ): Integer;\r
var pDw : PDWORD;\r
begin\r
  fREParaFmtRec := REGetParaFmt;\r
  pDw := Pointer( Integer( @fREParaFmtRec ) + ( HiWord( Index ) and $7E ) );\r
  Result := pDw^;\r
  if LongBool( HiWord( Index ) and 1 ) then\r
    Result := Result and $FFFF;\r
end;\r
\r
//*\r
//[function TControl.REGetParaAttrValid]\r
function TControl.REGetParaAttrValid( const Index: Integer ): Boolean;\r
begin\r
  Result := LongBool( ReGetParaAttr( 4 shl 16 ) and Index );\r
end;\r
\r
//*\r
//[function TControl.REGetTabCount]\r
function TControl.REGetTabCount: Integer;\r
begin\r
  Result := ReGetParaAttr( 27 shl 16 );\r
end;\r
\r
//*\r
//[function TControl.REGetTabs]\r
function TControl.REGetTabs(Idx: Integer): Integer;\r
begin\r
  Result := ReGetParaAttr( (28 + 4 * Idx) shl 16 );\r
end;\r
\r
//*\r
//[function TControl.REGetTextAlign]\r
function TControl.REGetTextAlign: TRichTextAlign;\r
begin\r
  Result := TRichTextAlign( ReGetParaAttr( 25 shl 16 ) - 1 );\r
end;\r
\r
//*\r
//[procedure TControl.RESetNumbering]\r
procedure TControl.RESetNumbering(const Value: Boolean);\r
begin\r
  RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Integer( Value ) );\r
end;\r
\r
//*\r
//[procedure TControl.RESetParaAttr]\r
procedure TControl.RESetParaAttr(const Index, Value: Integer);\r
var pDw: PDWORD;\r
    Mask: Integer;\r
begin\r
  REGetParaAttr( 0 );\r
  pDw := Pointer( Integer( @fREParaFmtRec ) + ( HiWord( Index ) and $7E ) );\r
  Mask := 0;\r
  if LongBool( HiWord( Index ) and 1 ) then\r
    Mask := Integer( $FFFF0000 );\r
  pDw^ := pDw^ and Mask or DWORD(Value);\r
  //////////////////////////////////////////////////////////////////////////////\r
    fREParaFmtRec.dwMask := Index and $8000FFFF;\r
  //////////////////////////////////////////////////////////////////////////////\r
  //fREParaFmtRec.dwMask := DWORD( Index ) or $8000FFFF;                      //\r
  //////////////////////////////////////////////////////////////////////////////\r
  RESetParaFmt( fREParaFmtRec );\r
end;\r
\r
//*\r
//[procedure TControl.RESetTabCount]\r
procedure TControl.RESetTabCount(const Value: Integer);\r
begin\r
  REGetParaAttr( 0 );\r
  RESetParaAttr( (27 shl 16) or PFM_TABSTOPS, Value );\r
end;\r
\r
//*\r
//[procedure TControl.RESetTabs]\r
procedure TControl.RESetTabs(Idx: Integer; const Value: Integer);\r
begin\r
  REGetParaAttr( 0 );\r
  RESetParaAttr( (28 + 4 * Idx) or PFM_TABSTOPS, Value );\r
end;\r
\r
//*\r
//[procedure TControl.RESetTextAlign]\r
procedure TControl.RESetTextAlign(const Value: TRichTextAlign);\r
begin\r
  RESetParaAttr( (25 shl 16) or PFM_ALIGNMENT, Ord( Value ) + 1 );\r
end;\r
\r
//*\r
//[function TControl.REGetStartIndentValid]\r
function TControl.REGetStartIndentValid: Boolean;\r
begin\r
  Result := REGetParaAttrValid( Integer( PFM_STARTINDENT ) );\r
end;\r
\r
//*\r
//[procedure TControl.RE_HideSelection]\r
procedure TControl.RE_HideSelection(aHide: Boolean);\r
begin\r
  Perform( EM_HIDESELECTION, Integer( aHide ), 1 );\r
end;\r
\r
//*\r
//[function TControl.RE_SearchText]\r
function TControl.RE_SearchText(const Value: String; MatchCase,\r
  WholeWord, ScanForward: Boolean; SearchFrom, SearchTo: Integer): Integer;\r
var Flags: Integer;\r
    FT: TFindText;\r
begin\r
  Flags := Integer( ScanForward );\r
  if WholeWord then Flags := Flags or FT_WHOLEWORD;\r
  if MatchCase then Flags := Flags or FT_MATCHCASE;\r
  FT.chrg.cpMin := SearchFrom;\r
  FT.chrg.cpMax := SearchTo;\r
  FT.lpstrText := PChar( Value );\r
  Result := Perform( EM_FINDTEXT, Flags, Integer( @FT ) );\r
end;\r
\r
//*\r
//[function TControl.CanUndo]\r
function TControl.CanUndo: Boolean;\r
begin\r
  Result := LongBool( Perform( EM_CANUNDO, 0, 0 ) );\r
end;\r
\r
//*\r
//[procedure TControl.EmptyUndoBuffer]\r
procedure TControl.EmptyUndoBuffer;\r
begin\r
  Perform( EM_EMPTYUNDOBUFFER, 0, 0 );\r
end;\r
\r
//*\r
//[function TControl.Undo]\r
function TControl.Undo: Boolean;\r
begin\r
  Result := LongBool( Perform( EM_UNDO, 0, 0 ) );\r
end;\r
\r
//*\r
//[function TControl.RE_Redo]\r
function TControl.RE_Redo: Boolean;\r
begin\r
  Result := LongBool( Perform( EM_REDO, 0, 0 ) );\r
end;\r
\r
//*\r
//[function TControl.REGetAutoURLDetect]\r
function TControl.REGetAutoURLDetect: Boolean;\r
begin\r
  Result := LongBool( Perform( EM_GETAUTOURLDETECT, 0, 0 ) );\r
end;\r
\r
//*\r
//[procedure TControl.RESetAutoURLDetect]\r
procedure TControl.RESetAutoURLDetect(const Value: Boolean);\r
begin\r
  AttachProc( WndProc_RE_LinkNotify );\r
  Perform( EM_AUTOURLDETECT, Integer( Value ), 0 );\r
end;\r
\r
//*\r
//[function TControl.GetMaxTextSize]\r
function TControl.GetMaxTextSize: DWORD;\r
begin\r
  Result := Perform( EM_GETLIMITTEXT, 0, 0 );\r
end;\r
\r
//*\r
//[procedure TControl.SetMaxTextSize]\r
procedure TControl.SetMaxTextSize(const Value: DWORD);\r
var V1, V2: Integer;\r
begin\r
  if fCommandActions.aSetLimit <> 0 then\r
  begin\r
    V1 := 0; V2 := Value;\r
    if fCommandActions.aSetLimit = EM_SETLIMITTEXT then\r
    begin\r
      V1 := Value; V2 := 0;\r
    end;\r
    Perform( fCommandActions.aSetLimit, V1, V2 );\r
  end;\r
end;\r
\r
//*\r
//[function WndProc_REFmt]\r
function WndProc_REFmt( _Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Mask: Integer;\r
    Shft, Flg: Boolean;\r
    Delta: Integer;\r
    TA: TRichTextAlign;\r
    ChgTA: Boolean;\r
    US: TRichUnderline;\r
    NS: TRichNumbering;\r
    NB: TRichNumBrackets;\r
    Side: TBorderEdge;\r
    Param: DWORD;\r
begin\r
  Result := False;\r
  if Msg.message = WM_CHAR then\r
  if _Self_.FSupressTab then\r
  begin\r
    _Self_.FSupressTab := FALSE;\r
    if Msg.wParam = 9 then\r
    begin\r
      Result := TRUE;\r
      Exit;\r
    end;\r
  end;\r
\r
  if Msg.message = WM_KEYDOWN then\r
  if GetKeyState( VK_CONTROL ) < 0 then\r
  begin\r
    Shft := GetKeyState( VK_SHIFT ) < 0;\r
    Rslt := 0;\r
    Result := True;\r
    Mask := 0;\r
    ChgTA := False; TA := raLeft;\r
    Param := Msg.wParam;\r
    //Msg.wParam := 0;\r
    case Param of\r
    Integer('Z'):\r
      begin\r
        if Shft then\r
        begin\r
          _Self_.RE_Redo;\r
          Exit;\r
        end;\r
        Result := False;\r
      end;\r
\r
    Integer('L'): begin ChgTA := True; TA := raLeft; end;\r
    Integer('R'): begin ChgTA := True; TA := raRight; end;\r
    Integer('E'): begin ChgTA := True; TA := raCenter; end;\r
    Integer('J'): begin ChgTA := True; TA := raJustify; end;\r
    Integer('N'): begin\r
                    if Shft then\r
                    begin\r
                      NS := _Self_.RE_NumStyle;\r
                      NB := _Self_.RE_NumBrackets;\r
                      if NS = rnBullets then\r
                      begin\r
                        _Self_.RE_NumStyle := rnNone;\r
                        Exit;\r
                      end;\r
                      if NS = rnNone then\r
                      begin\r
                        _Self_.RE_NumStyle := rnBullets;\r
                        //NB := rnbPlain;\r
                        Exit;\r
                      end\r
                         else\r
                      if Ord( NB ) = 0  then\r
                        NB := High(NB)  else\r
                        NB := Pred(NB);\r
                      _Self_.RE_NumBrackets := NB;\r
                    end\r
                       else\r
                    begin\r
                      NS := _Self_.RE_NumStyle;\r
                      if Ord( NS ) = 0 then\r
                      begin\r
                        NS := rnURoman; //rnULetter; //High( NS );\r
                        { because rnLRoman, rnURoman, rnNoNumber are not shown\r
                          in RichEdit. }\r
                        _Self_.RE_NumBrackets := rnbPeriod;\r
                      end              else\r
                        NS := Pred(NS);\r
                      _Self_.RE_NumStyle := NS;\r
                      if NS in [ rnLRoman, rnURoman, rnArabic ] then\r
                        _Self_.RE_NumStart := 1;\r
                    end;\r
                    Exit;\r
                  end;\r
    Integer('W'): begin\r
                    Delta := _Self_.RE_BorderWidth[ beLeft ] + 4;\r
                    if Shft then Delta := -1;\r
                    for Side := Low(Side) to High(Side) do\r
                    begin\r
                      if Delta < 0 then\r
                        _Self_.RE_BorderStyle[ Side ] := _Self_.RE_BorderStyle[ Side ] + 1\r
                      else\r
                      begin\r
                        _Self_.RE_BorderWidth[ Side ] := Delta;\r
                        _Self_.RE_BorderSpace[ Side ] := Delta;\r
                      end;\r
                    end;\r
                    Exit;\r
                  end;\r
    (* TABLES STUFF -- to try, uncomment it and press CTRL+T in RichEdit.\r
       (and uncomment declaration for Tmp above).\r
\r
       Not finished, and seems no way to figure it out - even RichEdit20.dll\r
       (i.e. Rich Edit v3.0) can not display tables properly formatted. :(((\r
\r
    Integer('T'): begin\r
                    if _Self_.RE_Table then\r
                    begin\r
                      //MsgOK( 'table' );\r
                    end;\r
                    Tmp := _Self_.REReadText( reRTF, True );\r
                    if StrIsStartingFrom( PChar(Tmp), '{\rtf' )\r
                    and (CopyTail( Tmp, 3 ) = '}'#$D#$A) then\r
                    begin\r
                      //Tmp := Copy( Tmp, 1, Length(Tmp) - 3 );\r
                      _Self_.RE_Text[ reRTF, True ] :=  '{\rtf1' + //Copy( Tmp, 1, 6 ) +\r
    '\trowd' +\r
    //'\lytcalctblwd' +\r
    //'\oldlinewrap' +\r
    //'\alntblind' +\r
    //'\trgaph108' +\r
    '\trleft-108' +\r
    {'\trbrdrt\brdrs\brdrw10' +\r
    '\trbrdrl\brdrs\brdrw10' +\r
    '\trbrdrb\brdrs\brdrw10' +\r
    '\trbrdrr\brdrs\brdrw10' +\r
    '\trbrdrh\brdrs\brdrw10' +\r
    '\trbrdrv\brdrs\brdrw10' +}\r
    //'\clvertalt' +\r
    {'\clbrdrt\brdrs\brdrw10' +\r
    '\clbrdrl\brdrs\brdrw10' +\r
    '\clbrdrb\brdrs\brdrw10' +\r
    '\clbrdrr\brdrs\brdrw10' +}\r
    //'\cltxlrtb' +\r
    '\cellx1414' +\r
    //'\pard' +\r
    //'\plain' +\r
    //'\widctlpar' +\r
    '\trautofit1' +\r
    '\intbl' +\r
    //'\adjustright' +\r
    //'\fs20\lang1049' +\r
    //'\cgrid' +\r
    '\trrh0' +\r
    '{\clFitText{{\box\brdrs\brdrw20\brsp20}'+\r
    '\par}\cell\row}' +\r
    //'\pard\widctlpar' +\r
    //'\intbl'+\r
    //'\adjustright'+\r
    //'{\row}' +\r
    '\pard\widctlpar' +\r
                             '}'#$D#$A;\r
                      _Self_.Perform( WM_KEYDOWN, VK_UP, 0 );\r
                      _Self_.Perform( WM_KEYUP, VK_UP, 0 );\r
                    end;\r
                    Exit;\r
                  end;\r
    *)\r
    Integer('B'): Mask := CFM_BOLD;\r
    Integer('I'):\r
      begin\r
        Mask := CFM_ITALIC;\r
        _Self_.FSupressTab := TRUE;\r
      end;\r
    Integer('U'):\r
      begin\r
        if Shft then\r
        begin\r
          US := _Self_.RE_FmtUnderlineStyle;\r
          if Ord(US) = 0 then US := High(TRichUnderLine)\r
          else US := Pred( US );\r
          _Self_.RE_FmtUnderlineStyle := US;\r
          Exit;\r
        end;\r
        Mask := CFM_UNDERLINE;\r
      end;\r
    Integer('O'): Mask := CFM_STRIKEOUT;\r
    VK_SUBTRACT, VK_ADD: Mask := Integer( CFM_SIZE );\r
    else\r
      begin\r
        Result := False;\r
        Msg.wParam := Param;\r
      end;\r
    end;\r
    if not Result then Exit;\r
\r
    if ChgTA then\r
      begin\r
        if Shft then Result := False\r
        else _Self_.RE_TextAlign := TA;\r
        Exit;\r
      end;\r
\r
    _Self_.REGetFont;\r
    if Mask > 0 then\r
    begin\r
      if Shft then Result := False\r
      else begin\r
             Flg := _Self_.REGetFontEffects( Mask );\r
             if not Flg then\r
               _Self_.fRECharFormatRec.dwEffects := _Self_.fRECharFormatRec.dwEffects and not Mask;\r
             _Self_.fRECharFormatRec.dwEffects := _Self_.fRECharFormatRec.dwEffects xor DWORD(Mask);\r
           end;\r
    end\r
       else\r
    begin\r
      if Msg.wParam = VK_SUBTRACT then\r
        Delta := -1\r
      else\r
        Delta := 1;\r
      if Shft then\r
        Mask := CFM_OFFSET;\r
      if Shft then\r
        Inc( _Self_.fRECharFormatRec.yOffset, Delta * _Self_.fRECharFormatRec.yHeight div 3 )\r
      else\r
        Inc( _Self_.fRECharFormatRec.yHeight, Delta * _Self_.fRECharFormatRec.yHeight div 8 );\r
      Flg := LongBool( _Self_.fRECharFormatRec.dwMask and Mask );\r
      if not Flg then\r
        _Self_.fRECharFormatRec.yOffset := 0;\r
    end;\r
    _Self_.fRECharFormatRec.dwMask := Mask;\r
    _Self_.Perform( EM_SETCHARFORMAT, SCF_SELECTION { RichAreas[ _Self_.fRECharArea ] }, Integer( @_Self_.fRECharFormatRec ) );\r
  end;\r
end;\r
\r
//*\r
//[function TControl.RE_FmtStandard]\r
function TControl.RE_FmtStandard: PControl;\r
begin\r
  AttachProc( WndProc_REFmt );\r
  Result := @Self;\r
end;\r
\r
//[FUNCTION EnumDynHandlers]\r
{$IFDEF ASM_VERSION}\r
function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
asm     //cmd    //opd\r
        CMP      [EAX].TControl.fRefCount, 0\r
        JL       @@fin_false\r
        PUSHAD\r
        MOV      EBX, EAX\r
        MOV      EBP, ECX\r
        MOV      ECX, [EBX].TControl.fDynHandlers\r
        JECXZ    @@ret_false\r
        MOV      ESI, ECX\r
        MOV      ECX, [ESI].TList.fCount\r
        JECXZ    @@ret_false\r
        MOV      EDI, ECX\r
        SHR      EDI, 1\r
        CALL     TControl.RefInc\r
@@loo:  DEC      EDI\r
        JS       @@e_loo\r
        PUSH     EDX\r
        PUSH     EBX\r
{$IFNDEF ENUM_DYN_HANDLERS_AFTER_RUN}\r
        XOR      EAX, EAX\r
        CMP      [AppletTerminated], AL\r
        JZ       @@do_call\r
        MOV      ECX, [ESI].TList.fItems\r
        MOV      ECX, [ECX+EDI*8+4]\r
        JECXZ    @@skip_call\r
{$ENDIF}\r
@@do_call:\r
        MOV      EAX, [ESI].TList.fItems\r
        MOV      EAX, [EAX+EDI*8]\r
        XCHG     EAX, EBX\r
        MOV      ECX, EBP\r
        CALL     EBX\r
@@skip_call:\r
        POP      EBX\r
        POP      EDX\r
        TEST     AL, AL\r
        JZ       @@loo\r
@@ret_true:\r
        MOV      EAX, EBX\r
        CALL     TControl.RefDec\r
        POPAD\r
        MOV      AL, 1\r
        RET\r
@@e_loo:\r
        XOR      EAX, EAX\r
        INC      EAX\r
        CMP      [EBX].TControl.fRefCount, EAX\r
        JE       @@ret_true\r
        MOV      EAX, EBX\r
        CALL     TControl.RefDec\r
@@ret_false:\r
        POPAD\r
@@fin_false:\r
        XOR      EAX, EAX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var I: Integer;\r
    Proc: TWindowFunc;\r
begin\r
  Result := False;\r
  if Self_.fRefCount < 0 then Exit;\r
  if (Self_.fDynHandlers = nil) or (Self_.fDynHandlers.fCount = 0) then Exit;\r
  Self_.RefInc; // Prevent destroying Self_\r
  for I := Self_.fDynHandlers.fCount div 2 - 1 downto 0 do\r
  begin\r
    Proc := Self_.fDynHandlers.fItems[ I * 2 ];\r
{$IFNDEF ENUM_DYN_HANDLERS_AFTER_RUN}\r
    if not AppletTerminated or (Self_.fDynHandlers.fItems[ I * 2 + 1 ] <> nil) then\r
{$ENDIF}\r
    if Proc( Self_, Msg, Rslt ) then\r
    begin\r
      Result := True;\r
      break;\r
    end;\r
  end;\r
  {$IFDEF DEBUG_ENDSESSION}\r
  if EndSession_Initiated then\r
  begin\r
    LogFileOutput( GetStartDir + 'es_debug.txt',\r
                   'ENUM_DYN_HANDLERS: Self_:' + Int2Hex( DWORD( Self_ ), 8 ) );\r
    LogFileOutput( GetStartDir + 'es_debug.txt',\r
                   'ENUM_DYN_HANDLERS: Self_.fRefCount:' + Int2Str( Self_.fRefCount ) );\r
  end;\r
  {$ENDIF}\r
  if LongBool(Self_.fRefCount and 1) then\r
    Result := True; // If Self_ will be destroyed now, stop further processing\r
  Self_.RefDec; // Destroy Self_, if Free was called for it while processing attached procedures\r
end;\r
{$ENDIF ASM_VERSION}\r
//[END EnumDynHandlers]\r
\r
{$IFDEF ASM_VERSION}\r
//[procedure TControl.AttachProcEx]\r
procedure TControl.AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );\r
asm     //cmd    //opd\r
        PUSH     EBX\r
        PUSH     EDI\r
        PUSH     ECX\r
        XCHG     EBX, EAX\r
        MOV      EDI, EDX\r
        MOV      [EBX].fOnDynHandlers, offset[EnumDynHandlers]\r
        MOV      ECX, [EBX].TControl.fDynHandlers\r
        INC      ECX\r
        LOOP     @@1\r
        CALL     NewList\r
        XCHG     ECX, EAX\r
        MOV      [EBX].TControl.fDynHandlers, ECX\r
@@1:\r
        PUSH     ECX\r
        MOV      EAX, EBX\r
        MOV      EDX, EDI\r
        CALL     TControl.IsProcAttached\r
        TEST     AL, AL\r
        POP      EBX\r
        JNZ      @@exit\r
        MOV      EAX, EBX\r
        MOV      EDX, EDI\r
        CALL     TList.Add\r
        XCHG     EAX, EBX\r
        POP      EDX\r
        PUSH     EDX\r
        CALL     TList.Add\r
@@exit:\r
        POP      ECX\r
        POP      EDI\r
        POP      EBX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
procedure TControl.AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );\r
begin\r
  if fDynHandlers = nil then\r
    fDynHandlers := NewList;\r
  if not IsProcAttached( Proc ) then\r
  begin\r
    fDynHandlers.Add( @Proc );\r
    fDynHandlers.Add( Pointer( Integer( ExecuteAfterAppletTerminated ) ) );\r
  end;\r
  fOnDynHandlers := EnumDynHandlers;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[procedure TControl.AttachProc]\r
procedure TControl.AttachProc(Proc: TWindowFunc);\r
begin\r
  AttachProcEx( Proc, FALSE );\r
end;\r
\r
//*\r
//[procedure TControl.DetachProc]\r
procedure TControl.DetachProc(Proc: TWindowFunc);\r
var I: Integer;\r
begin\r
  if fDynHandlers = nil then Exit;\r
  I := fDynHandlers.IndexOf( @Proc );\r
  if I >=0 then\r
  begin\r
    fDynHandlers.Delete( I );\r
    fDynHandlers.Delete( I );\r
  end;\r
end;\r
\r
{$IFDEF ASM_VERSION}\r
//[function TControl.IsProcAttached]\r
function TControl.IsProcAttached(Proc: TWindowFunc): Boolean;\r
asm     //cmd    //opd\r
        MOV      ECX, [EAX].TControl.fDynHandlers\r
        JECXZ    @@exit\r
        XCHG     EAX, ECX\r
        CALL     TList.IndexOf\r
        TEST     EAX, EAX\r
        SETGE    CL\r
@@exit: XCHG     EAX, ECX\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TControl.IsProcAttached(Proc: TWindowFunc): Boolean;\r
var I: Integer;\r
begin\r
  Result := False;\r
  if fDynHandlers = nil then Exit;\r
  I := fDynHandlers.IndexOf( @Proc );\r
  Result := I >=0;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function WndProcAutoPopupMenu]\r
function WndProcAutoPopupMenu( Control: PControl; var Msg: TMsg; var MsgRslt: Integer ): Boolean;\r
var R: TRect;\r
    M: Word;\r
    I: Integer;\r
    P: TPoint;\r
begin\r
  if (Msg.message = WM_CONTEXTMENU) and\r
     (Control.fAutoPopupMenu <> nil) then\r
  begin\r
    {$IFDEF USE_MENU_CURCTL}\r
    PMenu( Control.fAutoPopupMenu ).fCurCtl := Control;\r
    {$ENDIF USE_MENU_CURCTL}\r
    P.X := SmallInt( LoWord( Msg.lParam ) );\r
    P.Y := SmallInt( HiWord( Msg.lParam ) );\r
    if (Msg.lParam = -1) then\r
    begin\r
      I := Control.CurIndex;\r
      M := Control.fCommandActions.aItem2XY;\r
      if (I >= 0) and (M <> 0) then\r
      begin\r
        CASE M OF\r
        EM_POSFROMCHAR:\r
          begin\r
            I := Control.SelStart + Control.SelLength;\r
            // Edit or Rich Edit 2:\r
            I := Control.Perform( M, I, 1 );\r
            P.X := SmallInt( LoWord( I ) );\r
            P.Y := SmallInt( HiWord( I ) );\r
          end;\r
        LB_GETITEMRECT, LVM_GETITEMRECT, TCM_GETITEMRECT:\r
          begin\r
            R.Left := LVIR_BOUNDS;\r
            Control.Perform( M, I, Integer( @ R ) );\r
            P.X := R.Left;\r
            P.Y := R.Bottom;\r
          end;\r
        TVM_GETITEMRECT:\r
          begin\r
            I := Control.TVSelected;\r
            R.Left := I;\r
            Control.Perform( M, 1, Integer( @ R ) );\r
            P.X := R.Left;\r
            P.Y := R.Bottom;\r
          end;\r
        END;\r
        R := Control.ClientRect;\r
        if P.X < R.Left then P.X := R.Left;\r
        if P.X > R.Right then P.X := R.Right;\r
        if P.Y < R.Top then P.Y := R.Top;\r
        if P.Y > R.Bottom then P.Y := R.Bottom;\r
      end;\r
      P := Control.Client2Screen( P );\r
    end;\r
    PMenu( Control.fAutoPopupMenu ).Popup( P.X, P.Y );\r
    Result := TRUE;\r
  end\r
    else\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.SetAutoPopupMenu]\r
procedure TControl.SetAutoPopupMenu(PopupMenu: PObj);\r
{ new version - by Alexander Pravdin. Allows to attach a submenu (e.g. of the\r
  main menu) as a popup menu to a control, to avoid duplicating menu object,\r
  if it is the same already as desired. }\r
var pm: PMenu;\r
begin\r
  if PopupMenu <> nil then\r
  {$IFDEF USE_MENU_CURCTL}\r
  begin\r
    pm := PMenu( PopupMenu );\r
    if ( pm.FParent <> nil ) then\r
    begin\r
      while pm.FControl = nil do\r
        pm := pm.FParent;\r
      PMenu( PopupMenu ).FControl := pm.FControl;\r
    end\r
    else\r
    begin\r
      PMenu( PopupMenu ).FControl := @Self;\r
    end;\r
    AttachProc(WndProcAutoPopupMenu);\r
    AttachProc(WndProcMenu)\r
  end\r
  else begin\r
    DetachProc(WndProcAutoPopupMenu);\r
    DetachProc(WndProcMenu);\r
  end;\r
  {$ELSE}\r
  begin\r
    pm := PMenu( PopupMenu );\r
    while pm.FControl = nil do pm := pm.Parent;\r
    PMenu( PopupMenu ).FControl := pm.FControl;\r
  end;\r
  {$ENDIF}\r
  fAutoPopupMenu := PopupMenu;\r
  {$IFNDEF USE_MENU_CURCTL}\r
  AttachProc( WndProcAutoPopupMenu );\r
  {$ENDIF}\r
end;\r
\r
//[function SearchAnsiMnemonics]\r
function SearchAnsiMnemonics( const S: String ): String;\r
var I: Integer;\r
    Sh: ShortInt;\r
begin\r
  Result := S;\r
  for I := 1 to Length( Result ) do\r
  begin\r
    Sh := VkKeyScanEx( Result[ I ], MnemonicsLocale );\r
    if Sh <> -1 then\r
      Result[ I ] := Char( Sh );\r
  end;\r
end;\r
\r
//[procedure SupportAnsiMnemonics]\r
procedure SupportAnsiMnemonics( LocaleID: Integer );\r
begin\r
  MnemonicsLocale := LocaleID;\r
  SearchMnemonics := SearchAnsiMnemonics;\r
end;\r
\r
//[function WndProcMnemonics]\r
function WndProcMnemonics( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Form: PControl;\r
\r
  function HandleMnenonic( Prnt: PControl ): Boolean;\r
  var C: PControl;\r
      XY: Integer;\r
      procedure DoPressMnemonic;\r
      begin\r
        if Msg.message = WM_SYSKEYDOWN then\r
        begin\r
          Form.FPressedMnemonic := Msg.wParam;\r
          C.Perform( WM_LBUTTONDOWN, MK_LBUTTON, XY );\r
        end\r
          else\r
        begin\r
          Form.FPressedMnemonic := 0;\r
          C.Perform( WM_LBUTTONUP, MK_LBUTTON, XY );\r
        end;\r
      end;\r
  var I, J: Integer;\r
      R: TRect;\r
  begin\r
    for I := 0 to Prnt.ChildCount-1 do\r
    begin\r
      C := Prnt.Children[ I ];\r
      if C.IsButton then\r
      if C.Enabled then\r
      begin\r
        if C.fCommandActions.aGetCount = TB_BUTTONCOUNT then\r
        for J := 0 to C.Count-1 do\r
        begin\r
          if C.TBButtonEnabled[ J ] then\r
          if pos( '&' + Char( Msg.wParam ), SearchMnemonics( C.TBButtonText[ J ] ) ) > 0 then\r
          begin\r
            C.fCurIndex := J;\r
            C.fCurItem := C.TBIndex2Item( J );\r
            R := C.TBButtonRect[ J ];\r
            XY := R.Left or (R.Top shl 16);\r
            DoPressMnemonic;\r
            Result := TRUE;\r
            Exit;\r
          end;\r
        end;\r
        if pos( '&' + Char( Msg.wParam ), SearchMnemonics( C.Caption ) ) > 0 then\r
        begin\r
          XY := 0;\r
          DoPressMnemonic;\r
          Result := TRUE;\r
          Exit;\r
        end;\r
      end;\r
      if HandleMnenonic( C ) then\r
      begin\r
        Result := TRUE;\r
        Exit;\r
      end;\r
    end;\r
    Result := FALSE;\r
  end;\r
\r
{$IFDEF NEW_MENU_ACCELL}\r
  function FindByCtlRef(C: PControl; Accell: TMenuAccelerator): Boolean;\r
\r
    function FindInMenu(M: PMenu): PMenu;\r
    var\r
      I: Integer;\r
      SM: PMenu;\r
    begin\r
      for I := 0 to M.FItems.Count - 1 do begin\r
        Result := M.FItems.Items[I];\r
        if (Cardinal(Result.Accelerator) = Cardinal(Accell)) and Result.Enabled then\r
          Exit;\r
      end;\r
      Result := nil;\r
      for I := 0 to M.FItems.Count - 1 do begin\r
        SM := PMenu(M.FItems.Items[I]);\r
        if (SM.FItems.Count > 0) then\r
          Result := FindInMenu(SM);\r
        if (Result <> nil) then\r
          Break;\r
      end;\r
    end;\r
\r
    function FindInMenu2(M: PMenu): Boolean;\r
    var\r
      MI: PMenu;\r
    begin\r
      if (M <> nil) then begin\r
        MI := FindInMenu(M);\r
        if (MI <> nil) then begin\r
          //M.FControl.Perform(WM_COMMAND, MI.FId, 0);\r
          C.Perform(WM_COMMAND, MI.FId, 0); // fixed\r
          Result := True;\r
          Exit;\r
        end;\r
      end;\r
      Result := False;\r
    end;\r
\r
  var\r
    Parent: PControl;\r
  begin\r
    Result := False;\r
    if not FindInMenu2(PMenu(C.fAutoPopupMenu)) then\r
      if not FindInMenu2(PMenu(C.fMenuObj)) then begin\r
        Parent := C.Parent;\r
        if (Parent <> nil) then\r
          Result := FindByCtlRef(Parent, Accell);\r
      end;\r
  end;\r
\r
var\r
  Ac: TMenuAccelerator;\r
{$ENDIF}\r
begin\r
  Result := FALSE;\r
  if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then\r
  begin\r
{$IFDEF NEW_MENU_ACCELL}\r
    Ac := MakeAccelerator(FVIRTKEY or GetShiftState, Msg.wParam);\r
    Result := FindByCtlRef(Sender, Ac);\r
{$ELSE}\r
    if Sender.fAccelTable <> 0 then\r
      Result := LongBool( TranslateAccelerator( Sender.fHandle, Sender.fAccelTable, Msg ) );\r
    if not Result then\r
    begin\r
      if Sender.fCurrentControl <> nil then\r
      if Sender.fCurrentControl.fAccelTable <> 0 then\r
        Result := LongBool( TranslateAccelerator( Sender.fCurrentControl.fHandle,\r
                            Sender.fCurrentControl.fAccelTable, Msg ) );\r
    end;\r
    if not Result then\r
    begin\r
      Form := Sender.ParentForm;\r
      if Form <> nil then\r
      if Form.fAccelTable <> 0 then\r
        Result := LongBool( TranslateAccelerator( Form.fHandle,\r
                            Form.fAccelTable, Msg ) );\r
    end;\r
{$ENDIF}\r
  end;\r
  if Result then Exit;\r
  if (Msg.message = WM_SYSKEYUP) or\r
     (Msg.message = WM_SYSKEYDOWN) and (GetKeyState( VK_MENU ) < 0) then\r
  begin\r
    Rslt := 0;\r
    Form := Sender.ParentForm;\r
    if Form <> nil then\r
    begin\r
      { ----------------------- }\r
      //Form.Caption := Form.Caption + '<';\r
        if Char( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then\r
        begin\r
          if HandleMnenonic( Form ) then\r
          begin\r
            Result := TRUE;\r
            Exit;\r
          end\r
            else\r
          begin\r
            { ---------------------- }\r
            //Form.Caption := Form.Caption + '?';\r
          end;\r
        end;\r
    end;\r
  end\r
    else\r
  if Msg.message = WM_KEYUP then\r
  begin\r
    Rslt := 0;\r
    Form := Sender.ParentForm;\r
    if Form <> nil then\r
    begin\r
      { ------------------------ }\r
      //Form.Caption := Form.Caption + '>';\r
        if Msg.wParam = VK_MENU then\r
        begin\r
              if Form.FPressedMnemonic <> 0 then\r
                Form.FPressedMnemonic := Form.FPressedMnemonic or $80000000;\r
        end\r
          else\r
        if Char( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then\r
        begin\r
            if HandleMnenonic( Form ) then\r
            begin\r
              Result := TRUE;\r
              Exit;\r
            end\r
              else\r
            begin\r
              { --------------------- }\r
              //Form.Caption := form.Caption + '-';\r
            end;\r
        end;\r
    end;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[function TControl.SupportMnemonics]\r
function TControl.SupportMnemonics: PControl;\r
begin\r
  fGlobalProcKeybd := WndProcMnemonics;\r
  Result := @Self;\r
end;\r
\r
//*\r
//[API RevokeDragDrop]\r
function RevokeDragDrop(wnd: HWnd): HResult; stdcall;\r
  external 'ole32.dll' name 'RevokeDragDrop';\r
\r
//*\r
//[function TControl.RE_NoOLEDragDrop]\r
function TControl.RE_NoOLEDragDrop: PControl;\r
begin\r
  RevokeDragDrop( Handle );\r
  Result := @Self;\r
end;\r
\r
//*\r
//[function WndProcOnResize]\r
function WndProcOnResize( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  if Msg.message = WM_SIZE then\r
  begin\r
    if Assigned( Self_.fOnResize ) then\r
      Self_.fOnResize( Self_ );\r
  end;\r
  Result := False;\r
end;\r
\r
//*\r
//[procedure TControl.SetOnResize]\r
procedure TControl.SetOnResize(const Value: TOnEvent);\r
begin\r
  FOnResize := Value;\r
  AttachProc( WndProcOnResize );\r
end;\r
\r
//[function WndProcMove]\r
function WndProcMove( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  if Msg.message = WM_MOVE then\r
  begin\r
    if Assigned( Self_.FOnMove ) then\r
      Self_.FOnMove( Self_ );\r
  end;\r
  Result := False;\r
end;\r
\r
//[procedure TControl.SetOnMove]\r
procedure TControl.SetOnMove(const Value: TOnEvent);\r
begin\r
  FOnMove := Value;\r
  AttachProc( WndProcMove );\r
end;\r
\r
//[function WndProc_REBottomless]\r
function WndProc_REBottomless( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  if Msg.message = WM_SIZE then\r
    Self_.Perform( EM_REQUESTRESIZE, 0, 0 );\r
  Result := False;\r
end;\r
\r
//*\r
//[function TControl.RE_Bottomless]\r
function TControl.RE_Bottomless: PControl;\r
begin\r
  AttachProc( WndProc_REBottomless );\r
  Result := @Self;\r
end;\r
\r
//*\r
//[procedure TControl.RE_Append]\r
procedure TControl.RE_Append(const S: String; ACanUndo: Boolean);\r
begin\r
  SelStart := TextSize;\r
  if S <> '' then\r
  begin\r
    ReplaceSelection( S, ACanUndo );\r
    SelStart := TextSize;\r
  end;\r
end;\r
\r
//*\r
//[procedure TControl.RE_InsertRTF]\r
procedure TControl.RE_InsertRTF(const S: String);\r
var MS: PStream;\r
begin\r
  MS := NewMemoryStream;\r
  MS.Size := Length( S ) + 1;\r
  Move( S[ 1 ], MS.Memory^, Length( S ) + 1 );\r
  RE_LoadFromStream( MS, Length( S ), reRTF, TRUE );\r
  MS.Free;\r
end;\r
\r
//*\r
//[procedure TControl.DoSelChange]\r
procedure TControl.DoSelChange;\r
begin\r
  if Assigned( fOnSelChange ) then fOnSelChange( @Self )\r
  else\r
  if Assigned( fOnChange ) then fOnChange( @Self );\r
end;\r
\r
//*\r
//[function TControl.REGetUnderlineEx]\r
function TControl.REGetUnderlineEx: TRichUnderline;\r
begin\r
  Result := TRichUnderline( REGetFontAttr( (81 shl 16) or CFM_UNDERLINETYPE ) - 1 );\r
end;\r
\r
//*\r
//[procedure TControl.RESetUnderlineEx]\r
procedure TControl.RESetUnderlineEx(const Value: TRichUnderline);\r
begin\r
  RESetFontAttr( (81 shl 16) or CFM_UNDERLINETYPE, Ord( Value ) + 1 );\r
  RESetFontEffect( CFM_UNDERLINE, True );\r
end;\r
\r
//*\r
//[function TControl.GetTextSize]\r
function TControl.GetTextSize: Integer;\r
begin\r
  Result := 0;\r
  if fHandle <> 0 then\r
    Result := GetWindowTextLength( fHandle );\r
end;\r
\r
//*\r
//[function TControl.REGetTextSize]\r
function TControl.REGetTextSize(Units: TRichTextSize): Integer;\r
const TextLengthFlags: array[ TRichTextSizes ] of Integer =\r
      ( not GTL_UseCRLF, not GTL_Precise, GTL_Close, GTL_NUMBytes );\r
var GTL: TGetTextLengthEx;\r
begin\r
  GTL.flags := MakeFlags( @Units, TextLengthFlags );\r
  if not(rtsBytes in Units) then\r
    GTL.flags := GTL.flags or GTL_NUMCHARS;\r
  GTL.codepage := CP_ACP;\r
  Result := Perform( EM_GETTEXTLENGTHEX, Integer( @GTL ), 0 );\r
end;\r
\r
//[function TControl.RE_TextSizePrecise]\r
function TControl.RE_TextSizePrecise: Integer;\r
var gtlex : TGetTextLengthEx;\r
begin\r
  gtlex.flags := GTL_PRECISE;\r
  gtlex.codepage := CP_ACP;\r
  Result := Perform(EM_GETTEXTLENGTHEX,WPARAM(@gtlex), 0 );\r
end;\r
\r
//*\r
//[function TControl.REGetNumStyle]\r
function TControl.REGetNumStyle: TRichNumbering;\r
begin\r
  Result := TRichNumbering( ReGetParaAttr( 9 shl 16 ) );\r
end;\r
\r
//*\r
//[procedure TControl.RESetNumStyle]\r
procedure TControl.RESetNumStyle(const Value: TRichNumbering);\r
begin\r
  RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Ord( Value ) );\r
end;\r
\r
//*\r
//[function TControl.REGetNumBrackets]\r
function TControl.REGetNumBrackets: TRichNumBrackets;\r
begin\r
  REGetParaAttr( 0 );\r
  Result := TRichNumBrackets( (fREParaFmtRec.wNumberingStyle shr 8) {and 3} );\r
end;\r
\r
//*\r
//[procedure TControl.RESetNumBrackets]\r
procedure TControl.RESetNumBrackets(const Value: TRichNumBrackets);\r
begin\r
  REGetParaAttr( 0 );\r
  fREParaFmtRec.wNumberingStyle := fREParaFmtRec.wNumberingStyle and $F8FF\r
                                or Word( Ord( Value ) shl 8 );\r
  fREParaFmtRec.dwMask := PFM_NUMBERINGSTYLE;\r
  RE_ParaFmt := fREParaFmtRec;\r
end;\r
\r
//*\r
//[function TControl.REGetNumTab]\r
function TControl.REGetNumTab: Integer;\r
begin\r
  REGetParaAttr( 0 );\r
  Result := fREParaFmtRec.wNumberingTab;\r
end;\r
\r
//*\r
//[procedure TControl.RESetNumTab]\r
procedure TControl.RESetNumTab(const Value: Integer);\r
begin\r
  REGetParaAttr( 0 );\r
  fREParaFmtRec.wNumberingTab := Value;\r
  fREParaFmtRec.dwMask := PFM_NUMBERINGTAB;\r
  RE_ParaFmt := fREParaFmtRec;\r
end;\r
\r
//*\r
//[function TControl.REGetNumStart]\r
function TControl.REGetNumStart: Integer;\r
begin\r
  REGetParaAttr( 0 );\r
  Result := fREParaFmtRec.wNumberingStart;\r
end;\r
\r
//*\r
//[procedure TControl.RESetNumStart]\r
procedure TControl.RESetNumStart(const Value: Integer);\r
begin\r
  REGetParaAttr( 0 );\r
  fREParaFmtRec.wNumberingStart := Value;\r
  fREParaFmtRec.dwMask := PFM_NUMBERINGSTART;\r
  RE_ParaFmt := fREParaFmtRec;\r
end;\r
\r
//*\r
//[function TControl.REGetSpacing]\r
function TControl.REGetSpacing( const Index: Integer ): Integer;\r
begin\r
  REGetParaAttr( 0 );\r
  Result := PInteger( Integer(@fREParaFmtRec.dySpaceBefore) + (Index and $F) )^;\r
end;\r
\r
//*\r
//[procedure TControl.RESetSpacing]\r
procedure TControl.RESetSpacing(const Index, Value: Integer);\r
begin\r
  REGetParaAttr( 0 );\r
  PInteger( Integer(@fREParaFmtRec.dySpaceBefore) + (Index and $F) )^ := Value;\r
  fREParaFmtRec.dwMask := Index and not $F;\r
  RE_ParaFmt := fREParaFmtRec;\r
end;\r
\r
//*\r
//[function TControl.REGetSpacingRule]\r
function TControl.REGetSpacingRule: Integer;\r
begin\r
  REGetParaAttr( 0 );\r
  Result := fREParaFmtRec.bLineSpacingRule;\r
end;\r
\r
//*\r
//[procedure TControl.RESetSpacingRule]\r
procedure TControl.RESetSpacingRule(const Value: Integer);\r
begin\r
  REGetParaAttr( 0 );\r
  fREParaFmtRec.bLineSpacingRule := Value;\r
  fREParaFmtRec.dwMask := PFM_LINESPACING;\r
  RE_ParaFmt := fREParaFmtRec;\r
end;\r
\r
//*\r
//[function TControl.REGetLevel]\r
function TControl.REGetLevel: Integer;\r
begin\r
  REGetParaAttr( 0 );\r
  Result := fREParaFmtRec.bCRC;\r
end;\r
\r
//*\r
//[function TControl.REGetBorder]\r
function TControl.REGetBorder(Side: TBorderEdge; const Index: Integer): Integer;\r
begin\r
  REGetParaAttr( 0 );\r
  Result := PWORD( Integer(@fREParaFmtRec.wBorderSpace) + Index )^ shr (Ord(Side) * 4);\r
end;\r
\r
//*\r
//[procedure TControl.RESetBorder]\r
procedure TControl.RESetBorder(Side: TBorderEdge; const Index: Integer;\r
  const Value: Integer);\r
var Mask: Word;\r
    pW : PWord;\r
begin\r
  REGetParaAttr( 0 );\r
  pw := PWORD( Integer(@fREParaFmtRec.wBorderSpace) + Index );\r
  Mask := $F shl (Ord(Side) * 4);\r
  pw^ := pw^ and not Mask or (Value shl (4 * Ord(Side)) );\r
  fREParaFmtRec.dwMask := PFM_BORDER;\r
  RE_ParaFmt := fREParaFmtRec;\r
end;\r
\r
//*\r
//[function TControl.REGetParaEffect]\r
function TControl.REGetParaEffect(const Index: Integer): Boolean;\r
begin\r
  Result := LongBool( HiWord( REGetParaAttr( 8 shl 16 ) ) and Index );\r
end;\r
\r
//*\r
//[procedure TControl.RESetParaEffect]\r
procedure TControl.RESetParaEffect(const Index: Integer;\r
  const Value: Boolean);\r
var Idx: Integer;\r
begin\r
  REGetParaAttr( 0 );\r
  fREParaFmtRec.wReserved := Index;\r
  Idx := Index;\r
  //if Idx >= $4000 then Idx := $4000;\r
  fREParaFmtRec.dwMask := Idx shl 16;\r
  RE_ParaFmt := fREParaFmtRec;\r
end;\r
\r
//*\r
//[function WndProc_REMonitorIns]\r
function WndProc_REMonitorIns( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  Result := False;\r
  if (Msg.message = WM_KEYDOWN) and (Msg.wParam = VK_INSERT) and\r
     ((GetKeyState(VK_CONTROL) or GetKeyState(VK_SHIFT) or GetKeyState(VK_MENU)) >= 0) then\r
  begin\r
    if not Self_.fReOvrDisable then\r
      Self_.fREOvr := not Self_.fREOvr\r
    else\r
      Result := True;\r
    if assigned( Self_.fOnREInsModeChg ) then\r
       Self_.fOnREInsModeChg( Self_ );\r
  end;\r
end;\r
\r
//*\r
//[function TControl.REGetOverwite]\r
function TControl.REGetOverwite: Boolean;\r
begin\r
  AttachProc( WndProc_REMonitorIns );\r
  Result := fREOvr;\r
end;\r
\r
//*\r
//[procedure TControl.RESetOverwrite]\r
procedure TControl.RESetOverwrite(const Value: Boolean);\r
begin\r
  if fREOvr = Value then Exit;\r
  Perform( WM_KEYDOWN, VK_INSERT, 0 );\r
  Perform( WM_KEYUP, VK_INSERT, 0 );\r
end;\r
\r
//*\r
//[procedure TControl.RESetOvrDisable]\r
procedure TControl.RESetOvrDisable(const Value: Boolean);\r
begin\r
  REGetOverwite;\r
  fReOvrDisable := Value;\r
end;\r
\r
//*\r
//[function WndProc_RichEdTransp_ParentPaint]\r
function WndProc_RichEdTransp_ParentPaint( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var I: Integer;\r
    C: PControl;\r
begin\r
  if (Msg.message = WM_PAINT) and (Msg.wParam = 0) then\r
  begin\r
    for I := 0 to Self_.fChildren.fCount - 1 do\r
    begin\r
      C := Self_.fChildren.fItems[ I ];\r
      if C.fIsCommonControl then\r
      begin\r
        Inc( C.fUpdCount );\r
        PostMessage( C.fHandle, CM_NCUPDATE, C.fUpdCount, WM_PAINT );\r
        InvalidateRect( C.fHandle, nil, False );\r
      end;\r
    end;\r
  end;\r
  Result := False;\r
end;\r
\r
//*\r
//[function WndProc_RichEdTransp_Update]\r
function WndProc_RichEdTransp_Update( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Rgn, Rgn1: HRgn;\r
    R, CR: TRect;\r
    Pt: TPoint;\r
    VW, HH, VH, HW: Integer;\r
begin\r
  case Msg.message of\r
  WM_CHAR, WM_KILLFOCUS, WM_SETFOCUS:\r
    begin\r
      PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 );\r
    end;\r
  WM_PAINT:\r
    if Msg.wParam = 0 then\r
    begin\r
      Inc( Self_.fUpdCount );\r
      PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );\r
    end;\r
  WM_SIZE:\r
    begin\r
      Inc( Self_.fUpdCount );\r
      PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );\r
      PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 );\r
    end;\r
  WM_ERASEBKGND:\r
    if Msg.wParam = 0 then\r
    begin\r
      Inc( Self_.fUpdCount );\r
      PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );\r
    end;\r
  WM_HSCROLL, WM_VSCROLL:\r
    begin\r
      Self_.fREScrolling := LoWord( Msg.wParam ) <> SB_ENDSCROLL;\r
      Inc( Self_.fUpdCount );\r
      PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );\r
      if Self_.fREScrolling then\r
        Self_.Invalidate;\r
    end;\r
  CM_INVALIDATE:\r
    begin\r
      //Self_.Update;\r
      Self_.Parent.Invalidate;\r
      Self_.Invalidate;\r
      //Inc( Self_.fUpdCount );\r
      //PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );\r
    end;\r
  CM_NCUPDATE:\r
    if Msg.wParam = Self_.fUpdCount then\r
    begin\r
      //if Msg.lParam = WM_PAINT then\r
      //  UpdateWindow( Self_.fHandle );\r
      GetWindowRect( Self_.fHandle, R );\r
      Windows.GetClientRect( Self_.fHandle, CR );\r
      Pt.x := 0; Pt.y := 0;\r
      Pt := Self_.Client2Screen( Pt );\r
      OffsetRect( CR, Pt.x, Pt.y );\r
      Rgn := CreateRectRgn( R.Left, R.Top, R.Right, R.Bottom );\r
      if Self_.fREScrolling then\r
      begin\r
        VW := GetSystemMetrics( SM_CXVSCROLL );\r
        HH := GetSystemMetrics( SM_CYHSCROLL );\r
        VH := GetSystemMetrics( SM_CYVSCROLL );\r
        HW := GetSystemMetrics( SM_CXHSCROLL );\r
        if CR.Right + VW <= R.Right then\r
        begin\r
          Rgn1 := CreateRectRgn( CR.Right, CR.Top + VH, CR.Right + VW, CR.Bottom - VH );\r
          CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF );\r
          DeleteObject( Rgn1 );\r
        end;\r
        if CR.Bottom + HH <= R.Bottom then\r
        begin\r
          Rgn1 := CreateRectRgn( CR.Left + HW, CR.Bottom, CR.Right - HW, CR.Bottom + HH );\r
          CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF );\r
          DeleteObject( Rgn1 );\r
        end;\r
      end;\r
      Self_.Perform( WM_NCPAINT, Rgn, 0 );\r
      DeleteObject( Rgn ); // Unremarked By M.Gerasimov\r
    end;\r
  end;\r
  Result := False;\r
end;\r
\r
//*\r
//[function TControl.REGetTransparent]\r
function TControl.REGetTransparent: Boolean;\r
begin\r
  Result := Longbool(ExStyle and WS_EX_TRANSPARENT);\r
end;\r
\r
//*\r
//[procedure TControl.RESetTransparent]\r
procedure TControl.RESetTransparent(const Value: Boolean);\r
begin\r
  ExStyle := ExStyle or WS_EX_TRANSPARENT;\r
  fParent.AttachProc( WndProc_RichEdTransp_ParentPaint );\r
  AttachProc( WndProc_RichEdTransp_Update );\r
  fTransparent := Value;\r
end;\r
\r
//*\r
//[procedure TControl.RESetOnURL]\r
procedure TControl.RESetOnURL(const Index: Integer; const Value: TOnEvent);\r
begin\r
  if Index = 0 then\r
    fOnREOverURL := Value\r
  else\r
    fOnREURLClick := Value;\r
  RE_AutoURLDetect := assigned(fOnREOverURL) or assigned(fOnREURLClick);\r
end;\r
\r
{$IFDEF F_P}\r
//[function TControl.REGetOnURL]\r
function TControl.REGetOnURL(const Index: Integer): TOnEvent;\r
begin\r
  CASE Index OF\r
  0:   Result := fOnREOverURL;\r
  else Result := fOnREURLClick;\r
  END;\r
end;\r
{$ENDIF F_P}\r
\r
//*\r
//[function TControl.REGetLangOptions]\r
function TControl.REGetLangOptions(const Index: Integer): Boolean;\r
begin\r
  Result := LongBool( Perform( EM_GETLANGOPTIONS, 0, 0 ) and Index);\r
end;\r
\r
//*\r
//[procedure TControl.RESetLangOptions]\r
procedure TControl.RESetLangOptions(const Index: Integer;\r
  const Value: Boolean);\r
var Mask: Integer;\r
begin\r
  Mask := -1;\r
  if not Value then Inc( Mask );\r
  Perform( EM_SETLANGOPTIONS, 0, Perform( EM_GETLANGOPTIONS, 0, 0 ) and\r
           not Index or (Mask and Index) );\r
end;\r
\r
//[API _TrackMouseEvent]\r
function _TrackMouseEvent(lpEventTrack: PTrackMouseEvent): BOOL;\r
external cctrl name '_TrackMouseEvent';\r
\r
//[function DoTrackMouseEvent]\r
function DoTrackMouseEvent(lpEventTrack: PTrackMouseEvent): BOOL;\r
var FunTrack: function(lpEventTrack: PTrackMouseEvent): BOOL; stdcall;\r
    ComCtlModule: THandle;\r
begin\r
  Result := FALSE;\r
  ComCtlModule := GetModuleHandle( cctrl );\r
  if ComCtlModule = 0 then Exit;\r
  FunTrack := GetProcAddress( ComCtlModule, '_TrackMouseEvent' );\r
  if not Assigned( FunTrack ) then Exit;\r
  Result := FunTrack( lpEventTrack );\r
end;\r
\r
//*\r
//[function WndProcMouseEnterLeave]\r
function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var P: TPoint;\r
    MouseWasInControl: Boolean;\r
    Yes: Boolean;\r
    Track: TTrackMouseEvent;\r
begin\r
  case Msg.message of\r
    WM_MOUSEFIRST..WM_MOUSELAST:\r
      begin\r
        MouseWasInControl := Self_.MouseInControl;\r
        if Assigned( Self_.fOnTestMouseOver ) then\r
          Yes := Self_.fOnTestMouseOver( Self_ )\r
        else\r
        begin\r
          GetCursorPos( P );\r
          P := Self_.Screen2Client( P );\r
          Yes := PointInRect( P, Self_.ClientRect );\r
        end;\r
        if MouseWasInControl <> Yes then\r
        begin\r
          Self_.Invalidate;\r
          if Yes then\r
          begin\r
            Self_.fMouseInControl := TRUE;\r
            if Assigned( Self_.fOnMouseEnter ) then\r
              Self_.fOnMouseEnter( Self_ );\r
            Track.cbSize := Sizeof( Track );\r
            Track.dwFlags := TME_LEAVE;\r
            Track.hwndTrack := Self_.Handle;\r
            //Track.dwHoverTime := 0;\r
            DoTrackMouseEvent( @ Track );\r
            Self_.Invalidate;\r
          end\r
             else\r
          begin\r
            Self_.fMouseInControl := FALSE;\r
            Track.cbSize := Sizeof( Track );\r
            Track.dwFlags := TME_LEAVE or TME_CANCEL;\r
            Track.hwndTrack := Self_.Handle;\r
            //Track.dwHoverTime := 0;\r
            DoTrackMouseEvent( @ Track );\r
            if Assigned( Self_.fOnMouseLeave ) then\r
              Self_.fOnMouseLeave( Self_ );\r
            Self_.Invalidate;\r
          end;\r
        end;\r
      end;\r
    WM_MOUSELEAVE:\r
      begin\r
        if Self_.fMouseInControl then\r
        begin\r
          Self_.fMouseInControl := FALSE;\r
          if Assigned( Self_.fOnMouseLeave ) then\r
            Self_.fOnMouseLeave( Self_ );\r
          Self_.Invalidate;\r
        end;\r
      end;\r
  end;\r
  Result := False;\r
end;\r
\r
//[procedure ProvideMouseEnterLeave]\r
procedure ProvideMouseEnterLeave( Self_: PControl );\r
begin\r
  InitCommonControls;\r
  Self_.AttachProc( WndProcMouseEnterLeave );\r
  Self_.Invalidate;\r
end;\r
\r
//[procedure TControl.SetFlat]\r
procedure TControl.SetFlat(const Value: Boolean);\r
begin\r
  //if fFlat = Value then Exit;\r
  fFlat := Value;\r
  fMouseInControl := FALSE;\r
  ProvideMouseEnterLeave( @Self );\r
  Invalidate;\r
end;\r
\r
//[procedure TControl.SetOnMouseEnter]\r
procedure TControl.SetOnMouseEnter(const Value: TOnEvent);\r
begin\r
  fOnMouseEnter := Value;\r
  ProvideMouseEnterLeave( @Self );\r
end;\r
\r
//[procedure TControl.SetOnMouseLeave]\r
procedure TControl.SetOnMouseLeave(const Value: TOnEvent);\r
begin\r
  fOnMouseLeave := Value;\r
  ProvideMouseEnterLeave( @Self );\r
end;\r
\r
//[procedure TControl.SetOnTestMouseOver]\r
procedure TControl.SetOnTestMouseOver(const Value: TOnTestMouseOver);\r
begin\r
  fOnTestMouseOver := Value;\r
  ProvideMouseEnterLeave( @Self );\r
end;\r
\r
//[function WndProcEdTransparent]\r
function WndProcEdTransparent( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  if (Msg.message = WM_KEYDOWN) or\r
     (Msg.message = WM_MOUSEMOVE) and (GetKeyState( VK_LBUTTON ) < 0) or\r
     (Msg.message = WM_LBUTTONUP) or (Msg.message = WM_LBUTTONDOWN) then\r
    Self_.Invalidate;\r
  Result := False; // continue handling of a message anyway\r
end;\r
\r
//[procedure TControl.EdSetTransparent]\r
procedure TControl.EdSetTransparent(const Value: Boolean);\r
begin\r
  Transparent := Value;\r
  AttachProc( WndProcEdTransparent );\r
end;\r
\r
//[function WndProcSpeedButton]\r
function WndProcSpeedButton( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  Result := False;\r
  if Msg.message = WM_SETFOCUS then\r
  begin\r
    Result := TRUE;\r
    Rslt := 0;\r
  end;\r
end;\r
\r
//[function TControl.LikeSpeedButton]\r
function TControl.LikeSpeedButton: PControl;\r
var Form: PControl;\r
begin\r
  AttachProc( WndProcSpeedButton );\r
  fTabstop := False;\r
  Style := Style and not WS_TABSTOP;\r
  Form := ParentForm;\r
  if Form <> nil then\r
    if Form.fCurrentControl = @Self then\r
    begin\r
      Form.GotoControl( VK_TAB );\r
      if Form.fCurrentControl = @Self then\r
        Form.fCurrentControl := nil;\r
    end;\r
  Result := @Self;\r
end;\r
\r
{ -- Unicode -- }\r
//[function TControl.SetUnicode]\r
function TControl.SetUnicode(Unicode: Boolean): PControl;\r
begin\r
  Perform( CCM_SETUNICODEFORMAT, Integer( Unicode ), 0 );\r
  Result := @ Self;\r
end;\r
\r
{ -- TabControl -- }\r
\r
//[function TControl.GetPages]\r
function TControl.GetPages(Idx: Integer): PControl;\r
var Item: TTCItem;\r
begin\r
  Item.mask := TCIF_PARAM;\r
  if Perform( TCM_GETITEM, Idx, Integer( @Item ) ) = 0 then\r
    Result := nil\r
  else\r
    Result := Pointer( Item.lParam );\r
end;\r
\r
//[function TControl.TCGetItemText]\r
function TControl.TCGetItemText(Idx: Integer): String;\r
var TI: TTCItem;\r
    Buffer: array[ 0..1023 ] of Char;\r
begin\r
  TI.mask := TCIF_TEXT;\r
  TI.pszText := @Buffer[ 0 ];\r
  TI.cchTextMax := sizeof( Buffer );\r
  Buffer[ 0 ] := #0;\r
  Perform( TCM_GETITEM, Idx, Integer( @TI ) );\r
  Result := Buffer;\r
end;\r
\r
//[procedure TControl.TCSetItemText]\r
procedure TControl.TCSetItemText(Idx: Integer; const Value: String);\r
var TI: TTCItem;\r
begin\r
  TI.mask := TCIF_TEXT;\r
  TI.pszText := PChar( Value );\r
  Perform( TCM_SETITEM, Idx, Integer( @TI ) );\r
end;\r
\r
//[function TControl.TCGetItemImgIDx]\r
function TControl.TCGetItemImgIDx(Idx: Integer): Integer;\r
var TI: TTCItem;\r
begin\r
  TI.mask := TCIF_IMAGE;\r
  if Perform( TCM_GETITEM, Idx, Integer( @TI ) ) = 0 then\r
    Result := -1\r
  else\r
    Result := TI.iImage;\r
end;\r
\r
//[procedure TControl.TCSetItemImgIdx]\r
procedure TControl.TCSetItemImgIdx(Idx: Integer; const Value: Integer);\r
var TI: TTCItem;\r
begin\r
  TI.mask := TCIF_IMAGE;\r
  TI.iImage := Value;\r
  Perform( TCM_SETITEM, Idx, Integer( @TI ) );\r
end;\r
\r
//[function TControl.TCGetItemRect]\r
function TControl.TCGetItemRect(Idx: Integer): TRect;\r
begin\r
  if Perform( TCM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then\r
  begin\r
    Result.Left := 0;\r
    Result.Right := 0;\r
    Result.Top := 0;\r
    Result.Bottom := 0;\r
  end;\r
end;\r
\r
//[procedure TControl.TC_SetPadding]\r
procedure TControl.TC_SetPadding(cx, cy: Integer);\r
begin\r
  Perform( TCM_SETPADDING, 0, cx or (cy shl 16) );\r
end;\r
\r
//[function TControl.TC_TabAtPos]\r
function TControl.TC_TabAtPos(x, y: Integer): Integer;\r
type TTCHittestInfo = packed record\r
       Pt: TPoint;\r
       Fl: DWORD;\r
     end;\r
var HTI: TTCHitTestInfo;\r
begin\r
  HTI.Pt.x := x;\r
  HTI.Pt.y := y;\r
  Result := Perform( TCM_HITTEST, 0, Integer( @HTI ) );\r
end;\r
\r
//[function TControl.TC_DisplayRect]\r
function TControl.TC_DisplayRect: TRect;\r
begin\r
  Windows.GetClientRect( fHandle, Result );\r
  Perform( TCM_ADJUSTRECT, 0, Integer( @Result ) );\r
end;\r
\r
//[function TControl.TC_IndexOf]\r
function TControl.TC_IndexOf(const S: String): Integer;\r
begin\r
  Result := TC_SearchFor( S, -1, FALSE );\r
end;\r
\r
//[function TControl.TC_SearchFor]\r
function TControl.TC_SearchFor(const S: String; StartAfter: Integer;\r
  Partial: Boolean): Integer;\r
var I: Integer;\r
begin\r
  Result := -1;\r
  for I := StartAfter+1 to Count-1 do\r
  begin\r
    if Partial and ( Copy( TC_Items[ I ], 1, Length( S ) ) = S ) or\r
       ( TC_Items[ I ] = S ) then\r
    begin\r
      Result := I;\r
      break;\r
    end;\r
  end;\r
end;\r
\r
//[function TControl.TC_Insert]\r
function TControl.TC_Insert(Idx: Integer; const TabText: String;\r
  TabImgIdx: Integer): PControl;\r
var TI: TTCItem;\r
begin\r
  Result := NewPanel( @Self, esNone );\r
  Result.FAlign := caClient;\r
  Result.fNotUseAlign := True;\r
  Result.fVisibleWoParent := TRUE;\r
  Result.Visible := Count = 0;\r
  TI.mask := TCIF_TEXT or TCIF_IMAGE or TCIF_PARAM;\r
  TI.iImage := TabImgIdx;\r
  TI.pszText := PChar( TabText );\r
  TI.lParam := Integer( Result );\r
  Perform( TCM_INSERTITEM, Idx, Integer( @TI ) );\r
  Result.BoundsRect := TC_DisplayRect;\r
end;\r
\r
//[procedure TControl.TC_Delete]\r
procedure TControl.TC_Delete(Idx: Integer);\r
var Page: PControl;\r
begin\r
  Page := TC_Pages[ Idx ];\r
  if Page = nil then Exit;\r
  Perform( TCM_DELETEITEM, Idx, 0 );\r
  Page.Free;\r
end;\r
\r
{ -- TreeView -- }\r
\r
//[function TControl.TVGetItemIdx]\r
function TControl.TVGetItemIdx(const Index: Integer): THandle;\r
begin\r
  Result := Perform( TVM_GETNEXTITEM, Index, 0 );\r
end;\r
\r
//[procedure TControl.TVSetItemIdx]\r
procedure TControl.TVSetItemIdx(const Index: Integer;\r
  const Value: THandle);\r
begin\r
  Perform( TVM_SELECTITEM, Index, Value );\r
end;\r
\r
//[function TControl.TVGetItemNext]\r
function TControl.TVGetItemNext(Item: THandle; const Index: Integer): THandle;\r
begin\r
  Result := Perform( TVM_GETNEXTITEM, Index, Item );\r
end;\r
\r
//[function TControl.TVGetItemRect]\r
function TControl.TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect;\r
begin\r
  Result.Left := Item;\r
  if Perform( TVM_GETITEMRECT, Integer( TextOnly ), Integer( @Result ) ) = 0 then\r
  begin\r
    Result.Left := 0;\r
    Result.Right := 0;\r
    Result.Top := 0;\r
    Result.Bottom := 0;\r
  end;\r
end;\r
\r
//[function TControl.TVGetItemVisible]\r
function TControl.TVGetItemVisible(Item: THandle): Boolean;\r
var R: TRect;\r
begin\r
  R := TVItemRect[ Item, False ];\r
  Result := R.Bottom > R.Top;\r
end;\r
\r
//[procedure TControl.TVSetItemVisible]\r
procedure TControl.TVSetItemVisible(Item: THandle; const Value: Boolean);\r
begin\r
  if Value then\r
    Perform( TVM_ENSUREVISIBLE, 0, Item );\r
end;\r
\r
//[function TControl.TVGetItemStateFlg]\r
function TControl.TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean;\r
var TVI: TTVItem;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_STATE;\r
  TVI.hItem := Item;\r
  TVI.stateMask := Index;\r
  Result := False;\r
  if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then\r
    Result := (TVI.state and Index) <> 0;\r
end;\r
\r
//[procedure TControl.TVSetItemStateFlg]\r
procedure TControl.TVSetItemStateFlg(Item: THandle; const Index: Integer;\r
  const Value: Boolean);\r
var TVI: TTVItem;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_STATE;\r
  TVI.hItem := Item;\r
  TVI.stateMask := Index;\r
  TVI.state := $FFFFFFFF and Index;\r
  if not Value then\r
    TVI.state := 0;\r
  Perform( TVM_SETITEM, 0, Integer( @TVI ) );\r
end;\r
\r
//[function TControl.TVGetItemImage]\r
function TControl.TVGetItemImage(Item: THandle; const Index: Integer): Integer;\r
var TVI: TTVItem;\r
begin\r
  TVI.mask := TVIF_HANDLE or Loword( Index );\r
  TVI.hItem := Item;\r
  if Hiword( Index ) <> 0 then\r
  begin\r
    TVI.mask := TVIF_STATE or TVIF_HANDLE;\r
    TVI.stateMask := Loword( Index );\r
  end;\r
  Result := -1;\r
  if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then\r
  begin\r
    if Hiword( Index ) <> 0 then\r
      Result := (TVI.state shr Hiword( Index )) and $F\r
    else\r
    if Loword( Index ) = TVIF_IMAGE then\r
      Result := TVI.iImage\r
    else\r
      Result := TVI.iSelectedImage;\r
  end;\r
end;\r
\r
//[procedure TControl.TVSetItemImage]\r
procedure TControl.TVSetItemImage(Item: THandle; const Index: Integer;\r
  const Value: Integer);\r
var TVI: TTVItem;\r
begin\r
  TVI.mask := TVIF_HANDLE or Loword( Index );\r
  TVI.hItem := Item;\r
  TVI.iImage := Value;\r
  TVI.iSelectedImage := Value;\r
  if Hiword( Index ) <> 0 then\r
  begin\r
    TVI.mask := TVIF_STATE or TVIF_HANDLE;\r
    TVI.stateMask := Loword( Index );\r
    TVI.state := Value shl Hiword( Index );\r
  end;\r
  Perform( TVM_SETITEM, 0, Integer( @TVI ) );\r
end;\r
\r
//[function TControl.TVGetItemText]\r
function TControl.TVGetItemText(Item: THandle): String;\r
var TVI: TTVItem;\r
    Buffer: array[ 0..4095 ] of Char;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_TEXT;\r
  TVI.hItem := Item;\r
  TVI.pszText := @Buffer[ 0 ];\r
  Buffer[ 0 ] := #0;\r
  TVI.cchTextMax := Sizeof( Buffer );\r
  Perform( TVM_GETITEM, 0, Integer( @TVI ) );\r
  Result := Buffer;\r
end;\r
\r
//[procedure TControl.TVSetItemText]\r
procedure TControl.TVSetItemText(Item: THandle; const Value: String);\r
var TVI: TTVItem;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_TEXT;\r
  TVI.hItem := Item;\r
  TVI.pszText := PChar( Value );\r
  Perform( TVM_SETITEM, 0, Integer( @TVI ) );\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function TControl.TVGetItemTextW]\r
function TControl.TVGetItemTextW(Item: THandle): WideString;\r
var TVI: TTVItemW;\r
    Buffer: array[ 0..4095 ] of WideChar;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_TEXT;\r
  TVI.hItem := Item;\r
  TVI.pszText := @Buffer[ 0 ];\r
  Buffer[ 0 ] := #0;\r
  TVI.cchTextMax := High( Buffer ) + 1;\r
  Perform( TVM_GETITEMW, 0, Integer( @TVI ) );\r
  Result := Buffer;\r
end;\r
\r
//[procedure TControl.TVSetItemTextW]\r
procedure TControl.TVSetItemTextW(Item: THandle; const Value: WideString);\r
var TVI: TTVItemW;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_TEXT;\r
  TVI.hItem := Item;\r
  TVI.pszText := PWideChar( Value );\r
  Perform( TVM_SETITEMW, 0, Integer( @TVI ) );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[function TControl.TVItemPath]\r
function TControl.TVItemPath(Item: THandle; Delimiter: Char): String;\r
begin\r
  if Item = 0 then\r
    Item := TVSelected;\r
  Result := '';\r
  while Item <> 0 do\r
  begin\r
    if Result <> '' then\r
      Result := Delimiter + Result;\r
    Result := TVItemText[ Item ] + Result;\r
    Item := TVItemParent[ Item ];\r
  end;\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function TControl.TVItemPathW]\r
function TControl.TVItemPathW(Item: THandle;\r
  Delimiter: WideChar): WideString;\r
begin\r
  if Item = 0 then\r
    Item := TVSelected;\r
  Result := '';\r
  while Item <> 0 do\r
  begin\r
    if Result <> '' then\r
      Result := {$IFDEF _D3} '' + {$ENDIF} Delimiter + Result;\r
    Result := TVItemTextW[ Item ] + Result;\r
    Item := TVItemParent[ Item ];\r
  end;\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[function TControl.TV_GetItemHasChildren]\r
function TControl.TV_GetItemHasChildren(Item: THandle): Boolean;\r
var TVI: TTVItem;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_CHILDREN;\r
  TVI.hItem := Item;\r
  Perform( TVM_GETITEM, 0, Integer( @TVI ) );\r
  Result := TVI.cChildren = 1;\r
end;\r
\r
//[procedure TControl.TV_GetItemChildCount]\r
function TControl.TV_GetItemChildCount(Item: THandle): Integer;\r
var Node: THandle;\r
begin\r
  Result := 0;\r
  Node := TVItemChild[ Item ];\r
  while Node <> 0 do\r
  begin\r
    Inc( Result );\r
    Node := TVItemNext[ Node ];\r
  end;\r
end;\r
\r
//[procedure TControl.TV_SetItemHasChildren]\r
procedure TControl.TV_SetItemHasChildren(Item: THandle;\r
  const Value: Boolean);\r
var TVI: TTVItem;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_CHILDREN;\r
  TVI.hItem := Item;\r
  TVI.cChildren := 1 and Integer( Value );\r
  Perform( TVM_SETITEM, 0, Integer( @TVI ) );\r
end;\r
\r
//[function TControl.TVItemAtPos]\r
function TControl.TVItemAtPos(x, y: Integer; var Where: DWORD): THandle;\r
var HTI: TTVHitTestInfo;\r
begin\r
  HTI.pt.x := x;\r
  HTI.pt.y := y;\r
  Result := Perform( TVM_HITTEST, 0, Integer( @HTI ) );\r
  Where := HTI.fl;\r
end;\r
\r
type\r
  TTVInsertStruct = packed Record\r
    hParent: THandle;\r
    hAfter : THandle;\r
    item: TTVItem;\r
  end;\r
  TTVInsertStructEx = packed Record\r
    hParent: THandle;\r
    hAfter : THandle;\r
    item: TTVItemEx;\r
  end;\r
\r
//[function TControl.TVInsert]\r
function TControl.TVInsert(nParent, nAfter: THandle;\r
  const Txt: String): THandle;\r
var TVIns: TTVInsertStruct;\r
begin\r
  TVIns.hParent := nParent;\r
  TVIns.hAfter := nAfter;\r
  TVIns.item.mask := TVIF_TEXT;\r
  TVIns.item.pszText := PChar( Txt );\r
  Result := Perform( TVM_INSERTITEM, 0, Integer( @TVIns ) );\r
  Invalidate;\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
type\r
  TTVInsertStructW = packed Record\r
    hParent: THandle;\r
    hAfter : THandle;\r
    item: TTVItemW;\r
  end;\r
  TTVInsertStructExW = packed Record\r
    hParent: THandle;\r
    hAfter : THandle;\r
    item: TTVItemExW;\r
  end;\r
\r
//[function TControl.TVInsertW]\r
function TControl.TVInsertW(nParent, nAfter: THandle;\r
  const Txt: WideString): THandle;\r
var TVIns: TTVInsertStructW;\r
begin\r
  TVIns.hParent := nParent;\r
  TVIns.hAfter := nAfter;\r
  TVIns.item.mask := TVIF_TEXT;\r
  if Txt = '' then TVIns.item.pszText := nil\r
              else TVIns.item.pszText := PWideChar( @ Txt[ 1 ] );\r
  Result := Perform( TVM_INSERTITEMW, 0, Integer( @ TVIns ) );\r
  Invalidate;\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[procedure TControl.TVExpand]\r
procedure TControl.TVExpand(Item: THandle; Flags: DWORD);\r
begin\r
  Perform( TVM_EXPAND, Flags, Item );\r
end;\r
\r
//[procedure TControl.TVSort]\r
procedure TControl.TVSort( N: THandle );\r
var a: Cardinal;\r
    b: Boolean;\r
begin\r
  b := N = 0;\r
  if b then\r
  begin\r
    N := TVRoot;\r
  end;\r
  while N <> 0 do\r
    begin\r
      a := TVItemChild[N];\r
      if a > 0 then\r
        TVSort(a);\r
      Perform(TVM_SORTCHILDREN, 0, N);\r
      N := TVItemNext[N];\r
    end;\r
  if b then //moved by Truf\r
    Perform(TVM_SORTCHILDREN, 0, 0);  //+ by YS\r
end;\r
\r
//[procedure TControl.TVDelete]\r
procedure TControl.TVDelete(Item: THandle);\r
begin\r
  Perform( TVM_DELETEITEM, 0, Item );\r
  Invalidate;\r
end;\r
\r
//[function TControl.TVGetItemData]\r
function TControl.TVGetItemData(Item: THandle): Pointer;\r
var TVI: TTVItem;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_PARAM;\r
  TVI.hItem := Item;\r
  Result := nil;\r
  if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then\r
    Result := Pointer( TVI.lParam );\r
end;\r
\r
//[procedure TControl.TVSetItemData]\r
procedure TControl.TVSetItemData(Item: THandle; const Value: Pointer);\r
var TVI: TTVItem;\r
begin\r
  TVI.mask := TVIF_HANDLE or TVIF_PARAM;\r
  TVI.hItem := Item;\r
  TVI.lParam := Integer( Value );\r
  Perform( TVM_SETITEM, 0, Integer( @TVI ) );\r
end;\r
\r
//[procedure TControl.TVEditItem]\r
procedure TControl.TVEditItem(Item: THandle);\r
begin\r
  Perform( TVM_EDITLABEL, 0, Item );\r
end;\r
\r
//[procedure TControl.TVStopEdit]\r
procedure TControl.TVStopEdit(Cancel: Boolean);\r
begin\r
  Perform( TVM_ENDEDITLABELNOW, Integer( Cancel ), 0 );\r
end;\r
\r
//[function WndProcTVRightClickSelect]\r
function WndProcTVRightClickSelect( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean;\r
var I: Integer;\r
    Where: DWORD;\r
begin\r
  if Msg.message = WM_RBUTTONDOWN then\r
  begin\r
    I := Sender.TVItemAtPos( SmallInt( Msg.lParam and $FFFF ),\r
         SmallInt( Msg.lParam shr 16 ), Where  );\r
    if I <> 0 then\r
      Sender.TVSelected := I;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.SetTVRightClickSelect]\r
procedure TControl.SetTVRightClickSelect(const Value: Boolean);\r
begin\r
  fTVRightClickSelect := Value;\r
  if Value then\r
    AttachProc( @WndProcTVRightClickSelect );\r
end;\r
\r
//[procedure TControl.SetOnTVDelete]\r
procedure TControl.SetOnTVDelete( const Value: TOnTVDelete );\r
begin\r
  fOnTVDelete := Value;\r
  if fParent <> nil then\r
  begin\r
    fParent.Add2AutoFreeEx( Clear );\r
    fParent.DetachProc( WndProcNotify );\r
    fParent.AttachProcEx( WndProcNotify, TRUE );\r
  end;\r
  AttachProcEx( ProcTVDeleteItem, TRUE );\r
end;\r
\r
//[function Clipboard2Text]\r
function Clipboard2Text: String;\r
var gbl: THandle;\r
    str: PChar;\r
begin\r
  Result := '';\r
  if OpenClipboard( 0 ) then\r
  begin\r
    if IsClipboardFormatAvailable( CF_TEXT ) then\r
    begin\r
      gbl := GetClipboardData( CF_TEXT );\r
      if gbl <> 0 then\r
      begin\r
        str := GlobalLock( gbl );\r
        if str <> nil then\r
        begin\r
          Result := str;\r
          GlobalUnlock( gbl );\r
        end;\r
      end;\r
    end;\r
    CloseClipboard;\r
  end;\r
end;\r
\r
{-}\r
{$IFNDEF _D2}\r
//[function Clipboard2WText]\r
function Clipboard2WText: WideString;\r
var gbl: THandle;\r
    str: PWideChar;\r
begin\r
  Result := '';\r
  if OpenClipboard( 0 ) then\r
  begin\r
    if IsClipboardFormatAvailable( CF_UNICODETEXT ) then\r
    begin\r
      gbl := GetClipboardData( CF_UNICODETEXT );\r
      if gbl <> 0 then\r
      begin\r
        str := GlobalLock( gbl );\r
        if str <> nil then\r
        begin\r
          Result := str;\r
          GlobalUnlock( gbl );\r
        end;\r
      end;\r
    end;\r
    CloseClipboard;\r
  end;\r
end;\r
{$ENDIF}\r
\r
{+}\r
//[function Text2Clipboard]\r
function Text2Clipboard( const S: String ): Boolean;\r
var gbl: THandle;\r
    str: PChar;\r
begin\r
  Result := False;\r
  if not OpenClipboard( 0 ) then Exit;\r
  EmptyClipboard;\r
  if S <> '' then\r
  begin\r
    gbl := GlobalAlloc( GMEM_DDESHARE, Length( S ) + 1 );\r
    if gbl <> 0 then\r
    begin\r
      str := GlobalLock( gbl );\r
      Move( S[ 1 ], str^, Length( S ) + 1 );\r
      GlobalUnlock( gbl );\r
      Result := SetClipboardData( CF_TEXT, gbl ) <> 0;\r
    end;\r
  end\r
    else\r
      Result := True;\r
  CloseClipboard;\r
end;\r
\r
{-}\r
{$IFNDEF _D2}\r
//[function WText2Clipboard]\r
function WText2Clipboard( const WS: WideString ): Boolean;\r
var gbl: THandle;\r
    str: PChar;\r
begin\r
  Result := False;\r
  if not OpenClipboard( 0 ) then Exit;\r
  EmptyClipboard;\r
  if WS <> '' then\r
  begin\r
    gbl := GlobalAlloc( GMEM_DDESHARE, (Length( WS ) + 1) * 2 );\r
    if gbl <> 0 then\r
    begin\r
      str := GlobalLock( gbl );\r
      Move( WS[ 1 ], str^, (Length( WS ) + 1) * 2 );\r
      GlobalUnlock( gbl );\r
      Result := SetClipboardData( CF_UNICODETEXT, gbl ) <> 0;\r
    end;\r
  end\r
    else\r
      Result := True;\r
  CloseClipboard;\r
end;\r
{$ENDIF}\r
\r
{+}\r
//[function TControl.Size]\r
function TControl.Size(W, H: Integer): PControl;\r
var C, P: PControl;\r
    dW, dH: Integer;\r
begin\r
  C := @Self;\r
  while True do\r
  begin\r
    dW := 0; dH := 0;\r
    P := C.FParent;\r
    if C.ToBeVisible {or C.fCreateHidden {or (P <> nil) and (P.fVisible)} then\r
    begin\r
      if C.fAlign in [caLeft, caRight, caClient] then\r
      begin\r
        if H > 0 then\r
        begin\r
          dH := H - C.Height; H := 0;\r
        end;\r
      end;\r
      if C.fAlign in [caTop, caBottom, caClient] then\r
      begin\r
        if W > 0 then\r
        begin\r
          dW := W - C.Width; W := 0;\r
        end;\r
      end;\r
    end;\r
    if (W > 0) or (H > 0) then\r
    begin\r
      C.SetSize( W, H );\r
      if (P <> nil) // {Ralf Junker}\r
         and not P.IsApplet then\r
        C.ResizeParent;\r
      {\r
      if P <> nil then\r
      begin\r
        if not (C.FAlign in [caLeft,caRight,caClient]) then\r
          C.ResizeParentRight;\r
        if not (C.FAlign in [caTop,caBottom,caClient]) then\r
          C.ResizeParentBottom;\r
      end;\r
      }\r
    end;\r
    if (dW = 0) and (dH = 0) then break;\r
    C := P; //C.FParent;\r
    if C = nil then break;\r
    //if not C.fIsControl then break;\r
    if C.IsApplet then break;\r
    W := C.Width + dW;\r
    H := C.Height + dH;\r
  end;\r
  Result := @Self;\r
end;\r
\r
//[procedure AutoSzProc]\r
procedure AutoSzProc( Self_: PControl );\r
var DeltaX, DeltaY: Integer;\r
    SZ: TSize; PT: TPoint;\r
    Txt: String;\r
    Chg: Boolean;\r
begin\r
  Txt := Self_.fCaption;\r
  SZ.cx := 0;\r
  SZ.cy := 0;\r
  if Txt <> '' then\r
  begin\r
    if Assigned( Self_.fFont ) then\r
    if Self_.fFont.fData.Font.Italic then\r
       Txt := Txt + ' ';\r
    Self_.GetWindowHandle; // this line must be here.\r
    //-- otherwise, when handle is not yet allocated,\r
    // it is requested in TCanvas.GetHandle, and in result\r
    // of unpredictable recursion some memory can be currupted.\r
    Self_.Canvas.TextArea( Txt, SZ, PT );\r
  end;\r
  Chg := FALSE;\r
  if Self_.FAlign in [ caNone, caLeft, caRight ] then\r
  begin\r
    DeltaX := Self_.fCommandActions.aAutoSzX;\r
    if DeltaX > 0 then\r
    begin\r
      Self_.Width := SZ.cx + DeltaX;\r
      Chg := TRUE;\r
    end;\r
  end;\r
  if Self_.FAlign in [ caNone, caTop, caBottom ] then\r
  begin\r
    DeltaY := Self_.fCommandActions.aAutoSzY;\r
    if DeltaY > 0 then\r
    begin\r
      Self_.Height := SZ.cy + DeltaY;\r
      Chg := TRUE;\r
    end;\r
  end;\r
  if Chg then\r
  begin\r
    if Self_.fParent <> nil then\r
      Global_Align( Self_.fParent );\r
    Global_Align( Self_ );\r
  end;\r
end;\r
\r
//[function TControl.AutoSize]\r
function TControl.AutoSize(AutoSzOn: Boolean): PControl;\r
begin\r
  if AutoSzOn then\r
  begin\r
    fAutoSize := AutoSzProc;\r
    fAutoSize( @Self );\r
  end\r
  else\r
    fAutoSize := nil;\r
  Result := @Self;\r
end;\r
\r
//[function TControl.IsAutoSize]\r
function TControl.IsAutoSize: Boolean;\r
begin\r
  Result := Assigned( fAutoSize );\r
end;\r
\r
//*\r
//[function TControl.GetToBeVisible]\r
function TControl.GetToBeVisible: Boolean;\r
begin\r
  Result := fVisible or fCreateHidden or fVisibleWoParent;\r
  if fIsControl then\r
  if Parent <> nil then\r
  begin\r
    if fVisibleWoParent then\r
      Result := fVisible\r
    else\r
    begin\r
      Parent.Visible; // needed to provide correct fVisible for a form!\r
      Result := Result and Parent.ToBeVisible;\r
    end;\r
  end;\r
end;\r
\r
{ -- TTree -- }\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[function NewTree]\r
function NewTree( AParent: PTree; const AName: String ): PTree;\r
begin\r
  New( Result, CreateTree(  AParent, AName ) );\r
end;\r
//[END NewTree]\r
{$ELSE not_USE_CONSTRUCTORS}\r
//[function NewTree]\r
function NewTree( AParent: PTree; const AName: String ): PTree;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PTree.Create;*){--}\r
  if AParent <> nil then\r
    AParent.Add( Result );\r
  Result.fParent := AParent;\r
  Result.fName := AName;\r
end;\r
//[END NewTree]\r
{$ENDIF USE_CONSTRUCTORS}\r
\r
{ TTree }\r
\r
//[procedure TTree.Add]\r
procedure TTree.Add(Node: PTree);\r
var Previous: PTree;\r
begin\r
  Node.Unlink;\r
  if fChildren = nil then\r
    fChildren := NewList;\r
  Previous := nil;\r
  if fChildren.fCount > 0 then\r
    Previous := fChildren.fItems[ fChildren.fCount - 1 ];\r
  if Previous <> nil then\r
  begin\r
    Previous.fNext := Node;\r
    Node.fPrev := Previous;\r
  end;\r
  fChildren.Add( Node );\r
  Node.fParent := @Self;\r
end;\r
\r
//[procedure TTree.Clear]\r
procedure TTree.Clear;\r
var I: Integer;\r
begin\r
  if fChildren = nil then Exit;\r
  for I := fChildren.fCount - 1 downto 0 do\r
    PTree( fChildren.fItems[ I ] ).Free;\r
end;\r
\r
{$IFDEF USE_CONSTRUCTORS}\r
//[constructor TTree.CreateTree]\r
constructor TTree.CreateTree(AParent: PTree; const AName: String);\r
begin\r
  inherited Create;\r
  if AParent <> nil then\r
    AParent.Add( @Self );\r
  fParent := AParent;\r
  fName := AName;\r
end;\r
{$ENDIF}\r
\r
//[destructor TTree.Destroy]\r
destructor TTree.Destroy;\r
begin\r
  Unlink;\r
  Clear;\r
  fName := '';\r
  inherited;\r
end;\r
\r
//[function TTree.GetCount]\r
function TTree.GetCount: Integer;\r
begin\r
  Result := 0;\r
  if fChildren = nil then Exit;\r
  Result := fChildren.fCount;\r
end;\r
\r
//[function TTree.GetIndexAmongSiblings]\r
function TTree.GetIndexAmongSiblings: Integer;\r
begin\r
  Result := -1;\r
  if fParent = nil then Exit;\r
  Result := fParent.fChildren.IndexOf( @Self );\r
end;\r
\r
//[function TTree.GetItems]\r
function TTree.GetItems(Idx: Integer): PTree;\r
begin\r
  Result := nil;\r
  if fChildren = nil then Exit;\r
  Result := fChildren.Items[ Idx ];\r
end;\r
\r
//[function TTree.GetLevel]\r
function TTree.GetLevel: Integer;\r
var Node: PTree;\r
begin\r
  Result := 0;\r
  Node := fParent;\r
  while Node <> nil do\r
  begin\r
    Inc( Result );\r
    Node := Node.fParent;\r
  end;\r
end;\r
\r
//[function TTree.GetRoot]\r
function TTree.GetRoot: PTree;\r
begin\r
  Result := @Self;\r
  while Result.fParent <> nil do\r
    Result := Result.fParent;\r
end;\r
\r
//[function TTree.GetTotal]\r
function TTree.GetTotal: Integer;\r
var I: Integer;\r
begin\r
  Result := Count;\r
  if Result <> 0 then\r
  begin\r
    for I := 0 to Count - 1 do\r
      Result := Result + Items[ I ].Total;\r
  end;\r
end;\r
\r
//[procedure TTree.Init]\r
procedure TTree.Init;\r
begin\r
  if FParent <> nil then\r
    FParent.Add( @Self );\r
end;\r
\r
//[procedure TTree.Insert]\r
procedure TTree.Insert(Before, Node: PTree);\r
var Previous: PTree;\r
begin\r
  Node.Unlink;\r
  if fChildren = nil then\r
    fChildren := NewList;\r
  Previous := nil;\r
  if Before <> nil then\r
    Previous := Before.fPrev;\r
  if Previous <> nil then\r
  begin\r
    Previous.fNext := Node;\r
    Node.fPrev := Previous;\r
  end;\r
  if Before <> nil then\r
  begin\r
    Node.fNext := Before;\r
    Before.fPrev := Node;\r
    fChildren.Insert( fChildren.IndexOf( Before ), Node );\r
  end\r
    else\r
  fChildren.Add( Node );\r
  Node.fParent := @Self;\r
end;\r
\r
//[function CompareTreeNodes]\r
function CompareTreeNodes( const Data: Pointer; const e1, e2: DWORD ): Integer;\r
var List: PList;\r
begin\r
  List := Data;\r
  Result := AnsiCompareStr( PTree( List.fItems[ e1 ] ).fName,\r
                            PTree( List.fItems[ e2 ] ).fName );\r
end;\r
\r
//[procedure SwapTreeNodes]\r
procedure SwapTreeNodes( const Data: Pointer; const e1, e2: DWORD );\r
var List: PList;\r
begin\r
  List := Data;\r
  List.Swap( e1, e2 );\r
end;\r
\r
//[procedure TTree.SwapNodes]\r
procedure TTree.SwapNodes( i1, i2: Integer );\r
begin\r
  fChildren.Swap( i1, i2 );\r
end;\r
\r
//[procedure TTree.SortByName]\r
procedure TTree.SortByName;\r
begin\r
  if Count <= 1 then Exit;\r
  SortData( fChildren, fChildren.fCount, CompareTreeNodes, SwapTreeNodes );\r
end;\r
\r
//[procedure TTree.Unlink]\r
procedure TTree.Unlink;\r
var I: Integer;\r
begin\r
  if fPrev <> nil then\r
    fPrev.fNext := fNext;\r
  if fNext <> nil then\r
    fNext.fPrev := fPrev;\r
  if (fParent <> nil) then\r
  begin\r
    I := fParent.fChildren.IndexOf( @Self );\r
    fParent.fChildren.Delete( I );\r
    if fParent.fChildren.fCount = 0 then\r
    begin\r
      fParent.fChildren.Free;\r
      fParent.fChildren := nil;\r
    end;\r
  end;\r
  fPrev := nil;\r
  fNext := nil;\r
  fParent := nil;\r
end;\r
\r
//[function TTree.IsParentOfNode]\r
function TTree.IsParentOfNode(Node: PTree): Boolean;\r
begin\r
  Result := TRUE;\r
  while Node <> nil do\r
  begin\r
    if Node = @ Self then Exit;\r
    Node := Node.Parent;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[function TTree.IndexOf]\r
function TTree.IndexOf(Node: PTree): Integer;\r
begin\r
  Result := -1;\r
  if not IsParentOfNode( Node ) then Exit;\r
  while Node <> @ Self do\r
  begin\r
    Inc( Result );\r
    while Node.PrevSibling <> nil do\r
    begin\r
      Node := Node.PrevSibling;\r
      Inc( Result, 1 + Node.Total );\r
    end;\r
    Node := Node.Parent;\r
  end;\r
end;\r
\r
//-\r
//[procedure TControl.ProcessPendingMessages]\r
procedure TControl.ProcessPendingMessages;\r
var Msg: TMsg;\r
begin\r
  if LOWORD( GetQueueStatus( QS_ALLINPUT ) ) <> 0 then\r
  if PeekMessage( Msg, 0, 0, 0, PM_NOREMOVE {or PM_NOYIELD} )\r
  or PeekMessage( Msg, HWnd(-1), 0, 0, PM_NOREMOVE {or PM_NOYIELD} )\r
  then\r
    Applet.ProcessMessages;\r
end;\r
\r
//[procedure TControl.ProcessPaintMessages]\r
procedure TControl.ProcessPaintMessages;\r
var Msg: TMsg;\r
begin\r
  while PeekMessage( Msg, Handle, 15, 15, PM_NOREMOVE ) do\r
  //while GetQueueStatus( QS_PAINT ) <> 0 do\r
    Applet.ProcessMessage;\r
end;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
///////////////////////////////////////////////////////////////////////\r
//\r
//\r
//                         W  I  N  D  O  W  S\r
//\r
//\r
///////////////////////////////////////////////////////////////////////\r
\r
\r
\r
{ -- Set of window-related utility functions. -- }\r
type\r
  PGUIThreadInfo = ^TGUIThreadInfo;\r
  tagGUITHREADINFO = packed record\r
    cbSize: DWORD;\r
    flags: DWORD;\r
    hwndActive: HWND;\r
    hwndFocus: HWND;\r
    hwndCapture: HWND;\r
    hwndMenuOwner: HWND;\r
    hwndMoveSize: HWND;\r
    hwndCaret: HWND;\r
    rcCaret: TRect;\r
  end;\r
  TGUIThreadInfo = tagGUITHREADINFO;\r
\r
const\r
  GUI_CARETBLINKING  = $00000001;\r
  GUI_INMOVESIZE     = $00000002;\r
  GUI_INMENUMODE     = $00000004;\r
  GUI_SYSTEMMENUMODE = $00000008;\r
  GUI_POPUPMENUMODE  = $00000010;\r
\r
{function GetGUIThreadInfo (idThread: DWORD; var pgui: TGUIThreadinfo): BOOL; stdcall;\r
         external user32 name 'GetGUIThreadInfo';}\r
\r
type TGUIThreadInfo_Proc = function( ThreadID: THandle; var GTI: TGUIThreadInfo )\r
                          : Boolean; stdcall;\r
\r
var Proc_GetGUIThreadInfo: TGuiThreadInfo_Proc;\r
\r
//[function GetWindowChild]\r
function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd;\r
var GTI: TGuiThreadInfo;\r
    ThreadID: THandle;\r
    Module: THandle;\r
begin\r
  if not Assigned( Proc_GetGUIThreadInfo ) then\r
  begin\r
    Module := GetModuleHandle( 'User32' );\r
    Proc_GetGUIThreadInfo := GetProcAddress( Module, 'GetGUIThreadInfoA' );\r
    if not Assigned( Proc_GetGUIThreadInfo ) then\r
      Proc_GetGUIThreadInfo := Pointer( -1 );\r
  end;\r
  Result := Wnd;\r
  if Integer( @Proc_GetGUIThreadInfo ) = -1 then\r
    Exit;\r
  Result := 0;\r
  if Wnd = 0 then\r
    ThreadID := GetCurrentThreadID\r
  else\r
    ThreadID := GetWindowThreadProcessID( Wnd, nil );\r
  if ThreadID = 0 then Exit;\r
  GTI.cbSize := Sizeof( GTI );\r
  if Proc_GetGUIThreadInfo( ThreadId, GTI ) then\r
  begin\r
    case Kind of\r
    wcActive:  Result := GTI.hwndActive;\r
    wcFocus:   Result := GTI.hwndFocus;\r
    wcCapture: Result := GTI.hwndCapture;\r
    wcMenuOwner: Result := GTI.hwndMenuOwner;\r
    wcMoveSize:  Result := GTI.hwndMoveSize;\r
    wcCaret:     Result := GTI.hwndCaret;\r
    end;\r
  end;\r
end;\r
\r
//[function GetFocusedChild]\r
function GetFocusedChild( Wnd: HWnd ): HWnd;\r
var Tr1, Tr2: THandle;\r
begin\r
  Result := 0;\r
  Tr1 := GetCurrentThreadId;\r
  Tr2 := GetWindowThreadProcessId( Wnd, nil );\r
  if Tr1 = Tr2 then\r
    Result := GetFocus\r
  else\r
  if AttachThreadInput( Tr2, Tr1, True ) then\r
  begin\r
    Result := GetFocus;\r
    AttachThreadInput( Tr2, Tr1, False );\r
  end;\r
end;\r
\r
//[function WaitFocusedWndChild]\r
function WaitFocusedWndChild( Wnd: HWnd ): HWnd;\r
var T1, T2: Integer;\r
    W: HWnd;\r
begin\r
  Sleep( 50 );\r
  T1 := GetTickCount;\r
  while True do\r
  begin\r
    W := GetTopWindow( Wnd );\r
    if W = 0 then W := Wnd;\r
    W := GetFocusedChild( W );\r
    if W <> 0 then\r
    begin\r
      Wnd := W;\r
      break;\r
    end;\r
    T2 := GetTickCount;\r
    if Abs( T1 - T2 ) > 100 then break;\r
  end;\r
  Result := Wnd;\r
end;\r
\r
//[function Stroke2Window]\r
function Stroke2Window( Wnd: HWnd; const S: String ): Boolean;\r
var P: PChar;\r
begin\r
  Result := False;\r
  //Wnd := GetTopWindow( Wnd );\r
  Wnd := WaitFocusedWndChild( Wnd );\r
  if Wnd = 0 then Exit;\r
  P := PChar( S );\r
  while P^ <> #0 do\r
  begin\r
    PostMessage( Wnd, WM_CHAR, Integer( P^ ), 1 );\r
    Inc( P );\r
  end;\r
  Result := True;\r
end;\r
\r
//[function Stroke2WindowEx]\r
function Stroke2WindowEx( Wnd: HWnd; const S: String; Wait: Boolean ): Boolean;\r
var P: PChar;\r
    EndChar: Char;\r
    MsgDn, MsgUp, SCA: Integer;\r
\r
    function Compare( Pattern: PChar ): Boolean;\r
    var Pos: PChar;\r
        C1, C2: Char;\r
    begin\r
      Pos := P;\r
      while Pattern^ <> #0 do\r
      begin\r
        C1 := Pattern^;\r
        C2 := Pos^;\r
        if C1 in [ 'a'..'z' ] then\r
          C1 := Char( Ord( C1 ) - $20 );\r
        if C2 in [ 'a'..'z' ] then\r
          C2 := Char( Ord( C2 ) - $20 );\r
        if C1 <> C2 then\r
        begin\r
          Result := False;\r
          Exit;\r
        end;\r
        Inc( Pos );\r
        Inc( Pattern );\r
      end;\r
      while Pos^ = ' ' do Inc( Pos );\r
      P := Pos;\r
      Result := True;\r
    end;\r
\r
    procedure Send( Msg, KeyCode: Integer );\r
    var lParam: Integer;\r
    begin\r
      Wnd := WaitFocusedWndChild( Wnd );\r
      if Wnd = 0 then Exit;\r
      lParam := 1;\r
      if longBool( SCA and 4 ) then\r
        lParam := $20000001;\r
      if Msg = MsgUp then\r
        lParam := lParam or Integer($D0000000);\r
      PostMessage( Wnd, Msg, KeyCode, lParam );\r
      Applet.ProcessMessages;\r
      if Wait then\r
        Sleep( 50 );\r
    end;\r
\r
    function CompareSend( Pattern: PChar; Value2Send: Integer ): Boolean;\r
    begin\r
      if Compare( Pattern ) then\r
      begin\r
        Send( MsgDn, Value2Send );\r
        Send( MsgUp, Value2Send );\r
        Result := True;\r
      end\r
         else\r
        Result := False;\r
    end;\r
\r
    function ParseKeys( EndChar: Char ): PChar;\r
    var FN: Integer;\r
    begin\r
      SCA := 0;\r
      while not (P^ in [ #0, EndChar ]) do\r
      begin\r
        if Compare( 'Shift' ) then SCA := SCA or 1\r
        else\r
        if Compare( 'Ctrl' ) then SCA := SCA or 2\r
        else\r
        if Compare( 'Alt' ) then SCA := SCA or 4\r
        else\r
          break;\r
      end;\r
      MsgDn := WM_KEYDOWN;\r
      MsgUp := WM_KEYUP;\r
      if LongBool( SCA and 4 ) then\r
      begin\r
        MsgDn := WM_SYSKEYDOWN;\r
        MsgUp := WM_SYSKEYUP;\r
        keybd_event( VK_MENU, 0, 0, 0 );\r
        Send( WM_SYSKEYDOWN, VK_MENU );\r
      end;\r
      if LongBool( SCA and 2 ) then\r
      begin\r
        keybd_event( VK_CONTROL, 0, 0, 0 );\r
        Send( WM_KEYDOWN, VK_CONTROL );\r
      end;\r
      if Longbool( SCA and 1 ) then\r
      begin\r
        keybd_event( VK_SHIFT, 0, 0, 0 );\r
        Send( WM_KEYDOWN, VK_SHIFT );\r
      end;\r
      while not (P^ in [ #0, EndChar ]) do\r
      begin\r
        if (P^ = 'F') and (P[ 1 ] in [ '1'..'9' ]) then\r
        begin\r
          Inc( P );\r
          FN := Ord( P^ ) - Ord( '0' );\r
          if (FN = 1) and (P[ 1 ] in [ '0'..'2' ]) then\r
          begin\r
            Inc( P );\r
            FN := 10 + Ord( P^ ) - Ord( '0' );\r
          end;\r
          repeat Inc( P ) until P^ <> ' ';\r
          FN := FN + $6F;\r
          Send( MsgDn, FN );\r
          Send( MsgUp, FN );\r
        end\r
           else\r
        if Compare( 'Numpad' ) then\r
        begin\r
          if P^ in [ '0'..'9' ] then\r
          begin\r
            FN := Ord( P^ ) - Ord( '0' ) + $60;\r
            repeat Inc( P^ ) until P^ <> ' ';\r
            Send( MsgDn, FN );\r
            Send( MsgUp, FN );\r
          end;\r
        end\r
           else\r
        if not (CompareSend( 'Add', $6B ) or\r
                CompareSend( 'Gray+', $6B ) or\r
                CompareSend( 'Apps', $5D ) or\r
                CompareSend( 'BackSpace', $08 ) or\r
                CompareSend( 'BkSp', $08 ) or\r
                CompareSend( 'BS', $08 ) or\r
                CompareSend( 'Break', $13 ) or\r
                CompareSend( 'CapsLock', $14 ) or\r
                CompareSend( 'Clear', $0C ) or\r
                CompareSend( 'Decimal', $6E ) or\r
                CompareSend( 'Del', $2E ) or\r
                CompareSend( 'Delete', $2E ) or\r
                CompareSend( 'Divide', $6F ) or\r
                CompareSend( 'Gray/', $6F ) or\r
                CompareSend( 'Down', $28 ) or\r
                CompareSend( 'End', $23 ) or\r
                CompareSend( 'Enter', $0D ) or\r
                CompareSend( 'Return', $0D ) or\r
                CompareSend( 'CR', $0D ) or\r
                CompareSend( 'Esc', $1B ) or\r
                CompareSend( 'Escape', $1B ) or\r
                CompareSend( 'Help', $2F ) or\r
                CompareSend( 'Home', $24 ) or\r
                CompareSend( 'Ins', $2D ) or\r
                CompareSend( 'Insert', $2D ) or\r
                CompareSend( 'Left', $25 ) or\r
                CompareSend( 'LWin', $5B ) or\r
                CompareSend( 'Multiply', $6A ) or\r
                CompareSend( 'Gray*', $6A ) or\r
                CompareSend( 'NumLock', $90 ) or\r
                CompareSend( 'PgDn', $22 ) or\r
                CompareSend( 'PgUp', $21 ) or\r
                CompareSend( 'PrintScrn', $2C ) or\r
                CompareSend( 'Right', $27 ) or\r
                CompareSend( 'RWin', $5C ) or\r
                CompareSend( 'Separator', $6C ) or\r
                CompareSend( 'ScrollLock', $91 ) or\r
                CompareSend( 'Subtract', $6D ) or\r
                CompareSend( 'Tab', $09 ) or\r
                CompareSend( 'Gray-', $6D ) or\r
                CompareSend( 'Up', $26 )) then break;\r
      end;\r
      while not (P^ in [ #0, EndChar ]) do\r
      begin\r
        if P^ in [ 'A'..'Z', '0'..'9' ] then\r
        begin\r
          Send( MsgDn, Integer( P^ ) );\r
          Send( MsgUp, Integer( P^ ) );\r
        end\r
        else\r
        if P^ in [ #1..#255 ] then\r
          Stroke2Window( Wnd, '' + P^ );\r
        repeat Inc( P ) until (P^ <> ' ');\r
      end;\r
      if P^ = EndChar then\r
        Inc( P );\r
      if Longbool( SCA and 1 ) then\r
      begin\r
        Send( WM_KEYUP, VK_SHIFT );\r
        keybd_event( VK_SHIFT, 0, KEYEVENTF_KEYUP, 0 );\r
      end;\r
      if LongBool( SCA and 2 ) then\r
      begin\r
        Send( WM_KEYUP, VK_CONTROL );\r
        keybd_event( VK_CONTROL, 0, KEYEVENTF_KEYUP, 0 );\r
      end;\r
      if LongBool( SCA and 4 ) then\r
      begin\r
        Send( WM_SYSKEYUP, VK_MENU );\r
        keybd_event( VK_MENU, 0, KEYEVENTF_KEYUP, 0 );\r
      end;\r
      Result := P;\r
    end;\r
\r
begin\r
  Result := False;\r
  Wnd := GetTopWindow( Wnd );\r
  Wnd := GetFocusedChild( Wnd );\r
  if Wnd = 0 then Exit;\r
  P := PChar( S );\r
  while P^ <> #0 do\r
  begin\r
    if not (P^ in [ '[', '{' ]) then\r
    begin\r
      Stroke2Window( Wnd, '' + P^ );\r
      Inc( P );\r
    end\r
      else\r
    begin\r
      if P^ = '[' then\r
        EndChar := ']'\r
      else\r
        EndChar := '}';\r
      Inc( P );\r
      P := ParseKeys( EndChar );\r
    end;\r
  end;\r
  Result := True;\r
end;\r
\r
type\r
  PHWnd = ^HWnd;\r
\r
  TFindWndRec = packed Record\r
    ThreadID : DWord;\r
    WndFound : HWnd;\r
  end;\r
  PFindWndRec = ^TFindWndRec;\r
\r
//[function EnumWindowsProc]\r
function EnumWindowsProc( Wnd : HWnd; Find : PFindWndRec ) : Boolean;\r
stdcall;\r
var Id : DWord;\r
begin\r
  Result := True;\r
  Id := GetWindowThreadProcessId( Wnd, @Id );\r
  if Id = Find.ThreadID then\r
  begin\r
    Find.WndFound := Wnd;\r
    Result := False;\r
  end;\r
end;\r
\r
//[function FindWindowByThreadID]\r
function FindWindowByThreadID( ThreadID : DWORD ) : HWnd;\r
var Find : TFindWndRec;\r
begin\r
  Find.ThreadID := ThreadID;\r
  Find.WndFound := 0;\r
  EnumWindows( @EnumWindowsProc, Integer( @Find ) );\r
  Result := Find.WndFound;\r
end;\r
\r
//[function GetDesktopRect]\r
function GetDesktopRect : TRect;\r
var W1, W2 : HWnd;\r
begin\r
  Result := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) );\r
  W2 := findwindow(nil,'Program Manager');\r
  W1 := findwindowex(W2,0,'SHELLDLL_DefView',nil);\r
  if W1 = 0 then Exit;\r
  GetWindowRect( W1, Result );\r
end;\r
\r
//[function GetWorkArea]\r
function GetWorkArea: TRect;\r
begin\r
  SystemParametersInfo( SPI_GETWORKAREA, 0, @ Result, 0 );\r
end;\r
\r
//[function ExecuteWait]\r
function ExecuteWait( const AppPath, CmdLine, DfltDirectory: String;\r
         Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean;\r
var Flags: DWORD;\r
    Startup: TStartupInfo;\r
    ProcInf: TProcessInformation;\r
    DfltDir: PChar;\r
    App: String;\r
begin\r
  Result := FALSE;\r
  Flags := CREATE_NEW_CONSOLE;\r
  if Show = SW_HIDE then\r
    Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF};\r
  FillChar( Startup, SizeOf( Startup ), 0 );\r
  Startup.cb := Sizeof( Startup );\r
  Startup.wShowWindow := Show;\r
  Startup.dwFlags := STARTF_USESHOWWINDOW;\r
  if ProcID <> nil then\r
    ProcID^ := 0;\r
  DfltDir := nil;\r
  if DfltDirectory <> '' then\r
    DfltDir := PChar( DfltDirectory );\r
  if ProcID <> nil then\r
    ProcID^ := 0;\r
  App := AppPath;\r
  if (pos( ' ', App ) > 0) and (pos( '"', App ) <= 0) then\r
    App := '"' + App + '"';\r
  if (App <> '') and (CmdLine <> '') then\r
    App := App + ' ';\r
  if CreateProcess( nil, PChar( App + CmdLine ), nil,\r
     nil, FALSE, Flags, nil, DfltDir, Startup,\r
     ProcInf ) then\r
  begin\r
    if WaitForSingleObject( ProcInf.hProcess, TimeOut ) = WAIT_OBJECT_0 then\r
    begin\r
      CloseHandle( ProcInf.hProcess );\r
      Result := TRUE;\r
    end\r
      else\r
    begin\r
      if ProcID <> nil then\r
        ProcID^ := ProcInf.hProcess;\r
    end;\r
    CloseHandle( ProcInf.hThread );\r
  end;\r
end;\r
\r
//[function ExecuteIORedirect]\r
function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: String;\r
         Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean;\r
var Flags: DWORD;\r
    Startup: TStartupInfo;\r
    ProcInf: TProcessInformation;\r
    DfltDir: PChar;\r
    SecurityAttributes: TSecurityAttributes;\r
    SaveStdOut, SaveStdIn: THandle;\r
    ChildStdOutRd, ChildStdOutWr: THandle;\r
    ChildStdInRd, ChildStdInWr: THandle;\r
    ChildStdOutRdDup: THandle;\r
    ChildStdInWrDup: THandle;\r
\r
    procedure Do_CloseHandle( var Handle: THandle );\r
    begin\r
      if Handle <> 0 then\r
      begin\r
        CloseHandle( Handle );\r
        Handle := 0;\r
      end;\r
    end;\r
\r
    procedure Close_Handles;\r
    begin\r
      Do_CloseHandle( ChildStdOutRd );\r
      Do_CloseHandle( ChildStdOutWr );\r
      Do_CloseHandle( ChildStdInRd );\r
      Do_CloseHandle( ChildStdInWr );\r
    end;\r
\r
    function RedirectInputOutput: Boolean;\r
    begin\r
      Result := FALSE;\r
      if (OutPipeRd <> nil) or (OutPipeWr <> nil) then\r
      begin\r
        // redirect output\r
        SaveStdOut := GetStdHandle(STD_OUTPUT_HANDLE);\r
        if not CreatePipe( ChildStdOutRd, ChildStdOutWr, @ SecurityAttributes, 0 ) then\r
          Exit;\r
        if not SetStdHandle( STD_OUTPUT_HANDLE, ChildStdOutWr ) then\r
          Exit;\r
        if not DuplicateHandle( GetCurrentProcess, ChildStdOutRd,\r
           GetCurrentProcess, @ ChildStdOutRdDup, 0, FALSE,\r
           2 {DUPLICATE_SAME_ACCESS} ) then\r
          Exit;\r
        Do_CloseHandle( ChildStdOutRd );\r
        if OutPipeRd <> nil then\r
          OutPipeRd^ := ChildStdOutRdDup;\r
        if OutPipeWr <> nil then\r
          OutPipeWr^ := ChildStdOutWr;\r
      end;\r
      if InPipe <> nil then\r
      begin\r
        // redirect input\r
        SaveStdIn := GetStdHandle(STD_INPUT_HANDLE);\r
        if not CreatePipe( ChildStdInRd, ChildStdInWr, @ SecurityAttributes, 0 ) then\r
          Exit;\r
        if not SetStdHandle( STD_INPUT_HANDLE, ChildStdInRd ) then\r
          Exit;\r
        if not DuplicateHandle( GetCurrentProcess, ChildStdInWr,\r
           GetCurrentProcess, @ ChildStdInWrDup, 0, FALSE,\r
           2 {DUPLICATE_SAME_ACCESS} ) then\r
          Exit;\r
        Do_CloseHandle( ChildStdInWr );\r
        if InPipe <> nil then\r
          InPipe^ := ChildStdInWrDup;\r
        Do_CloseHandle( ChildStdInRd );\r
      end;\r
      Result := TRUE;\r
    end;\r
\r
    procedure Restore_Saved_StdInOut;\r
    begin\r
      //if SaveStdOut <> 0 then\r
        SetStdHandle( STD_OUTPUT_HANDLE, SaveStdOut );\r
      //if SaveStdin <> 0 then\r
        SetStdHandle( STD_INPUT_HANDLE, SaveStdIn );\r
    end;\r
\r
begin\r
  Result := FALSE;\r
  Flags := 0;\r
  if Show = SW_HIDE then\r
    Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF};\r
  FillChar( Startup, SizeOf( Startup ), 0 );\r
  Startup.cb := Sizeof( Startup );\r
  {Startup.wShowWindow := Show;\r
  Startup.dwFlags := STARTF_USESHOWWINDOW;}\r
  if ProcID <> nil then\r
    ProcID^ := 0;\r
  DfltDir := nil;\r
  SecurityAttributes.nLength := Sizeof( SecurityAttributes );\r
  SecurityAttributes.lpSecurityDescriptor := nil;\r
  SecurityAttributes.bInheritHandle := TRUE;\r
  SaveStdOut := 0;\r
  SaveStdIn := 0;\r
  ChildStdOutRd := 0;\r
  ChildStdOutWr := 0;\r
  ChildStdInRd := 0;\r
  ChildStdInWr := 0;\r
  if not RedirectInputOutput then\r
  begin\r
    Close_Handles;\r
    Exit;\r
  end;;\r
  if DfltDirectory <> '' then\r
    DfltDir := PChar( DfltDirectory );\r
  if CreateProcess( nil, PChar( '"' + AppPath + '" ' + CmdLine ),\r
     nil, nil, TRUE, Flags, nil, DfltDir, Startup,\r
     ProcInf ) then\r
  begin\r
    if ProcID <> nil then\r
      ProcID^ := ProcInf.hProcess\r
    else\r
      CloseHandle( ProcInf.hProcess );\r
    CloseHandle( ProcInf.hThread );\r
    Restore_Saved_StdInOut;\r
    Result := TRUE;\r
  end\r
    else\r
  begin\r
    Restore_Saved_StdInOut;\r
    Close_Handles;\r
    Exit;\r
  end;\r
end;\r
\r
//[function ExecuteConsoleAppIORedirect]\r
function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: String;\r
         Show: DWORD; const InStr: String; var OutStr: String; WaitTimeout: DWORD ): Boolean;\r
var PipeIn, PipeOutRd, PipeOutWr: THandle;\r
    ProcID: DWORD;\r
    BytesCount: DWORD;\r
    Buffer: array[ 0..4096 ] of Char;\r
    BufStr: String;\r
    PPipeIn: PHandle;\r
begin\r
  Result := FALSE;\r
  PPipeIn := @ PipeIn;\r
  if InStr = '' then\r
    PPipeIn := nil;\r
  PipeOutRd := 0;\r
  PipeOutWr := 0;\r
  if not ExecuteIORedirect( AppPath, CmdLine, DfltDirectory, Show, @ ProcID,\r
                     PPipeIn, @ PipeOutWr, @ PipeOutRd ) then Exit;\r
  if PPipeIn <> nil then\r
  begin\r
    if InStr <> '' then\r
      WriteFile( PipeIn, InStr[ 1 ], Length( InStr ), BytesCount, nil );\r
    CloseHandle( PipeIn );\r
  end;\r
  OutStr := '';\r
  if WaitForSingleObject( ProcID, WaitTimeOut ) = WAIT_OBJECT_0 then\r
  begin\r
    CloseHandle( ProcID );\r
    CloseHandle( PipeOutWr );\r
    while ReadFile( PipeOutRd, Buffer, Sizeof( Buffer ), BytesCount, nil ) do\r
    begin\r
      SetLength( BufStr, BytesCount );\r
      Move( Buffer[ 0 ], BufStr[ 1 ], BytesCount );\r
      OutStr := OutStr + BufStr;\r
    end;\r
  end\r
    else\r
    CloseHandle( PipeOutWr );\r
  CloseHandle( PipeOutRd );\r
  Result := TRUE;\r
end;\r
\r
{$IFDEF _D2}\r
//[API OpenProcessToken]\r
function OpenProcessToken(ProcessHandle: THandle; DesiredAccess: DWORD;\r
  var TokenHandle: THandle): BOOL; stdcall;\r
  external advapi32 name 'OpenProcessToken';\r
{$ENDIF}\r
\r
//[function WindowsShutdown]\r
function WindowsShutdown( const Machine : String; Force, Reboot : Boolean ) : Boolean;\r
var\r
  hToken: THandle;\r
  tkp, tkp_prev: TTokenPrivileges;\r
  dwRetLen :DWORD;\r
  Flags: Integer;\r
begin\r
  Result := False;\r
  if Integer( GetVersion ) < 0 then // Windows95/98/Me\r
  begin\r
    if Machine <> '' then Exit;\r
    Flags := EWX_SHUTDOWN;\r
    if Reboot then\r
      Flags := Flags or EWX_REBOOT;\r
    if Force then\r
      Flags := Flags or EWX_FORCE;\r
    Result := ExitWindowsEx( Flags, 0 );\r
    Exit;\r
  end;\r
\r
  OpenProcessToken(GetCurrentProcess(),\r
                   TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,\r
                   hToken);\r
\r
  if not LookupPrivilegeValue(PChar(Machine),\r
'SeShutdownPrivilege',tkp.Privileges[0].Luid)\r
     then\r
         Exit;\r
\r
  tkp_prev:=tkp;\r
  tkp.PrivilegeCount:=1;\r
  tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;\r
  AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev,\r
dwRetLen);\r
\r
  if not LookupPrivilegeValue(PChar(Machine),\r
                              'SeRemoteShutdownPrivilege',\r
                              tkp.Privileges[0].Luid)\r
     then\r
         Exit;\r
\r
  tkp.PrivilegeCount:=1;\r
  tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;\r
  AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev,\r
dwRetLen);\r
\r
  Result := InitiateSystemShutdown(PChar(Machine),nil, 0, Force, Reboot);\r
end;\r
\r
var SaveWinVer: Byte = $FF;\r
\r
//[function WinVer]\r
function WinVer : TWindowsVersion;\r
{* Returns Windows version. }\r
var OVI: TOsVersionInfo;\r
begin\r
  if SaveWinVer <> $FF then Result := TWindowsVersion( SaveWinVer )\r
  else\r
  begin\r
    OVI.dwOSVersionInfoSize := Sizeof( OVI );\r
    GetVersionEx( OVI );\r
    with OVI do\r
    if dwPlatformId = VER_PLATFORM_WIN32_NT then\r
    begin\r
      Result := wvNT;\r
      if dwMajorVersion >= 6 then\r
        Result := wvLongHorn\r
      else begin\r
             if dwMajorVersion >= 5 then\r
               if dwMinorVersion >=1 then\r
                 Result := wvXP\r
               else\r
                 Result := wvY2K;\r
           end;\r
    end\r
    {if dwPlatformId = VER_PLATFORM_WIN32_NT then\r
    begin\r
      Result := wvNT;\r
      if dwMajorVersion >= 5 then\r
        Result := wvY2K;\r
    end}\r
       else\r
    if dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then\r
    begin\r
      Result := wv95;\r
      if (dwMajorVersion > 4) or (dwMajorVersion = 4)\r
      and (dwMinorVersion >= 10)  then\r
        Result := wv98;\r
    end\r
       else\r
       Result := wv31; // Windows 3.1 (WIN32s)\r
    SaveWinVer := Ord( Result );\r
  end;\r
end;\r
\r
//[function IsWinVer]\r
function IsWinVer( Ver : TWindowsVersions ) : Boolean;\r
{* Returns True if Windows version is in given range of values. }\r
begin\r
  Result := WinVer in Ver;\r
end;\r
\r
//[procedure TControl.SetAlphaBlend]\r
procedure TControl.SetAlphaBlend(const Value: Integer);\r
const\r
  LWA_COLORKEY=$00000001;\r
  LWA_ALPHA=$00000002;\r
  ULW_COLORKEY=$00000001;\r
  ULW_ALPHA=$00000002;\r
  ULW_OPAQUE=$00000004;\r
  WS_EX_LAYERED=$00080000;\r
type\r
  TSetLayeredWindowAttributes=\r
    function( hwnd: Integer; crKey: TColor; bAlpha: Byte; dwFlags: DWORD )\r
    : Boolean; stdcall;\r
var\r
  SetLayeredWindowAttributes: TSetLayeredWindowAttributes;\r
  User32: THandle;\r
  dw: DWORD;\r
begin\r
  if Value = fAlphaBlend then Exit;\r
  fAlphaBlend := Value;\r
  User32 := GetModuleHandle( 'User32' );\r
  SetLayeredWindowAttributes := GetProcAddress( User32,\r
                             'SetLayeredWindowAttributes' );\r
  if Assigned( SetLayeredWindowAttributes ) then\r
  begin\r
    dw := GetWindowLong( GetWindowHandle, GWL_EXSTYLE );\r
    if Byte( Value ) < 255 then\r
    begin\r
      SetWindowLong( fHandle, GWL_EXSTYLE, dw or WS_EX_LAYERED );\r
      SetLayeredWindowAttributes( fHandle, 0, Value and $FF, LWA_ALPHA);\r
    end\r
       else\r
      SetWindowLong( fHandle, GWL_EXSTYLE, dw and not WS_EX_LAYERED );\r
  end;\r
end;\r
\r
//[function TControl.SetPosition]\r
function TControl.SetPosition( X, Y: Integer ): PControl;\r
begin\r
  Left := X;\r
  Top := Y;\r
  Result := @Self;\r
end;\r
\r
//[function NewColorDialog]\r
function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog;\r
var I: Integer;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PColorDialog.Create;*){--}\r
  Result.ColorCustomOption := FullOpen;\r
  for I := 1 to 16 do\r
    Result.CustomColors[ I ] := clWhite;\r
end;\r
//[END NewColorDialog]\r
\r
{ TColorDialog }\r
\r
//[function TColorDialog.Execute]\r
function TColorDialog.Execute: Boolean;\r
var CD: TChooseColor;\r
begin\r
  CD.lStructSize := Sizeof( CD );\r
  CD.hWndOwner := OwnerWindow;\r
  //CD.hInstance := 0;\r
  CD.rgbResult := Color2RGB( Color );\r
  CD.lpCustColors := @CustomColors[ 1 ];\r
  CD.Flags := CC_RGBINIT;\r
  case ColorCustomOption of\r
  ccoFullOpen: CD.Flags := CD.Flags or CC_FULLOPEN;\r
  ccoPreventFullOpen: CD.Flags := CD.Flags or CC_PREVENTFULLOPEN;\r
  end;\r
  Result := ChooseColor( CD );\r
  if Result then\r
    Color := CD.rgbResult;\r
end;\r
\r
//[procedure TControl.SetMaxProgress]\r
procedure TControl.SetMaxProgress(const Index, Value: Integer);\r
begin\r
  // ignore index, and set Value via PBM_SETRANGE32:     ()\r
  Perform( PBM_SETRANGE32, 0, Value );\r
end;\r
\r
//[procedure TControl.SetDroppedWidth]\r
procedure TControl.SetDroppedWidth(const Value: Integer);\r
begin\r
  FDroppedWidth := Value;\r
  Perform( CB_SETDROPPEDWIDTH, Value, 0 );\r
end;\r
\r
//[function TControl.LVGetItemState]\r
function TControl.LVGetItemState(Idx: Integer): TListViewItemState;\r
type\r
  PListViewItemState = ^TListViewItemState;\r
var I: Byte;\r
begin\r
  I := Perform( LVM_GETITEMSTATE, Idx,\r
                LVIS_CUT or LVIS_DROPHILITED or LVIS_FOCUSED or LVIS_SELECTED );\r
  Result := PListViewItemState( @ I )^;\r
end;\r
\r
//[procedure TControl.LVSetItemState]\r
procedure TControl.LVSetItemState(Idx: Integer; const Value: TListViewItemState);\r
var Data: TLVItem;\r
begin\r
  //FillChar( Data, Sizeof( Data ), 0 );\r
  //Data.mask := LVIF_DI_SETITEM or LVIF_STATE;\r
  Data.stateMask := LVIS_FOCUSED or LVIS_SELECTED or LVIS_CUT or LVIS_DROPHILITED;\r
  Data.state     := PByte( @ Value )^;\r
  //Data.iItem     := Idx;\r
  Perform( LVM_SETITEMSTATE, Idx, Integer( @Data ) );\r
end;\r
\r
//[procedure TControl.LVSelectAll]\r
procedure TControl.LVSelectAll;\r
begin\r
  LVSetItemState( -1, [ lvisSelect ] );\r
end;\r
\r
//[function TControl.LVItemInsert]\r
function TControl.LVItemInsert(Idx: Integer; const aText: String): Integer;\r
var LVI: TLVItem;\r
begin\r
  LVI.mask := LVIF_TEXT or LVIF_DI_SETITEM;\r
  LVI.iItem := Idx;\r
  LVI.iSubItem := 0;\r
  LVI.pszText := PChar( aText );\r
  Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) );\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function TControl.LVItemInsertW]\r
function TControl.LVItemInsertW(Idx: Integer;\r
  const aText: WideString): Integer;\r
var LVI: TLVItemW;\r
begin\r
  LVI.mask := LVIF_TEXT or LVIF_DI_SETITEM;\r
  LVI.iItem := Idx;\r
  LVI.iSubItem := 0;\r
  LVI.pszText := PWideChar( aText );\r
  Result := Perform( LVM_INSERTITEMW, 0, Integer( @LVI ) );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[function TControl.LVItemAdd]\r
function TControl.LVItemAdd(const aText: String): Integer;\r
begin\r
  Result := LVItemInsert( Count, aText );\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function TControl.LVItemAddW]\r
function TControl.LVItemAddW(const aText: WideString): Integer;\r
begin\r
  Result := LVItemInsertW( Count, aText );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[function TControl.LVGetSttImgIdx]\r
function TControl.LVGetSttImgIdx(Idx: Integer): Integer;\r
begin\r
  Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_STATEIMAGEMASK ) shr 12;\r
end;\r
\r
//[procedure TControl.LVSetSttImgIdx]\r
procedure TControl.LVSetSttImgIdx(Idx: Integer; const Value: Integer);\r
var LVI: TLVItem;\r
begin\r
  LVI.stateMask := LVIS_STATEIMAGEMASK;\r
  LVI.state := Value shl 12;\r
  Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) );\r
end;\r
\r
//[function TControl.LVGetOvlImgIdx]\r
function TControl.LVGetOvlImgIdx(Idx: Integer): Integer;\r
begin\r
  Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_OVERLAYMASK ) shr 8;\r
end;\r
\r
//[procedure TControl.LVSetOvlImgIdx]\r
procedure TControl.LVSetOvlImgIdx(Idx: Integer; const Value: Integer);\r
var LVI: TLVItem;\r
begin\r
  LVI.stateMask := LVIS_OVERLAYMASK;\r
  LVI.state := Value shl 8;\r
  Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) );\r
end;\r
\r
//[function TControl.LVGetItemData]\r
function TControl.LVGetItemData(Idx: Integer): DWORD;\r
var LVI: TLVItem;\r
begin\r
  LVI.mask := LVIF_PARAM;\r
  LVI.iItem := Idx;\r
  LVI.iSubItem := 0;\r
  Perform( LVM_GETITEM, 0, Integer( @LVI ) );\r
  Result := LVI.lParam;\r
end;\r
\r
//[procedure TControl.LVSetItemData]\r
procedure TControl.LVSetItemData(Idx: Integer; const Value: DWORD);\r
var LVI: TLVItem;\r
begin\r
  LVI.mask := LVIF_PARAM;\r
  LVI.iItem := Idx;\r
  LVI.iSubItem := 0;\r
  LVI.lParam := Value;\r
  Perform( LVM_SETITEM, 0, Integer( @LVI ) );\r
end;\r
\r
//[function TControl.LVGetItemIndent]\r
function TControl.LVGetItemIndent(Idx: Integer): Integer;\r
var LI: TLVItem;\r
begin\r
  LI.mask := LVIF_INDENT;\r
  LI.iItem := Idx;\r
  LI.iSubItem := 0;\r
  Perform( LVM_GETITEM, 0, Integer( @LI ) );\r
  Result := LI.iIndent;\r
end;\r
\r
//[procedure TControl.LVSetItemIndent]\r
procedure TControl.LVSetItemIndent(Idx: Integer; const Value: Integer);\r
var LI: TLVItem;\r
begin\r
  LI.mask := LVIF_INDENT or LVIF_DI_SETITEM;\r
  LI.iItem := Idx;\r
  LI.iSubItem := 0;\r
  LI.iIndent := Value;\r
  Perform( LVM_SETITEM, 0, Integer( @LI ) );\r
end;\r
\r
type\r
  TNMLISTVIEW = packed Record\r
    hdr: TNMHDR;\r
    iItem: Integer;\r
    iSubItem: Integer;\r
    uNewState: Integer;\r
    uOldState: Integer;\r
    uChanged: Integer;\r
    ptAction: Integer;\r
    lParam: DWORD;\r
  end;\r
  PNMLISTVIEW = ^TNMLISTVIEW;\r
\r
//[function WndProc_LVDeleteItem]\r
function WndProc_LVDeleteItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )\r
                          : Boolean;\r
var Hdr: PNMHDR;\r
    LV: PNMListView;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    Hdr := Pointer(Msg.lParam);\r
    if Hdr.hwndFrom = Sender.Handle then\r
    begin\r
      LV := Pointer( Hdr );\r
      if Hdr.code = LVN_DELETEITEM then\r
      begin\r
        if Assigned( Sender.OnDeleteLVItem ) then\r
          Sender.OnDeleteLVItem( Sender, LV.iItem );\r
        Result := TRUE;\r
      end\r
        else\r
      if Hdr.code = LVN_DELETEALLITEMS then\r
      begin\r
        if Assigned( Sender.OnDeleteAllLVItems ) then\r
        begin\r
          Sender.OnDeleteAllLVItems( Sender );\r
          Rslt := 0;\r
          if Assigned( Sender.OnDeleteLVItem ) then\r
            Rslt := 1;\r
        end;\r
        Result := TRUE;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnDeleteAllLVItems]\r
procedure TControl.SetOnDeleteAllLVItems(const Value: TOnEvent);\r
begin\r
  fOnDeleteAllLVItems := Value;\r
  AttachProc( @WndProc_LVDeleteItem );\r
end;\r
\r
//[procedure TControl.SetOnDeleteLVItem]\r
procedure TControl.SetOnDeleteLVItem(const Value: TOnDeleteLVItem);\r
begin\r
  fOnDeleteLVItem := Value;\r
  AttachProc( @WndProc_LVDeleteItem );\r
end;\r
\r
//[function WndProc_LVData]\r
function WndProc_LVData( Sender: PControl; var Msg: TMsg; var Rslt: Integer )\r
                          : Boolean;\r
var Hdr: PNMHDR;\r
    DI: PLVDispInfo;\r
    Store: Boolean;\r
    Txt: String;\r
    LV: PControl;\r
    {$IFDEF UNICODE_CTRLS}\r
    TxtW: WideString;\r
    {$ENDIF UNICODE_CTRLS}\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    Hdr := Pointer(Msg.lParam);\r
    if Hdr.hwndFrom = Sender.Handle then\r
    begin\r
      if (Hdr.code = LVN_GETDISPINFO)\r
         {$IFDEF UNICODE_CTRLS}\r
         or (Hdr.code = LVN_GETDISPINFOW)\r
         {$ENDIF UNICODE_CTRLS}\r
      then\r
      begin\r
        DI := Pointer( Hdr );\r
        LV := Sender;\r
        if LV <> nil then\r
        begin\r
          Txt := '';\r
          DI.item.iImage := -1;\r
          DI.item.state := 0;\r
          Store := FALSE;\r
          if (Assigned( LV.OnLVData )\r
               {$IFDEF UNICODE_CTRLS}\r
               or Assigned( LV.OnLVDataW )\r
               {$ENDIF UNICODE_CTRLS}\r
             )\r
             and (DI.item.iItem >= 0) then\r
          begin\r
            {$IFDEF UNICODE_CTRLS}\r
            TxtW := '';\r
            if Assigned( LV.ONLVDataW ) then\r
              LV.OnLVDataW( LV, DI.item.iItem, DI.item.iSubItem, TxtW,\r
                            DI.item.iImage, DWORD( DI.item.state ), Store )\r
            else\r
            {$ENDIF UNICODE_CTRLS}\r
            LV.OnLVData( LV, DI.item.iItem, DI.item.iSubItem, Txt,\r
                             DI.item.iImage, DWORD( DI.item.state ), Store );\r
            {$IFNDEF UNICODE_CTRLS}\r
            if (LV.fCaption = nil) or (Integer( StrLen( LV.fCaption ) ) <=\r
               Length( Txt ) ) then\r
            {$ENDIF UNICODE_CTRLS}\r
            begin\r
              if LV.fCaption <> nil then\r
                FreeMem( LV.fCaption );\r
              {$IFDEF UNICODE_CTRLS}\r
              GetMem( LV.fCaption, (Length( Txt ) + Length( TxtW ) + 1)\r
                      * Sizeof( WideChar ) );\r
              {$ELSE NOT_UNICODE_CTRLS}\r
              GetMem( LV.fCaption, Length( Txt ) + 1 );\r
              {$ENDIF NOT_UNICODE_CTRLS}\r
            end;\r
            {$IFDEF UNICODE_CTRLS}\r
            PWord( @ LV.fCaption[ 0 ] )^ := 0;\r
            {$ELSE}\r
            LV.fCaption[ 0 ] := #0;\r
            {$ENDIF}\r
            if Txt {$IFDEF UNICODE_CTRLS} + TxtW {$ENDIF UNICODE_CTRLS}\r
               <> '' then\r
            begin\r
              {$IFDEF UNICODE_CTRLS}\r
              if Hdr.code = LVN_GETDISPINFOW then\r
              begin\r
                if Txt <> '' then\r
                  TxtW := Txt;\r
                Move( TxtW[ 1 ], LV.fCaption[ 0 ], (Length( TxtW ) + 1) * Sizeof( WideChar ) );\r
              end else\r
              {$ENDIF UNICODE_CTRLS}\r
              StrCopy( LV.fCaption, @Txt[ 1 ] );\r
            end;\r
            DI.item.pszText := LV.fCaption;\r
            if Store then\r
              DI.item.mask := DI.item.mask or LVIF_DI_SETITEM;\r
          end;\r
          Result := TRUE;\r
        end;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnLVData]\r
procedure TControl.SetOnLVData(const Value: TOnLVData);\r
begin\r
  fOnLVData := Value;\r
  AttachProc( @WndProc_LVData );\r
  Perform( LVM_SETCALLBACKMASK, LVIS_OVERLAYMASK or LVIS_STATEIMAGEMASK, 0 );\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[procedure TControl.SetOnLVDataW]\r
procedure TControl.SetOnLVDataW(const Value: TOnLVDataW);\r
begin\r
  fOnLVDataW := Value;\r
  AttachProc( @WndProc_LVData );\r
  Perform( LVM_SETCALLBACKMASK, LVIS_OVERLAYMASK or LVIS_STATEIMAGEMASK, 0 );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[function WndProc_LVCustomDraw]\r
function WndProc_LVCustomDraw( Sender: PControl; var Msg: TMsg;\r
                               var Rslt: Integer ): Boolean;\r
var NMCustDraw: PNMLVCustomDraw;\r
    NMHdr: PNMHdr;\r
    ItemIdx, SubItemIdx: Integer;\r
    S: TListViewItemState;\r
    ItemState: TDrawState;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NMHdr := Pointer( Msg.lParam );\r
    if (NMHdr.code = NM_CUSTOMDRAW) and Assigned( Sender.fOnLVCustomDraw ) then\r
    begin\r
      NMCustDraw := Pointer( Msg.lParam );\r
      ItemIdx := -1;\r
      SubItemIdx := -1;\r
      if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_ITEM ) then\r
        ItemIdx := NMCustDraw.nmcd.dwItemSpec;\r
      if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_SUBITEM ) then\r
        SubItemIdx := NMCustDraw.iSubItem;\r
      ItemState := [ ];\r
      if ItemIdx >= 0 then\r
      begin\r
        S := Sender.LVItemState[ ItemIdx ];\r
        if lvisFocus in S then\r
          ItemState := ItemState + [ odsFocused ];\r
        if lvisSelect in S then\r
          ItemState := ItemState + [ odsSelected ];\r
        if lvisBlend in S then\r
          ItemState := ItemState + [ odsGrayed ];\r
        if lvisHighlight in S then\r
          ItemState := ItemState + [ odsMarked ];\r
      end;\r
\r
      Sender.Canvas;\r
\r
      Rslt := Sender.FOnLVCustomDraw( Sender, {Sender.Canvas.Handle} NMCustDraw.nmcd.hdc,\r
           NMCustDraw.nmcd.dwDrawStage, ItemIdx, SubItemIdx, NMCustDraw.nmcd.rc,\r
           ItemState, TColor( NMCustDraw.clrText ), TColor( NMCustDraw.clrTextBk ) );\r
\r
      Result := TRUE;\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnLVCustomDraw]\r
procedure TControl.SetOnLVCustomDraw(const Value: TOnLVCustomDraw);\r
begin\r
  fOnLVCustomDraw := Value;\r
  AttachProc( @WndProc_LVCustomDraw );\r
end;\r
\r
//[function CompareLVItems]\r
function CompareLVItems( Idx1, Idx2: Integer; ListView: PControl ): Integer; stdcall;\r
begin\r
  if Assigned( ListView.fOnCompareLVItems ) then\r
    Result := ListView.fOnCompareLVItems( ListView, Idx1, Idx2 )\r
  else\r
    Result := 0;\r
end;\r
\r
//[procedure TControl.LVSort]\r
procedure TControl.LVSort;\r
begin\r
  Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVItems) );\r
end;\r
\r
//[function CompareLVItemsData]\r
function CompareLVItemsData( D1, D2: DWORD; ListView: PControl ): Integer; stdcall;\r
begin\r
  if Assigned( ListView.fOnCompareLVItems ) then\r
    Result := ListView.fOnCompareLVItems( ListView, D1, D2 )\r
  else\r
    Result := 0;\r
end;\r
\r
//[procedure TControl.LVSortData]\r
procedure TControl.LVSortData;\r
begin\r
  Perform( LVM_SORTITEMS, Integer( @Self ), Integer( @CompareLVItemsData ) );\r
end;\r
\r
//[function WndProc_LVColumnClick]\r
function WndProc_LVColumnClick( Sender: PControl; var Msg: TMsg; var Rslt: Integer )\r
                          : Boolean;\r
var Hdr: PNMHDR;\r
    LV: PNMListView;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    Hdr := Pointer(Msg.lParam);\r
    if Hdr.hwndFrom = Sender.Handle then\r
    begin\r
      LV := Pointer( Hdr );\r
      if Hdr.code = LVN_COLUMNCLICK then\r
      begin\r
        if Assigned( Sender.OnColumnClick ) then\r
          Sender.OnColumnClick( Sender, LV.iSubItem );\r
        Result := TRUE;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnColumnClick]\r
procedure TControl.SetOnColumnClick(const Value: TOnLVColumnClick);\r
begin\r
  fOnColumnClick := Value;\r
  AttachProc( @WndProc_LVColumnClick );\r
end;\r
\r
//[function WndProc_LVStateChange]\r
function WndProc_LVStateChange( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean;\r
var NMOD: PNMLVODStateChange;\r
    NMLV: PNMLISTVIEW;\r
begin\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NMOD := Pointer( Msg.lParam );\r
    NMLV := Pointer( Msg.lParam );\r
    if NMOD.hdr.code = LVN_ODSTATECHANGED then\r
    begin\r
      if Assigned( Sender.OnLVStateChange ) then\r
        Sender.OnLVStateChange( Sender, NMOD.iFrom, NMOD.iTo,\r
                                NMOD.uOldState, NMOD.uNewState );\r
    end\r
      else\r
    if NMLV.hdr.code = LVN_ITEMCHANGED then\r
    begin\r
      if Assigned( Sender.OnLVStateChange ) then\r
        Sender.OnLVStateChange( Sender, NMLV.iItem, NMLV.iItem,\r
                                NMLV.uOldState, NMLV.uNewState );\r
    end;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.SetOnLVStateChange]\r
procedure TControl.SetOnLVStateChange(const Value: TOnLVStateChange);\r
begin\r
  FOnLVStateChange := Value;\r
  AttachProc( WndProc_LVStateChange );\r
end;\r
\r
//[function WndProc_LVDelete]\r
function WndProc_LVDelete( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean;\r
var NMLV: PNMLISTVIEW;\r
begin\r
  if Msg.message = WM_NOTIFY then\r
  begin\r
    NMLV := Pointer( Msg.lParam );\r
    if NMLV.hdr.code = LVN_DELETEITEM then\r
    begin\r
      if Assigned( Sender.OnLVDelete ) then\r
        Sender.OnLVDelete( Sender, NMLV.iItem );\r
    end;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.SetOnLVDelete]\r
procedure TControl.SetOnLVDelete(const Value: TOnLVDelete);\r
begin\r
  FOnLVDelete := Value;\r
  Add2AutoFreeEx( Clear );\r
  AttachProcEx( WndProc_LVDelete, TRUE );\r
  if fParent <> nil then\r
  begin\r
    fParent.DetachProc( WndProcNotify );\r
    fParent.AttachProcEx( WndProcNotify, TRUE );\r
  end;\r
end;\r
\r
//[function CompareLVColumns]\r
function CompareLVColumns( Idx1, Idx2: Integer; Sender: PControl ): Integer; stdcall;\r
var S1, S2: String;\r
begin\r
  //--- changed by Mike Gerasimov:\r
  S1 := Sender.LVItems[ Idx1, Sender.fColumn ];\r
  S2 := Sender.LVItems[ Idx2, Sender.fColumn ];\r
  If lvoSortAscending in Sender.fLVOptions Then\r
   Result := AnsiCompareStrNoCase( S1, S2 )\r
  Else\r
   If lvoSortDescending in Sender.fLVOptions Then\r
    Result := AnsiCompareStrNoCase( S2, S1 )\r
   Else\r
    Result:=0;\r
end;\r
\r
//[procedure TControl.LVSortColumn]\r
procedure TControl.LVSortColumn(Idx: Integer);\r
begin\r
  fColumn := Idx;\r
  Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVColumns) );\r
end;\r
\r
//[function TControl.LVIndexOf]\r
function TControl.LVIndexOf(const S: String): Integer;\r
begin\r
  Result := LVSearchFor( S, -1, FALSE );\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function TControl.LVIndexOfW]\r
function TControl.LVIndexOfW(const S: WideString): Integer;\r
begin\r
  Result := LVSearchForW( S, -1, FALSE );\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
//[function TControl.LVSearchFor]\r
function TControl.LVSearchFor(const S: String; StartAfter: Integer;\r
  Partial: Boolean): Integer;\r
var f: TLVFindInfo;\r
begin\r
    f.lParam := 0;\r
    f.flags  := LVFI_STRING;\r
    if Partial then\r
      f.flags := LVFI_STRING or LVFI_PARTIAL;\r
    f.psz    := @s[1];\r
    result := Perform(LVM_FINDITEM,StartAfter,integer(@f));\r
end;\r
\r
{$IFNDEF _FPC}\r
{$IFNDEF _D2}\r
//[function TControl.LVSearchForW]\r
function TControl.LVSearchForW(const S: WideString; StartAfter: Integer;\r
  Partial: Boolean): Integer;\r
var f: TLVFindInfoW;\r
begin\r
    f.lParam := 0;\r
    f.flags  := LVFI_STRING;\r
    if Partial then\r
      f.flags := LVFI_STRING or LVFI_PARTIAL;\r
    f.psz    := @s[1];\r
    result := Perform(LVM_FINDITEMW,StartAfter,integer(@f));\r
end;\r
{$ENDIF _D2}\r
{$ENDIF _FPC}\r
\r
function WndProcLVMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
const\r
  ClsName: PChar = 'obj_SysListView32'#0;\r
var\r
  pMI: PMeasureItemStruct;\r
  pLV: PControl;\r
  H: Integer;\r
  wnd: HWND;\r
  wId: DWORD;\r
\r
begin\r
\r
  Result := FALSE;\r
  if Msg.message = WM_MEASUREITEM then begin\r
    pMI := Pointer(Msg.lParam);\r
    with pMI^ do begin\r
      if CtlType=ODT_LISTVIEW then begin\r
        wnd := 0;\r
\r
        repeat\r
          wnd := FindWindowEx(Sender.GetWindowHandle,wnd,ClsName,nil);\r
          wId := GetWindowLong(wnd,GWL_ID);\r
          if CtlID = wId then begin\r
            pLV := Pointer(GetProp(wnd,ID_SELF));\r
            if pLV <> nil then begin\r
              H := pLV.Perform(WM_MEASUREITEM,0,0);\r
              if H > 0 then begin\r
                itemHeight := H;\r
                Rslt:=1;\r
                Result := TRUE;\r
              end;\r
              break;\r
            end;\r
          end;\r
        until wnd = 0;\r
\r
      end;\r
    end;\r
  end;\r
end;\r
\r
function WndProcLVMeasureItem2( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
begin\r
  Result := FALSE;\r
  if (Msg.message = WM_MEASUREITEM) and (Msg.wParam = 0) then begin\r
    Rslt := Sender.fLVItemHeight;\r
    Result := TRUE;\r
  end;\r
\r
end;\r
\r
function TControl.SetLVItemHeight(Value: Integer): PControl;\r
begin\r
  Set_LVItemHeight( Value );\r
  Result := @ Self;\r
end;\r
\r
procedure TControl.Set_LVItemHeight(Value: Integer);\r
begin\r
  if fLVItemHeight <> Value then begin\r
    if fLVItemHeight = 0 then begin\r
      Parent.AttachProc(WndProcLVMeasureItem);\r
      AttachProc(WndProcLVMeasureItem2);\r
    end;\r
    fLVItemHeight := Value;\r
  end;\r
end;\r
\r
//[function TControl.IndexOf]\r
function TControl.IndexOf(const S: String): Integer;\r
begin\r
  Result := SearchFor( S, -1, FALSE );\r
end;\r
\r
//[function TControl.SearchFor]\r
function TControl.SearchFor(const S: String; StartAfter: Integer;\r
  Partial: Boolean): Integer;\r
var Cmd: Integer;\r
    I: Integer;\r
begin\r
  Cmd := fCommandActions.aFindItem;\r
  if Partial then\r
    Cmd := fCommandActions.aFindPartial;\r
  if Cmd <> 0 then\r
    Result := Perform( Cmd, StartAfter, Integer( PChar( S ) ) )\r
  else\r
  begin\r
    Result := -1;\r
    for I := StartAfter+1 to Count-1 do\r
    begin\r
      if Partial and ( Copy( Items[ I ], 1, Length( S ) ) = S ) or\r
         ( Items[ I ] = S ) then\r
      begin\r
        Result := I;\r
        break;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//[function TControl.DefaultBtnProc]\r
function TControl.DefaultBtnProc(var Msg: TMsg;\r
  var Rslt: Integer): Boolean;\r
var Btn: PControl;\r
    F: PControl;\r
    //Msg1: TMsg;\r
begin\r
  if Assigned( fOldOnMessage ) then\r
  begin\r
    Result := fOldOnMessage( Msg, Rslt );\r
    if Result then Exit;\r
  end;\r
  Result := FALSE;\r
  if AppletTerminated then Exit;\r
  F := Applet;\r
  if not F.fIsForm then\r
  begin\r
    F := F.fCurrentControl;\r
    if F = nil then Exit;\r
  end;\r
  Btn := nil;\r
  if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and\r
     ((Msg.wParam = VK_RETURN) or (Msg.wParam = VK_ESCAPE)) then\r
  begin\r
    if (Msg.wParam = VK_RETURN) and\r
       (F.fDefaultBtnCtl <> nil) and\r
       F.fDefaultBtnCtl.ToBeVisible and\r
       F.fDefaultBtnCtl.Enabled and\r
       ((F.fCurrentControl=nil) or (not F.fCurrentControl.fCancelBtn and\r
                                    not F.fCurrentControl.fIgnoreDefault)\r
                                or (F.fCurrentControl = F.fDefaultBtnCtl)\r
       ) then\r
       Btn := F.fDefaultBtnCtl\r
      else\r
    if (Msg.wParam = VK_ESCAPE) and\r
       (F.fCancelBtnCtl <> nil) and\r
       F.fCancelBtnCtl.ToBeVisible and\r
       F.fCancelBtnCtl.Enabled then\r
       Btn := F.fCancelBtnCtl\r
      else\r
    if (Msg.wParam = VK_RETURN) and\r
       (F.fAllBtnReturnClick or fAllBtnReturnClick) and\r
       (F.ActiveControl <> nil) and\r
       (F.ActiveControl.IsButton) and\r
       (F.ActiveControl.Count = 0) then\r
       Btn := F.ActiveControl;\r
    if Btn <> nil then\r
    begin\r
      if Msg.message = WM_KEYDOWN then\r
        Btn.Focused := TRUE;\r
      Btn.Perform( Msg.message, DWORD( ' ' ), Msg.lParam );\r
      Msg.wParam := 0;\r
      Result := TRUE;\r
      Rslt := 0;\r
      Exit;\r
    end\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.SetDefaultBtn]\r
procedure TControl.SetDefaultBtn(const Index: Integer;\r
  const Value: Boolean);\r
var F, C: PControl;\r
begin\r
  if Index = 13 then\r
  begin\r
    fDefaultBtn := Value;\r
    fCancelBtn := FALSE;\r
  end\r
    else\r
  if Index = 27 then\r
  begin\r
    fCancelBtn := Value;\r
    fDefaultBtn := FALSE;\r
  end;\r
  if Applet = nil then Exit;\r
  F := ParentForm;\r
  if F <> nil then\r
  begin\r
    if Value then\r
    begin\r
      if @ Applet.fOnMessage <> @ TControl.DefaultBtnProc  then\r
        Applet.fOldOnMessage := Applet.fOnMessage; // fixed by YS\r
      Applet.fOnMessage := Applet.DefaultBtnProc;\r
    end\r
      else\r
    begin\r
      Applet.fOnMessage := Applet.fOldOnMessage;\r
      Applet.fOldOnMessage := nil;\r
    end;\r
    C := nil;\r
    if Value then C := @ Self;\r
    if Index = 13 then\r
    begin\r
      F.fDefaultBtnCtl := C;\r
      if Value then\r
        Style := Style or BS_DEFPUSHBUTTON\r
      else\r
        Style := Style and not BS_DEFPUSHBUTTON;\r
    end\r
    else\r
    if Index = 27 then\r
      F.fCancelBtnCtl := C;\r
  end;\r
end;\r
\r
{$IFDEF F_P}\r
//[function TControl.GetDefaultBtn]\r
function TControl.GetDefaultBtn(const Index: Integer): Boolean;\r
begin\r
  CASE Index OF\r
  13: Result := fDefaultBtn;\r
  27: Result := fCancelBtn;\r
  END;\r
end;\r
{$ENDIF F_P}\r
\r
//[function TControl.AllBtnReturnClick]\r
function TControl.AllBtnReturnClick: PControl;\r
{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}\r
begin\r
  // nothing: already implemented in WndProcBtnReturnClick\r
  Result := @ Self;\r
end;\r
{$ELSE}\r
var F: PControl;\r
begin\r
  SetDefaultBtn( 0, TRUE );\r
  F := ParentForm;\r
  if F <> nil then\r
    F.fAllBtnReturnClick := TRUE;\r
  Result := @ Self;\r
end;\r
{$ENDIF}\r
\r
//[function WndProc_CNDrawItem]\r
function WndProc_CNDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )\r
                          : Boolean;\r
type PDrawAction = ^TDrawAction;\r
     PDrawState = ^TDrawState;\r
var DI: PDrawItemStruct;\r
begin\r
  Result := FALSE;\r
  if Msg.message = CN_DRAWITEM then\r
  begin\r
    DI := Pointer( Msg.lParam );\r
    if Assigned( Sender.OnDrawItem ) then\r
    begin\r
      if Sender.OnDrawItem( Sender, DI.hDC, DI.rcItem, DI.itemID,\r
                         PDrawAction( @ DI.itemAction )^,\r
                         PDrawState( @ DI.itemState )^ )\r
        then Rslt := 1\r
        else Rslt := 0;\r
      Result := TRUE;\r
    end\r
      else Rslt := 0;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnDrawItem]\r
procedure TControl.SetOnDrawItem(const Value: TOnDrawItem);\r
begin\r
  fOnDrawItem := Value;\r
  if Parent <> nil then\r
    Parent.AttachProc( @WndProc_DrawItem );\r
  AttachProc( @WndProc_CNDrawItem );\r
end;\r
\r
//[function WndProc_MeasureItem]\r
function WndProc_MeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )\r
                          : Boolean;\r
var MI: PMeasureItemStruct;\r
    Control: PControl;\r
    I: Integer;\r
begin\r
  Result := FALSE;\r
  if Msg.message = WM_MEASUREITEM then\r
  begin\r
    MI := Pointer( Msg.lParam );\r
    for I := 0 to Sender.ChildCount - 1 do\r
    begin\r
      Control := Sender.Children[ I ];\r
      if Control.Menu = MI.CtlID then\r
      begin\r
        if Assigned( Control.OnMeasureItem ) then\r
        begin\r
          MI.itemHeight := Control.OnMeasureItem( Control, MI.itemID );\r
          if MI.itemHeight > 0 then\r
          begin\r
            Rslt := 1;\r
            Result := TRUE;\r
          end;\r
        end;\r
        break;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.SetOnMeasureItem]\r
procedure TControl.SetOnMeasureItem(const Value: TOnMeasureItem);\r
begin\r
  fOnMeasureItem := Value;\r
  if Parent <> nil then\r
    Parent.AttachProc( @WndProc_MeasureItem );\r
end;\r
\r
//[function TControl.GetItemData]\r
function TControl.GetItemData(Idx: Integer): DWORD;\r
begin\r
  Result := 0;\r
  if fCommandActions.aGetItemData <> 0 then\r
    Result := Perform( fCommandActions.aGetItemData, Idx, 0 );\r
end;\r
\r
//[procedure TControl.SetItemData]\r
procedure TControl.SetItemData(Idx: Integer; const Value: DWORD);\r
begin\r
  if fCommandActions.aSetItemData <> 0 then\r
    Perform( fCommandActions.aSetItemData, Idx, Value );\r
end;\r
\r
//[function TControl.GetLVCurItem]\r
function TControl.GetLVCurItem: Integer;\r
begin\r
  Result := Perform( LVM_GETNEXTITEM, -1, LVNI_SELECTED );\r
end;\r
\r
//[procedure TControl.SetLVCurItem]\r
procedure TControl.SetLVCurItem(const Value: Integer);\r
begin\r
  if (lvoMultiselect in LVOptions) or (Value <> LVCurItem ) then\r
    LVItemState[ -1 ] := [ ];\r
  if Value >= 0 then\r
    LVItemState[ Value ] := [ lvisSelect, lvisFocus ];\r
end;\r
\r
//[function TControl.LVNextItem]\r
function TControl.LVNextItem(IdxPrev: Integer; Attrs: DWORD): Integer;\r
begin\r
  Result := Perform( LVM_GETNEXTITEM, IdxPrev, Attrs );\r
end;\r
\r
//[function TControl.LVNextSelected]\r
function TControl.LVNextSelected(IdxPrev: Integer): Integer;\r
begin\r
  Result := Perform( LVM_GETNEXTITEM, IdxPrev, LVNI_SELECTED );\r
end;\r
\r
//[procedure TControl.Close]\r
procedure TControl.Close;\r
begin\r
  PostMessage( Handle, WM_CLOSE, 0, 0 );\r
end;\r
\r
//[function WndProcMinimize]\r
function WndProcMinimize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Wnd: PControl;\r
begin\r
  Result := FALSE;\r
  if (Msg.message = WM_SYSCOMMAND) and ((Msg.wParam and $FFF0) = SC_MINIMIZE)then\r
  begin\r
    if Applet <> nil then\r
    begin\r
      Wnd := Applet.FMinimizeWnd;\r
      if Wnd <> nil then\r
        SetWindowPos( Applet.Handle, 0, Wnd.Left, Wnd.Top, Wnd.Width, 0,\r
                      SWP_NOZORDER or SWP_NOREDRAW);\r
    end;\r
  end;\r
end;\r
\r
//[procedure TControl.MinimizeNormalAnimated]\r
procedure TControl.MinimizeNormalAnimated;\r
var App: PControl;\r
begin\r
  App := Applet;\r
  if App = nil then\r
    App := @Self;\r
  App.FMinimizeWnd := @Self;\r
  App.AttachProc( @WndProcMinimize );\r
end;\r
\r
//[function WndProcDropFiles]\r
function WndProcDropFiles( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var hDrop: THandle;\r
    Pt: TPoint;\r
    FList: String;\r
    I, N: Integer;\r
    Buf: array[ 0..MAX_PATH ] of Char;\r
begin\r
  if Msg.message = WM_DROPFILES then\r
  if Assigned( Sender.FOnDropFiles ) then\r
  begin\r
    hDrop := Msg.wParam;\r
    DragQueryPoint( hDrop, Pt );\r
    N := DragQueryFile( hDrop, $FFFFffff, nil, 0 );\r
    FList := '';\r
    for I := 0 to N-1 do\r
    begin\r
      if FList <> '' then\r
        FList := FList + #13;\r
      DragQueryFile( hDrop, I, Buf, Sizeof( Buf ) );\r
      FList := FList + Buf;\r
    end;\r
    DragFinish( hDrop );\r
    Sender.FOnDropFiles( Sender, FList, Pt );\r
    Rslt := 0;\r
    Result := TRUE;\r
    Exit;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.SetOnDropFiles]\r
procedure TControl.SetOnDropFiles(const Value: TOnDropFiles);\r
begin\r
  FOnDropFiles := Value;\r
  AttachProc( @WndProcDropFiles );\r
  DragAcceptFiles( GetWindowHandle, Assigned( Value ) );\r
end;\r
\r
//[function WndProcShowHide]\r
function WndProcShowHide( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var IsVisible: Boolean;\r
begin\r
  if Msg.message = WM_SHOWWINDOW then\r
  if Msg.hwnd = Sender.Handle then\r
  begin\r
    IsVisible := IsWindowVisible( Sender.Handle );\r
    if LongBool( Msg.wParam ) then\r
    begin\r
      Sender.fVisible := TRUE;\r
      if not IsVisible then\r
      if Assigned( Sender.FOnShow ) then\r
        Sender.FOnShow( Sender );\r
    end\r
      else\r
    begin\r
      Sender.fVisible := FALSE;\r
      if IsVisible then\r
      if Assigned( Sender.FOnHide ) then\r
        Sender.FOnHide( Sender );\r
    end;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.SetOnHide]\r
procedure TControl.SetOnHide(const Value: TOnEvent);\r
begin\r
  FOnHide := Value;\r
  AttachProc( WndProcShowHide );\r
end;\r
\r
//[procedure TControl.SetOnShow]\r
procedure TControl.SetOnShow(const Value: TOnEvent);\r
begin\r
  FOnShow := Value;\r
  AttachProc( WndProcShowHide );\r
end;\r
\r
//[function TControl.BringToFront]\r
function TControl.BringToFront: PControl;\r
begin\r
  SetWindowPos( GetWindowHandle, HWND_TOP, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or\r
                SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_SHOWWINDOW );\r
  Result := @Self;\r
end;\r
\r
//[function TControl.SendToBack]\r
function TControl.SendToBack: PControl;\r
begin\r
  SetWindowPos( GetWindowHandle, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or\r
                SWP_NOACTIVATE or SWP_NOOWNERZORDER );\r
  Result := @Self;\r
end;\r
\r
//[procedure TControl.DragStart]\r
procedure TControl.DragStart;\r
begin\r
  PostMessage( GetWindowHandle, WM_SYSCOMMAND, $F012, 0 );\r
end;\r
\r
//[function WndProcDragWindow]\r
function WndProcDragWindow( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var P: TPoint;\r
begin\r
  if Msg.message = WM_MOUSEMOVE then\r
  begin\r
    if Sender.FDragging then\r
    begin\r
      GetCursorPos( P );\r
      P.x := P.x - Sender.fMouseStartPos.x + Sender.fDragStartPos.x;\r
      P.y := P.y - Sender.fMouseStartPos.y + Sender.fDragStartPos.y;\r
      Sender.Position := P;\r
    end;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.DragStartEx]\r
procedure TControl.DragStartEx;\r
var StartBounds: TRect;\r
begin\r
  GetCursorPos( fMouseStartPos );\r
  StartBounds := BoundsRect;\r
  fDragStartPos.x := StartBounds.Left;\r
  fDragStartPos.y := StartBounds.Top;\r
  SetCapture( GetWindowHandle );\r
  fDragging := TRUE;\r
  AttachProc( WndProcDragWindow );\r
end;\r
\r
//[procedure TControl.DragStopEx]\r
procedure TControl.DragStopEx;\r
begin\r
  if FDragging then\r
  begin\r
    ReleaseCapture;\r
    FDragging := FALSE;\r
  end;\r
end;\r
\r
//[function CallDragCallBack]\r
function CallDragCallBack( Sender: PControl; var Stop: Boolean ): Boolean;\r
var P: TPoint;\r
    Shape, ShapeWas: Integer;\r
begin\r
  GetCursorPos( P );\r
  Shape := LoadCursor( 0, IDC_HAND );\r
  ShapeWas := Shape;\r
  Result := Sender.fDragCallback( Sender, P.x, P.y, Shape, Stop );\r
  if not Stop then\r
  begin\r
    if not Result then\r
      if Shape = ShapeWas then\r
        Shape := LoadCursor( 0, IDC_NO );\r
    ScreenCursor := Shape;\r
  end\r
    else\r
  begin\r
    ScreenCursor := 0;\r
    Shape := Sender.fCursor;\r
  end;\r
  Windows.SetCursor( Shape );\r
end;\r
\r
//[function WndProcDrag]\r
function WndProcDrag( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
var Stop: Boolean;\r
begin\r
  if Sender.fDragging then\r
  begin\r
    Stop := FALSE;\r
    case Msg.message of\r
    WM_MOUSEMOVE:\r
      CallDragCallBack( Sender, Stop );\r
    WM_LBUTTONUP, WM_RBUTTONUP:\r
      begin\r
        Stop := TRUE;\r
        CallDragCallBack( Sender, Stop );\r
      end;\r
    else\r
      begin\r
        Result := FALSE;\r
        Exit;\r
      end;\r
    end;\r
    if Stop then\r
    begin\r
      ReleaseCapture;\r
      Sender.fDragging := FALSE;\r
    end\r
      else\r
    begin\r
      Result := TRUE;\r
      exit;\r
    end;\r
  end;\r
  Result := FALSE;\r
end;\r
\r
//[procedure TControl.DragItem]\r
procedure TControl.DragItem(OnDrag: TOnDrag);\r
begin\r
  fDragCallback := OnDrag;\r
  fDragging := TRUE;\r
  SetCapture( GetWindowHandle );\r
  AttachProc( WndProcDrag );\r
end;\r
\r
{-}\r
{$IFDEF USE_CONSTRUCTORS} //****************************************************//\r
                                                                                //\r
//[constructor TControl.CreateWindowed]\r
constructor TControl.CreateWindowed(AParent: PControl; AClassName: PChar;       //\r
  ACtl3D: Boolean);                                                             //\r
begin                                                                           //\r
  CreateParented( AParent );                                                    //\r
  fOnDynHandlers := WndProcDummy;                                               //\r
  fWndProcKeybd := WndProcDummy;                                                //\r
  fWndProcResizeFlicks := WndProcDummy;                                         //\r
  fCommandActions.aClear := ClearText;                                          //\r
  fWindowed := True;                                                            //\r
  fControlClassName := AClassName;                                              //\r
                                                                                //\r
  fControlClick := DummyObjProc;                                                //\r
                                                                                //\r
  fColor := clBtnFace;                                                          //\r
  fTextColor := clWindowText;                                                   //\r
  fMargin := 2;                                                                 //\r
  fCtl3D := True;                                                               //\r
  fCtl3Dchild := True;                                                          //\r
  if AParent <> nil then                                                        //\r
  begin                                                                         //\r
     fWndProcResizeFlicks := AParent.fWndProcResizeFlicks;                      //\r
     fGotoControl := AParent.fGotoControl;                                      //\r
     fDoubleBuffered := AParent.fDoubleBuffered;                                //\r
     fTransparent := AParent.fTransparent;                                      //\r
     fCtl3Dchild := AParent.fCtl3Dchild;                                        //\r
     if AParent.fCtl3Dchild then                                                //\r
       fCtl3D := ACtl3D                                                         //\r
     else                                                                       //\r
       fCtl3D := False;                                                         //\r
     fMargin := AParent.fMargin;                                                //\r
     with fBoundsRect do                                                        //\r
     begin                                                                      //\r
       Left := AParent.fMargin + AParent.fClientLeft;                           //\r
       Top  := AParent.fMargin + AParent.fClientTop;                            //\r
       Right := Left + 64;                                                      //\r
       Bottom := Top + 64;                                                      //\r
     end;                                                                       //\r
     fTextColor := AParent.fTextColor;                                          //\r
     fFont := fFont.Assign( AParent.fFont );                                    //\r
     if fFont <> nil then                                                       //\r
     begin                                                                      //\r
       fFont.fOnChange := FontChanged;                                          //\r
       FontChanged( fFont );                                                    //\r
     end;                                                                       //\r
     fColor := AParent.fColor;                                                  //\r
     fBrush := fBrush.Assign( AParent.fBrush );                                 //\r
     if fBrush <> nil then                                                      //\r
     begin                                                                      //\r
       fBrush.fOnChange := BrushChanged;                                        //\r
       BrushChanged( fBrush );                                                  //\r
     end;                                                                       //\r
  end;                                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateApplet]\r
constructor TControl.CreateApplet(const ACaption: String);                      //\r
begin                                                                           //\r
  AppButtonUsed := True;                                                        //\r
  CreateWindowed( nil, 'App', TRUE );                                           //\r
  FIsApplet := TRUE;                                                            //\r
  fStyle := WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX              //\r
    or WS_CAPTION;                                                              //\r
  fExStyle := WS_EX_APPWINDOW;                                                  //\r
  FCreateWndExt := CreateAppButton;                                             //\r
  AttachProc( WndProcApp );                                                     //\r
  Caption := ACaption;                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateForm]\r
constructor TControl.CreateForm(AParent: PControl; const ACaption: String);     //\r
begin                                                                           //\r
  CreateWindowed( AParent, 'Form', TRUE );                                      //\r
  AttachProc( WndProcForm );                                                    //\r
  AttachProc( WndProcDoEraseBkgnd );                                            //\r
  Caption := ACaption;                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateControl]\r
constructor TControl.CreateControl(AParent: PControl; AClassName: PChar;        //\r
  AStyle: DWORD; ACtl3D: Boolean; Actions: PCommandActions);                    //\r
var Form: PControl;                                                             //\r
begin                                                                           //\r
  CreateWindowed( AParent, AClassName, ACtl3D );                                //\r
  if Actions <> nil then                                                        //\r
    fCommandActions := Actions^;                                                //\r
  fIsControl := True;                                                           //\r
  fStyle := AStyle or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;                       //\r
  fVisible := (Style and WS_VISIBLE) <> 0;                                      //\r
  fTabstop := (Style and WS_TABSTOP) <> 0;                                      //\r
  if (AParent <> nil) then                                                      //\r
  begin                                                                         //\r
    Inc( AParent.ParentForm.fTabOrder );                                        //\r
    fTabOrder := AParent.ParentForm.fTabOrder;                                  //\r
  end;                                                                          //\r
  fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];             //\r
  if fCtl3D then                                                                //\r
  begin                                                                         //\r
    fStyle := fStyle and not WS_BORDER;                                         //\r
    fExStyle := fExStyle or WS_EX_CLIENTEDGE;                                   //\r
  end;                                                                          //\r
  if (Style and WS_TABSTOP) <> 0 then                                           //\r
  begin                                                                         //\r
    Form := ParentForm;                                                         //\r
    if Form <> nil then                                                         //\r
    if Form.FCurrentControl = nil then                                          //\r
       Form.FCurrentControl := @Self;                                           //\r
  end;                                                                          //\r
  //fCreateParamsExt := CreateParams2;                                          //\r
  fMenu := CtlIdCount;                                                          //\r
  Inc( CtlIdCount );                                                            //\r
  AttachProc( WndProcCtrl );                                                    //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateButton]\r
constructor TControl.CreateButton(AParent: PControl;                            //\r
  const ACaption: String);                                                      //\r
begin                                                                           //\r
  CreateControl( AParent, 'BUTTON',                                             //\r
            WS_VISIBLE or WS_CHILD or                                           //\r
            BS_PUSHLIKE or WS_TABSTOP, False, @ButtonActions );                 //\r
  with fBoundsRect do                                                           //\r
    Bottom := Top + 22;                                                         //\r
  fTextAlign := taCenter;                                                       //\r
  Caption := ACaption;                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateBitBtn]\r
constructor TControl.CreateBitBtn(AParent: PControl;                            //\r
  const ACaption: String; AOptions: TBitBtnOptions; ALayout: TGlyphLayout;      //\r
  AGlyphBitmap: HBitmap; AGlyphCount: Integer);                                 //\r
var                                                                             //\r
    B: TBitmapInfo;                                                             //\r
    W, H: Integer;                                                              //\r
begin                                                                           //\r
  CreateControl( AParent, 'BUTTON', WS_VISIBLE or WS_CHILD or                   //\r
            WS_TABSTOP or BS_OWNERDRAW, False, @ButtonActions );                //\r
  fBitBtnOptions := AOptions;                                                   //\r
  fGlyphLayout := ALayout;                                                      //\r
  fGlyphBitmap := AGlyphBitmap;                                                 //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Bottom := Top + 22;                                                         //\r
    W := 0; H := 0;                                                             //\r
    if AGlyphBitmap <> 0 then                                                   //\r
    begin                                                                       //\r
      if bboImageList in AOptions then                                          //\r
        ImageList_GetIconSize( AGlyphBitmap, W, H )                             //\r
      else                                                                      //\r
        begin                                                                   //\r
          if GetObject( AGlyphBitmap, Sizeof(B), @B ) > 0 then                  //\r
          begin                                                                 //\r
            W := B.bmiHeader.biWidth;                                           //\r
            H := B.bmiHeader.biHeight;                                          //\r
            if AGlyphCount = 0 then                                             //\r
              AGlyphCount := W div H;                                           //\r
            if AGlyphCount > 1 then                                             //\r
              W := W div AGlyphCount;                                           //\r
          end;                                                                  //\r
        end;                                                                    //\r
      if W > 0 then                                                             //\r
        if ACaption = '' then                                                   //\r
          Right := Left + W                                                     //\r
        else                                                                    //\r
          Right := Right + W;                                                   //\r
      if H > 0 then                                                             //\r
        Bottom := Top + H;                                                      //\r
      if not ( bboNoBorder in AOptions ) then                                   //\r
      begin                                                                     //\r
        if W > 0 then                                                           //\r
          Inc( Right, 2 );                                                      //\r
        if H > 0 then                                                           //\r
          Inc( Bottom, 2 );                                                     //\r
      end;                                                                      //\r
    end;                                                                        //\r
    fGlyphWidth := W;                                                           //\r
    fGlyphHeight := H;                                                          //\r
  end;                                                                          //\r
  fGlyphCount := AGlyphCount;                                                   //\r
  if AParent <> nil then                                                        //\r
    AParent.AttachProc( WndProc_DrawItem );                                     //\r
  AttachProc( WndProcBitBtn );                                                  //\r
  fTextAlign := taCenter;                                                       //\r
  Caption := ACaption;                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateLabel]\r
constructor TControl.CreateLabel(AParent: PControl;                             //\r
  const ACaption: String);                                                      //\r
begin                                                                           //\r
  CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or                   //\r
                         SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,         //\r
                         False, @LabelActions );                                //\r
  fIsStaticControl := True;                                                     //\r
  fSizeRedraw := True;                                                          //\r
  fBoundsRect.Bottom := fBoundsRect.Top + 22;                                   //\r
  Caption := ACaption;                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateWordWrapLabel]\r
constructor TControl.CreateWordWrapLabel(AParent: PControl;                     //\r
  const ACaption: String);                                                      //\r
begin                                                                           //\r
  CreateLabel( AParent, ACaption );                                             //\r
  fBoundsRect.Bottom := fBoundsRect.Top + 44;                                   //\r
  fStyle := fStyle and not SS_LEFTNOWORDWRAP;                                   //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateLabelEffect]\r
constructor TControl.CreateLabelEffect(AParent: PControl; ACaption: String;     //\r
  AShadowDeep: Integer);                                                        //\r
begin                                                                           //\r
  CreateLabel( AParent, ACaption );                                             //\r
  fIsStaticControl := False;                                                    //\r
  AttachProc( WndProcLabelEffect );                                             //\r
  fTextAlign := taCenter;                                                       //\r
  fTextColor := clBtnShadow;                                                    //\r
  fShadowDeep := AShadowDeep;                                                   //\r
  fIgnoreWndCaption := True;                                                    //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Bottom := Top + 40;                                                         //\r
  end;                                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreatePaintBox]\r
constructor TControl.CreatePaintBox(AParent: PControl);                         //\r
begin                                                                           //\r
  CreateLabel( AParent, '' );                                                   //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 40;                                                         //\r
    Bottom := Top + 40;                                                         //\r
  end;                                                                          //\r
end;                                                                            //\r
                                                                                //\r
{$IFDEF ASM_VERSION}                                                            //\r
//[constructor TControl.CreateGradientPanel]\r
constructor TControl.CreateGradientPanel(AParent: PControl; AColor1,            //\r
  AColor2: TColor);                                                             //\r
asm     //cmd    //opd                                                          //\r
        XOR      EDX, EDX                                                       //\r
        PUSH     EDX                                                            //\r
        CALL     CreateLabel                                                    //\r
        MOV      ECX, AColor1                                                   //\r
        MOV      [EAX].fColor1, ECX                                             //\r
        MOV      ECX, AColor2                                                   //\r
        MOV      [EAX].fColor2, ECX                                             //\r
        MOV      EDX, [EAX].fBoundsRect.Left                                    //\r
        ADD      EDX, 40                                                        //\r
        MOV      [EAX].fBoundsRect.Right, EDX                                   //\r
        MOV      EDX, [EAX].fBoundsRect.Top                                     //\r
        ADD      EDX, 40                                                        //\r
        MOV      [EAX].fBoundsRect.Bottom, EDX                                  //\r
        PUSH     EAX                                                            //\r
        MOV      EDX, offset[ WndProcGradient ]                                 //\r
        CALL     AttachProc                                                     //\r
        POP      EAX                                                            //\r
end;                                                                            //\r
{$ELSE ASM_VERSION} //Pascal                                                                //\r
constructor TControl.CreateGradientPanel(AParent: PControl; AColor1,            //\r
  AColor2: TColor);                                                             //\r
begin                                                                           //\r
  CreateLabel( AParent, '' );                                                   //\r
  AttachProc( WndProcGradient );                                                //\r
  fColor2 := AColor2;                                                           //\r
  fColor1 := AColor1;                                                           //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 40;                                                         //\r
    Bottom := Top + 40;                                                         //\r
  end;                                                                          //\r
end;                                                                            //\r
{$ENDIF ASM_VERSION}                                                                        //\r
                                                                                //\r
//[constructor TControl.CreateGradientPanelEx]\r
constructor TControl.CreateGradientPanelEx(AParent: PControl; AColor1,          //\r
  AColor2: TColor; AStyle: TGradientStyle; ALayout: TGradientLayout);           //\r
begin                                                                           //\r
  CreateLabel( AParent, '' );                                                   //\r
  AttachProc( WndProcGradientEx );                                              //\r
  fColor2 := AColor2;                                                           //\r
  fColor1 := AColor1;                                                           //\r
  fGradientStyle := AStyle;                                                     //\r
  fGradientLayout := ALayout;                                                   //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 40;                                                         //\r
    Bottom := Top + 40;                                                         //\r
  end;                                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateGroupbox]\r
constructor TControl.CreateGroupbox(AParent: PControl;                          //\r
  const ACaption: String);                                                      //\r
begin                                                                           //\r
  CreateButton( AParent, ACaption );                                            //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 100;                                                        //\r
    Bottom := Top + 100;                                                        //\r
  end;                                                                          //\r
  fStyle := WS_VISIBLE or WS_CHILD or BS_GROUPBOX or WS_TABSTOP;                //\r
  fClientTop := 22;                                                             //\r
  fClientLeft := 2;                                                             //\r
  fClientBottom := 2;                                                           //\r
  fClientRight := 2;                                                            //\r
  fTabstop := False;                                                            //\r
  //AttachProc( WndProcGroupBox );                                                //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateCheckbox]\r
constructor TControl.CreateCheckbox(AParent: PControl;                          //\r
  const ACaption: String);                                                      //\r
begin                                                                           //\r
  CreateButton( AParent, ACaption );                                            //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 72;                                                         //\r
  end;                                                                          //\r
  fStyle := WS_VISIBLE or WS_CHILD or                                           //\r
            BS_AUTOCHECKBOX or WS_TABSTOP;                                      //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateRadiobox]\r
constructor TControl.CreateRadiobox(AParent: PControl;                          //\r
  const ACaption: String);                                                      //\r
begin                                                                           //\r
  CreateCheckbox( AParent, ACaption );                                          //\r
  fStyle := WS_VISIBLE or WS_CHILD or                                           //\r
            BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP;                           //\r
  fControlClick := ClickRadio;                                                  //\r
  if AParent <> nil then                                                        //\r
  begin                                                                         //\r
    AParent.fRadioLast := fMenu;                                                //\r
    if AParent.fRadio1st = 0 then                                               //\r
    begin                                                                       //\r
       AParent.fRadio1st := fMenu;                                              //\r
       SetRadioChecked;                                                         //\r
    end;                                                                        //\r
  end;                                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateEditbox]\r
constructor TControl.CreateEditbox(AParent: PControl;                           //\r
  AOptions: TEditOptions);                                                      //\r
var Flags: Integer;                                                             //\r
begin                                                                           //\r
  Flags := MakeFlags( @AOptions, EditFlags );                                   //\r
  if not(eoMultiline in AOptions) then                                          //\r
     Flags := Flags and not(WS_HSCROLL or WS_VSCROLL);                          //\r
  CreateControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP          //\r
                         or WS_BORDER or Flags, True, @EditActions );           //\r
//YS  fCursor := LoadCursor( 0, IDC_IBEAM );                                      // //YS\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 100;                                                        //\r
    Bottom := Top + 22;                                                         //\r
    if eoMultiline in AOptions then                                             //\r
    begin                                                                       //\r
       Right := Right + 100;                                                    //\r
       Bottom := Top + 200;                                                     //\r
    end;                                                                        //\r
  end;                                                                          //\r
  fColor := clWindow;                                                           //\r
  fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ];                          //\r
  if eoMultiline in AOptions then                                               //\r
     fLookTabKeys := [ tkTab ];                                                 //\r
  if eoWantTab in AOptions then                                                 //\r
     fLookTabKeys := fLookTabKeys - [ tkTab ];                                  //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreatePanel]\r
constructor TControl.CreatePanel(AParent: PControl; AStyle: TEdgeStyle);        //\r
const Edgestyles: array[ TEdgeStyle ] of DWORD = ( WS_DLGFRAME, SS_SUNKEN, 0 ); //\r
begin                                                                           //\r
  CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or                   //\r
                         SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, False,  //\r
                         @LabelActions );                                       //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 100;                                                        //\r
    Bottom := Top + 100;                                                        //\r
  end;                                                                          //\r
  Style := Style or Edgestyles[ AStyle ];                                       //\r
  ExStyle := ExStyle or WS_EX_CONTROLPARENT;                                    //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateSplitter]\r
constructor TControl.CreateSplitter(AParent: PControl; AMinSizePrev,            //\r
  AMinSizeNext: Integer; EdgeStyle: TEdgeStyle);                                //\r
var PrevCtrl: PControl;                                                         //\r
    Sz0: Integer;                                                               //\r
begin                                                                           //\r
  CreatePanel( AParent, EdgeStyle );                                            //\r
  fSplitMinSize1 := AMinSizePrev;                                               //\r
  fSplitMinSize2 := AMinSizeNext;                                               //\r
  Sz0 := 4;                                                                     //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + Sz0;                                                        //\r
    Bottom := Top + Sz0;                                                        //\r
  end;                                                                          //\r
  if AParent <> nil then                                                        //\r
  begin                                                                         //\r
    if AParent.fChildren.fCount > 1 then                                        //\r
    begin                                                                       //\r
      PrevCtrl := AParent.fChildren.fItems[ AParent.fChildren.fCount - 2 ];     //\r
      case PrevCtrl.FAlign of                                                   //\r
      caLeft, caRight:                                                          //\r
        begin                                                                   //\r
          fCursor := LoadCursor( 0, IDC_SIZEWE );                               //\r
        end;                                                                    //\r
      caTop, caBottom:                                                          //\r
        begin                                                                   //\r
          fCursor := LoadCursor( 0, IDC_SIZENS );                               //\r
        end;                                                                    //\r
      end;                                                                      //\r
      Align := PrevCtrl.FAlign;                                                 //\r
    end;                                                                        //\r
  end;                                                                          //\r
  AttachProc( WndProcSplitter );                                                //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateListbox]\r
constructor TControl.CreateListbox(AParent: PControl;                           //\r
  AOptions: TListOptions);                                                      //\r
var Flags: Integer;                                                             //\r
begin                                                                           //\r
  Flags := MakeFlags( @AOptions, ListFlags );                                   //\r
  CreateControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP       //\r
                 or WS_BORDER or WS_VSCROLL                                     //\r
                 or LBS_NOTIFY or Flags, True, @ListActions );                  //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Right + 100;                                                       //\r
    Bottom := Top + 200;                                                        //\r
  end;                                                                          //\r
  fColor := clWindow;                                                           //\r
  fLookTabKeys := [ tkTab, tkLeftRight ];                                       //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateCombobox]\r
constructor TControl.CreateCombobox(AParent: PControl;                          //\r
  AOptions: TComboOptions);                                                     //\r
var Flags: Integer;                                                             //\r
begin                                                                           //\r
  Flags := MakeFlags( @AOptions, ComboFlags );                                  //\r
  CreateControl( AParent, 'COMBOBOX',                                           //\r
                 WS_VISIBLE or WS_CHILD or WS_VSCROLL or                        //\r
                 CBS_DROPDOWN or CBS_HASSTRINGS or WS_TABSTOP or Flags,         //\r
                 True, @ComboActions );                                         //\r
  fCreateWndExt := CreateComboboxWnd;                                           //\r
  fDropDownProc := ComboboxDropDown;                                            //\r
  fClsStyle := fClsStyle or CS_DBLCLKS;                                         //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 100;                                                        //\r
    Bottom := Top + 22;                                                         //\r
  end;                                                                          //\r
  fColor := clWindow;                                                           //\r
  fLookTabKeys := [ tkTab ];                                                    //\r
  if coReadOnly in AOptions then                                                //\r
    fLookTabKeys := [ tkTab, tkLeftRight ];                                     //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateCommonControl]\r
constructor TControl.CreateCommonControl(AParent: PControl;                     //\r
  AClassName: PChar; AStyle: DWORD; ACtl3D: Boolean;                            //\r
  Actions: PCommandActions);                                                    //\r
begin                                                                           //\r
  {*************} DoInitCommonControls( ICC_WIN95_CLASSES );                      //\r
  CreateControl( AParent, AClassName, AStyle, ACtl3D, Actions );                //\r
  fIsCommonControl := True;                                                     //\r
  if AParent <> nil then                                                        //\r
  begin                                                                         //\r
    AttachProc( WndProcParentResize );                                          //\r
    AParent.AttachProc( WndProcResize );                                        //\r
    AttachProc( WndProcCommonNotify );                                          //\r
    AParent.AttachProc( WndProcNotify );                                        //\r
  end;                                                                          //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateRichEdit1]\r
constructor TControl.CreateRichEdit1(AParent: PControl;                         //\r
  AOptions: TEditOptions);                                                      //\r
var Flags, I: Integer;                                                          //\r
begin                                                                           //\r
  if FRichEditModule = 0 then                                                   //\r
  begin                                                                         //\r
    for I := 0 to 2 do                                                          //\r
    begin                                                                       //\r
      FRichEditModule := LoadLibrary( RichEditLibnames[ I ] );                  //\r
      if FRichEditModule > HINSTANCE_ERROR then break;                          //\r
      RichEditClass := 'RichEdit';                                              //\r
    end;                                                                        //\r
    if FRichEditModule <= HINSTANCE_ERROR then                                  //\r
      FRichEditModule := 0;                                                     //\r
  end;                                                                          //\r
  Flags := MakeFlags( @AOptions, RichEditFlags );                               //\r
  CreateCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD           //\r
                       or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags,     //\r
                       True, @RichEditActions );                                //\r
                                                                                //\r
  AttachProc( WndProcRichEditNotify );                                          //\r
  fDoubleBuffered := False;                                                     //\r
  fCannotDoubleBuf := True;                                                     //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Right + 100;                                                       //\r
    Bottom := Top + 200;                                                        //\r
  end;                                                                          //\r
  fColor := clWindow;                                                           //\r
  fLookTabKeys := [ tkTab ];                                                    //\r
  if eoWantTab in AOptions then                                                 //\r
     fLookTabKeys := [ ];                                                       //\r
  Perform( EM_SETEVENTMASK, 0,                                                  //\r
    ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or                         //\r
    ENM_PROTECTED or $04000000 {ENM_LINK} );                                    //\r
  Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(fColor));                             //\r
end;                                                                            //\r
                                                                                //\r
                                                                                //\r
//[constructor TControl.CreateRichEdit]\r
constructor TControl.CreateRichEdit(AParent: PControl;                          //\r
  AOptions: TEditOptions);                                                      //\r
var OldRichEditClass, OldRichEditLib: PChar;                                    //\r
begin                                                                           //\r
  if OleInit then                                                               //\r
  begin                                                                         //\r
    OldRichEditClass := RichEditClass;                                          //\r
    RichEditClass := 'RichEdit20A';                                             //\r
    OldRichEditLib := RichEditLib;                                              //\r
    RichEditLib := 'RICHED20.DLL';                                              //\r
    CreateRichEdit1( AParent, AOptions );                                       //\r
    fCharFmtDeltaSz := 24;                                                      //\r
    // sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat );                 //\r
    fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat ); //\r
    RichEditClass := OldRichEditClass;                                          //\r
    RichEditLib := OldRichEditLib;                                              //\r
  end                                                                           //\r
     else                                                                       //\r
    CreateRichEdit1( AParent, AOptions );                                       //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateProgressbar]\r
constructor TControl.CreateProgressbar(AParent: PControl);                      //\r
const ProgressBarFlags: array[ TProgressbarOption ] of Integer =                //\r
      (PBS_VERTICAL, PBS_SMOOTH );                                              //\r
begin                                                                           //\r
  CreateCommonControl( AParent, PROGRESS_CLASS,                                 //\r
            WS_CHILD or WS_VISIBLE, True, nil );                                //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 300;                                                        //\r
    Bottom := Top + 20;                                                         //\r
  end;                                                                          //\r
  fMenu := 0;                                                                   //\r
  fTextColor := clHighlight;                                                    //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateProgressbarEx]\r
constructor TControl.CreateProgressbarEx(AParent: PControl;                     //\r
  AOptions: TProgressbarOptions);                                               //\r
const ProgressBarFlags: array[ TProgressbarOption ] of Integer =                //\r
      (PBS_VERTICAL, PBS_SMOOTH );                                              //\r
begin                                                                           //\r
  CreateProgressbar( AParent );                                                 //\r
  fStyle := fStyle or DWORD( MakeFlags( @AOptions, ProgressBarFlags ) );        //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateListView]\r
constructor TControl.CreateListView(AParent: PControl;                          //\r
  AStyle: TListViewStyle; AOptions: TListViewOptions; AImageListSmall,          //\r
  AImageListNormal, AImageListState: PImageList);                               //\r
begin                                                                           //\r
  CreateCommonControl( AParent, WC_LISTVIEW, ListViewStyles[ AStyle ] or        //\r
                 LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP,   //\r
                 True, @ListViewActions );                                      //\r
  fLVOptions := AOptions;                                                       //\r
  fLVStyle := AStyle;                                                           //\r
  fCreateWndExt := ApplyImageLists2ListView;                                    //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 200;                                                        //\r
    Bottom := Top + 150;                                                        //\r
  end;                                                                          //\r
  ImageListSmall := AImageListSmall;                                            //\r
  ImageListNormal := AImageListNormal;                                          //\r
  ImageListState := AImageListState;                                            //\r
  fLVTextBkColor := clWindow;                                                   //\r
  fLookTabKeys := [ tkTab ];                                                    //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateTreeView]\r
constructor TControl.CreateTreeView(AParent: PControl;                          //\r
  AOptions: TTreeViewOptions; AImgListNormal, AImgListState: PImageList);       //\r
var Flags: Integer;                                                             //\r
begin                                                                           //\r
  Flags := MakeFlags( @AOptions, TreeViewFlags );                               //\r
  CreateCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or             //\r
            WS_CHILD or WS_TABSTOP, True, @TreeViewActions );                   //\r
  fCreateWndExt := ApplyImageLists2Control;                                     //\r
  fColor := clWindow;                                                           //\r
  AttachProc( WndProcTreeView );                                                //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 150;                                                        //\r
    Bottom := Top + 200;                                                        //\r
  end;                                                                          //\r
  ImageListNormal := AImgListNormal;                                            //\r
  ImageListState := AImgListState;                                              //\r
  fLookTabKeys := [ tkTab ];                                                    //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateTabControl]\r
constructor TControl.CreateTabControl(AParent: PControl; ATabs: array of String;//\r
         AOptions: TTabControlOptions;                                          //\r
         AImgList: PImageList; AImgList1stIdx: Integer);                        //\r
var I, II : Integer;                                                            //\r
    Flags: Integer;                                                             //\r
begin                                                                           //\r
  Flags := MakeFlags( @AOptions, TabControlFlags );                             //\r
  if tcoFocusTabs in AOptions then                                              //\r
    Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN);                    //\r
  CreateCommonControl( AParent, WC_TABCONTROL,                                  //\r
            Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or         //\r
            WS_VISIBLE), True, @TabControlActions );                            //\r
  if not( tcoBorder in AOptions ) then                                           //\r
    fExStyle := fExStyle and not WS_EX_CLIENTEDGE;                              //\r
  AttachProc( WndProcTabControl );                                              //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    Right := Left + 100;                                                        //\r
    Bottom := Top + 100;                                                        //\r
  end;                                                                          //\r
  if AImgList <> nil then                                                       //\r
    Perform( TCM_SETIMAGELIST, 0, AImgList.Handle );                            //\r
  II := AImgList1stIdx;                                                         //\r
  for I := 0 to High( ATabs ) do                                                //\r
  begin                                                                         //\r
    TC_Insert( I, ATabs[ I ], II );                                             //\r
    Inc( II );                                                                  //\r
  end;                                                                          //\r
  fLookTabKeys := [ tkTab ];                                                    //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TControl.CreateToolbar]\r
constructor TControl.CreateToolbar(AParent: PControl;                           //\r
  AAlign: TControlAlign; AOptions: TToolbarOptions; ABitmap: HBitmap;           //\r
  AButtons: array of PChar; ABtnImgIdxArray: array of Integer);                 //\r
var Flags: DWORD;                                                               //\r
begin                                                                           //\r
  if not( tboTextBottom in AOptions ) then                                      //\r
    AOptions := AOptions + [ tboTextRight ];                                    //\r
  if tboTextRight in AOptions then                                              //\r
    AOptions := AOptions - [ tboTextBottom ];                                   //\r
  Flags := MakeFlags( @AOptions, ToolbarOptions );                              //\r
  CreateCommonControl( AParent, TOOLBARCLASSNAME, ToolbarAligns[ Align ] or     //\r
                       WS_CHILD or WS_VISIBLE {or WS_TABSTOP}                   //\r
                       or TBSTYLE_TOOLTIPS or Flags,                            //\r
                       (not (Align in [caNone])) and                            //\r
                        not (tboNoDivider in AOptions),  nil );                 //\r
  fCommandActions.aClear := ClearToolbar;                                       //\r
  fCommandActions.aGetCount := TB_BUTTONCOUNT;                                  //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    if AAlign in [ caNone ] then                                                //\r
    begin                                                                       //\r
      Bottom := Top + 26;                                                       //\r
      Right := Left + 1000;                                                     //\r
    end                                                                         //\r
       else                                                                     //\r
    begin                                                                       //\r
      Left := 0; Right := 0;                                                    //\r
      Top := 0; Bottom := 0;                                                    //\r
    end;                                                                        //\r
  end;                                                                          //\r
  Perform(TB_SETEXTENDEDSTYLE, 0, Perform(TB_GETEXTENDEDSTYLE, 0, 0) or         //\r
      TBSTYLE_EX_DRAWDDARROWS);                                                 //\r
                                                                                //\r
  AttachProc( WndProcToolbarCtrl );                                             //\r
  Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 );                       //\r
  Perform( TB_SETINDENT, fMargin, 0 );                                          //\r
  with fBoundsRect do                                                           //\r
  begin                                                                         //\r
    if AAlign in [ caLeft, caRight ] then                                       //\r
      Right := Left + 24                                                        //\r
    else if not (AAlign in [caNone]) then                                       //\r
      Bottom := Top + 22;                                                       //\r
  end;                                                                          //\r
  if ABitmap <> 0 then                                                          //\r
    TBAddBitmap( ABitmap );                                                     //\r
  TBAddButtons( AButtons, ABtnImgIdxArray );                                    //\r
  Perform( WM_SIZE, 0, 0 );                                                     //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TImageList.CreateImageList]\r
constructor TImageList.CreateImageList(POwner: Pointer);                        //\r
var AOwner: PControl;                                                           //\r
begin                                                                           //\r
  {*************} DoInitCommonControls( ICC_WIN95_CLASSES );                    //\r
  Create;                                                                       //\r
  FAllocBy := 1;                                                                //\r
  FMasked := True;                                                              //\r
  if POwner = nil then exit;                                                    //\r
  FBkColor := TColor( CLR_NONE );\r
  //ImageList_SetBkColor( FHandle, CLR_NONE );\r
                                                                                //\r
  AOwner := POwner;                                                             //\r
  FControl := AOwner;                                                           //\r
  fNext := PImageList( AOwner.fImageList );                                     //\r
  if AOwner.fImageList <> nil then                                              //\r
     PImageList( AOwner.fImageList ).fPrev := @Self;                            //\r
  AOwner.fImageList := @Self;                                                   //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TThread.ThreadCreate]\r
constructor TThread.ThreadCreate;                                               //\r
begin                                                                           //\r
  IsMultiThread := True;                                                        //\r
  Create;                                                                       //\r
  FSuspended := True;                                                           //\r
  FHandle := CreateThread( nil, // no security                                  //\r
                          0,   // the same stack size                           //\r
                          @ThreadFunc, // thread entry point                    //\r
                          @Self,      // parameter to pass to ThreadFunc        //\r
                          CREATE_SUSPENDED,   // always SUSPENDED               //\r
                          FThreadID ); // receive thread ID                     //\r
end;                                                                            //\r
                                                                                //\r
//[constructor TThread.ThreadCreateEx]\r
constructor TThread.ThreadCreateEx( const Proc: TOnThreadExecute );             //\r
begin                                                                           //\r
  ThreadCreate;                                                                 //\r
  OnExecute := Proc;                                                            //\r
  Resume;                                                                       //\r
end;                                                                            //\r
                                                                                //\r
{$ENDIF USE_CONSTRUCTORS} //****************************************************//\r
{+}\r
\r
{ TCABFile }\r
\r
//[function OpenCABFile]\r
function OpenCABFile( const APaths: array of String ): PCABFile;\r
var I: Integer;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+}{++}(*Result := PCABFile.Create;*){--}\r
  Result.FSetupapi := LoadLibrary( 'setupapi.dll' );\r
  Result.FNames := NewStrList;\r
  Result.FPaths := NewStrList;\r
  for I := 0 to High( APaths ) do\r
    Result.FPaths.Add( APaths[ I ] );\r
end;\r
\r
//[destructor TCABFile.Destroy]\r
destructor TCABFile.Destroy;\r
begin\r
  FNames.Free;\r
  FPaths.Free;\r
  FTargetPath := '';\r
  if FSetupapi <> 0 then\r
    FreeLibrary( FSetupapi );\r
  inherited;\r
end;\r
\r
const\r
  SPFILENOTIFY_FILEINCABINET  = $11;\r
  SPFILENOTIFY_NEEDNEWCABINET = $12;\r
\r
type\r
  PSP_FILE_CALLBACK = function( Context: Pointer; Notification, Param1, Param2: DWORD ): DWORD;\r
  stdcall;\r
\r
  TSetupIterateCabinet = function ( CabinetFile: PChar; Reserved: DWORD;\r
         MsgHandler: PSP_FILE_CALLBACK; Context: Pointer ): Boolean; stdcall;\r
         //external 'setupapi.dll' name 'SetupIterateCabinetA';\r
\r
  TSetupPromptDisk = function (\r
    hwndParent: HWND;   // parent window of the dialog box\r
    DialogTitle: PChar; // optional, title of the dialog box\r
    DiskName: PChar;    // optional, name of disk to insert\r
    PathToSource: PChar;// optional, expected source path\r
    FileSought: PChar;  // name of file needed\r
    TagFile: PChar;     // optional, source media tag file\r
    DiskPromptStyle: DWORD;     // specifies dialog box behavior\r
    PathBuffer: PChar;  // receives the source location\r
    PathBufferSize: DWORD;      // size of the supplied buffer\r
    PathRequiredSize: PDWORD    // optional, buffer size needed\r
   ): DWORD; stdcall;\r
   //external 'setupapi.dll' name 'SetupPromptForDiskA';\r
\r
type\r
  TCabinetInfo = packed record\r
    CabinetPath: PChar;\r
    CabinetFile: PChar;\r
    DiskName: PChar;\r
    SetId: WORD;\r
    CabinetNumber: WORD;\r
  end;\r
  PCabinetInfo = ^TCabinetInfo;\r
\r
  TFileInCabinetInfo = packed record\r
    NameInCabinet: PChar;\r
    FileSize: DWORD;\r
    Win32Error: DWORD;\r
    DosDate: WORD;\r
    DosTime: WORD;\r
    DosAttribs: WORD;\r
    FullTargetName: array[0..MAX_PATH-1] of Char;\r
  end;\r
  PFileInCabinetInfo = ^TFileInCabinetInfo;\r
\r
//[function CABCallback]\r
function CABCallback( Context: Pointer; Notification, Param1, Param2: DWORD ): DWORD;\r
stdcall;\r
var CAB: PCABFile;\r
    CABPath, OldPath: String;\r
    CABInfo: PCabinetInfo;\r
    CABFileInfo: PFileInCabinetInfo;\r
    hr: Integer;\r
    SetupPromptProc: TSetupPromptDisk;\r
begin\r
  Result := 0;\r
  CAB := Context;\r
  case Notification of\r
  SPFILENOTIFY_NEEDNEWCABINET:\r
    begin\r
      OldPath := CAB.FPaths.Items[ CAB.FCurCAB ];\r
      Inc( CAB.FCurCAB );\r
      if CAB.FCurCAB = CAB.FPaths.Count then\r
        CAB.FPaths.Add( '?' );\r
      CABPath := CAB.FPaths.Items[ CAB.FCurCAB ];\r
      if CABPath = '?' then\r
      begin\r
        if Assigned( CAB.FOnNextCAB ) then\r
          CAB.FPaths.Items[CAB.FCurCAB ] := CAB.FOnNextCAB( CAB );\r
        CABPath := CAB.FPaths.Items[ CAB.FCurCAB ];\r
        if CABPath = '?' then\r
        begin\r
          SetLength( CABPath, MAX_PATH );\r
          CABInfo := Pointer( Param1 );\r
          if CAB.FSetupapi <> 0 then\r
            SetupPromptProc := GetProcAddress( CAB.FSetupapi, 'SetupPromptForDiskA' )\r
          else\r
            SetupPromptProc := nil;\r
          if Assigned( SetupPromptProc ) then\r
          begin\r
            hr := SetupPromptProc( 0, nil, nil, PChar( ExtractFilePath( OldPath ) ),\r
                 CABInfo.CabinetFile, nil, 2 {IDF_NOSKIP}, @CabPath[ 1 ], MAX_PATH, nil );\r
            case hr of\r
            0: // success\r
              begin\r
                StrCopy( PChar( Param2 ), PChar( CABPath ) );\r
                Result := 0;\r
              end;\r
            2: // skip file\r
              Result := 0;\r
            else // cancel\r
              Result := ERROR_FILE_NOT_FOUND;\r
            end;\r
          end;\r
        end\r
          else\r
        begin\r
          StrCopy( PChar( Param2 ), PChar( CABPath ) );\r
          Result := 0;\r
        end;\r
      end;\r
    end;\r
  SPFILENOTIFY_FILEINCABINET:\r
    begin\r
      CABFileInfo := Pointer( Param1 );\r
      if CAB.FGettingNames then\r
      begin\r
        CAB.FNames.Add( CABFileInfo.NameInCabinet );\r
        Result := 2; // FILEOP_SKIP\r
      end\r
        else\r
      begin\r
        CABPath := CABFileInfo.NameInCabinet;\r
        if Assigned( CAB.FOnFile ) then\r
        begin\r
          if CAB.FOnFile( CAB, CABPath ) then\r
          begin\r
            if ExtractFilePath( CABPath ) = '' then\r
            if CAB.FTargetPath <> '' then\r
              CABPath := CAB.TargetPath + CABPath;\r
            StrCopy( @CABFileInfo.FullTargetName[ 0 ], PChar( CABPath ) );\r
            Result := 1; // FILEOP_DOIT\r
          end\r
          else\r
            Result := 2\r
        end\r
        else\r
        begin\r
          if CAB.FTargetPath <> '' then\r
            StrCopy( @CABFileInfo.FullTargetName[ 0 ], PChar( CAB.TargetPath + CABPath ) );\r
          Result := 1;\r
        end;\r
      end;\r
    end;\r
  end;\r
end;\r
\r
//[function TCABFile.Execute]\r
function TCABFile.Execute: Boolean;\r
var SetupIterateProc: TSetupIterateCabinet;\r
begin\r
  FCurCAB := 0;\r
  Result := FALSE;\r
  if FSetupapi = 0 then Exit;\r
  SetupIterateProc := GetProcAddress( FSetupapi, 'SetupIterateCabinetA' );\r
  if not Assigned( SetupIterateProc ) then Exit;\r
  Result := SetupIterateProc( PChar( FPaths.Items[ 0 ] ), 0, CABCallback, @Self );\r
end;\r
\r
//[function TCABFile.GetCount]\r
function TCABFile.GetCount: Integer;\r
begin\r
  GetNames( 0 );\r
  Result := FNames.Count;\r
end;\r
\r
//[function TCABFile.GetNames]\r
function TCABFile.GetNames(Idx: Integer): String;\r
begin\r
  if FNames.Count = 0 then\r
  begin\r
    FGettingNames := TRUE;\r
    Execute;\r
    FGettingNames := FALSE;\r
  end;\r
  Result := '';\r
  if Idx < FNames.Count then\r
    Result := FNames.Items[ Idx ];\r
end;\r
\r
//[function TCABFile.GetPaths]\r
function TCABFile.GetPaths(Idx: Integer): String;\r
begin\r
  Result := FPaths.Items[ Idx ];\r
end;\r
\r
//[function TCABFile.GetTargetPath]\r
function TCABFile.GetTargetPath: String;\r
begin\r
  Result := FTargetPath;\r
  if Result <> '' then\r
  if Result[ Length( Result ) ] <> '\' then\r
    Result := Result + '\';\r
end;\r
\r
//[procedure InvalidateExW]\r
procedure InvalidateExW( Wnd: HWnd );\r
begin\r
  InvalidateRect( Wnd, nil, TRUE );\r
  Wnd := GetWindow( Wnd, GW_CHILD );\r
  while Wnd <> 0 do\r
  begin\r
    InvalidateExW( Wnd );\r
    Wnd := GetWindow( Wnd, GW_HWNDNEXT );\r
  end;\r
end;\r
\r
//[procedure TControl.InvalidateEx]\r
procedure TControl.InvalidateEx;\r
begin\r
  if fHandle = 0 then Exit;\r
  InvalidateExW( fHandle );\r
end;\r
\r
//[procedure InvalidateNCW]\r
procedure InvalidateNCW( Wnd: HWnd; Recursive: Boolean );\r
begin\r
  SendMessage( Wnd, WM_NCPAINT, 1, 0 );\r
  if not Recursive then Exit;\r
  Wnd := GetWindow( Wnd, GW_CHILD );\r
  while Wnd <> 0 do\r
  begin\r
    InvalidateNCW( Wnd, Recursive );\r
    Wnd := GetWindow( Wnd, GW_HWNDNEXT );\r
  end;\r
end;\r
\r
//[procedure TControl.InvalidateNC]\r
procedure TControl.InvalidateNC(Recursive: Boolean);\r
begin\r
  if fHandle = 0 then Exit;\r
  InvalidateNCW( fHandle, Recursive );\r
end;\r
\r
//[procedure TControl.SetClientMargin]\r
procedure TControl.SetClientMargin(const Index, Value: Integer);\r
begin\r
  case Index of\r
  1: fClientTop := Value;\r
  2: fClientBottom := Value;\r
  3: fClientLeft := Value;\r
  4: fClientRight := Value;\r
  end;\r
  Global_Align( @Self );\r
end;\r
\r
{$IFDEF F_P}\r
//[function TControl.GetClientMargin]\r
function TControl.GetClientMargin(const Index: Integer): Integer;\r
begin\r
  CASE Index OF\r
  1: Result := fClientTop;\r
  2: Result := fClientBottom;\r
  3: Result := fClientLeft;\r
  4: Result := fClientRight;\r
  END;\r
end;\r
{$ENDIF F_P}\r
\r
{ TBits }\r
\r
//[function NewBits]\r
function NewBits: PBits;\r
begin\r
  {-}\r
  new( Result, Create );\r
  {+}{++}(*Result := PBits.Create;*){--}\r
  Result.fList := NewList;\r
  //Result.fList.fAddBy := 1;\r
end;\r
\r
//[procedure TBits.AssignBits]\r
procedure TBits.AssignBits(ToIdx: Integer; FromBits: PBits; FromIdx,\r
  N: Integer);\r
var i: Integer;\r
    NewCount: Integer;\r
begin\r
  if FromIdx >= FromBits.Count then Exit;\r
  if FromIdx + N > FromBits.Count then\r
    N := FromBits.Count - FromIdx;\r
  Capacity := (ToIdx + N + 8) div 8;\r
  NewCount := Max( Count, ToIdx + N - 1 );\r
  fCount := Max( NewCount, fCount );\r
  fList.fCount := (Capacity + 3) div 4;\r
  while ToIdx and $1F <> 0 do\r
  begin\r
    Bits[ ToIdx ] := FromBits.Bits[ FromIdx ];\r
    Inc( ToIdx );\r
    Inc( FromIdx );\r
    Dec( N );\r
    if N = 0 then Exit;\r
  end;\r
  Move( PByte( Integer( FromBits.fList.fItems ) + (FromIdx + 31) div 32 )^,\r
        PByte( Integer( fList.fItems ) + ToIdx div 32 )^, (N + 31) div 32 );\r
  FromIdx := FromIdx and $1F;\r
  if FromIdx <> 0 then\r
  begin // shift data by (Idx and $1F) bits right\r
    for i := ToIdx div 32 to fList.Count-2 do\r
      fList.Items[ i ] := Pointer(\r
        (DWORD( fList.Items[ i ] ) shr FromIdx) or\r
        (DWORD( fList.Items[ i+1 ] ) shl (32 - FromIdx))\r
        );\r
    fList.Items[ fList.Count-1 ] := Pointer(\r
      DWORD( fList.Items[ fList.Count-1 ] ) shr FromIdx\r
      );\r
  end;\r
end;\r
\r
//[function TBits.Copy]\r
procedure TBits.Clear;\r
begin\r
  fList.Clear;\r
end;\r
\r
function TBits.Copy(From, BitsCount: Integer): PBits;\r
var Shift, N: Integer;\r
    FirstItemPtr: Pointer;\r
begin\r
  Result := NewBits;\r
  if BitsCount = 0 then Exit;\r
  Result.Capacity := BitsCount + 32;\r
  Result.fCount := BitsCount;\r
  Move( fList.fItems[ From shr 5 ], Result.fList.fItems[ 0 ], (Count + 31) div 32 );\r
  Shift := From and $1F;\r
  if Shift <> 1 then\r
  begin\r
    N := (BitsCount + 31) div 32;\r
    FirstItemPtr := @ Result.fList.fItems[ N - 1 ];\r
    asm\r
          PUSH  ESI\r
          PUSH  EDI\r
          MOV   ESI, FirstItemPtr\r
          MOV   EDI, ESI\r
          STD\r
          MOV   ECX, N\r
          XOR   EAX, EAX\r
          CDQ\r
    @@1:\r
          PUSH  ECX\r
          LODSD\r
          MOV   ECX, Shift\r
          SHRD  EAX, EDX, CL\r
          STOSD\r
          SUB   ECX, 32\r
          NEG   ECX\r
          SHR   EDX, CL\r
          POP   ECX\r
\r
          LOOP  @@1\r
\r
          CLD\r
          POP   EDI\r
          POP   ESI\r
    end {$IFDEF F_P} ['EAX','EDX','ECX'] {$ENDIF};\r
  end;\r
end;\r
\r
//[destructor TBits.Destroy]\r
destructor TBits.Destroy;\r
begin\r
  fList.Free;\r
  inherited;\r
end;\r
\r
//[function TBits.GetBit]\r
function TBits.GetBit(Idx: Integer): Boolean;\r
begin\r
  if Idx >= Count then Result := FALSE else\r
  Result := ( ( DWORD( fList.fItems[ Idx shr 5 ] ) shr (Idx and $1F)) and 1 ) <> 0;\r
end;\r
\r
//[function TBits.GetCapacity]\r
function TBits.GetCapacity: Integer;\r
begin\r
  Result := fList.Capacity * 32;\r
end;\r
\r
//[function TBits.GetSize]\r
function TBits.GetSize: Integer;\r
begin\r
  Result := (fList.fCount + 3) div 4;\r
end;\r
\r
{$IFDEF ASM_noVERSION}\r
//[function TBits.IndexOf]\r
function TBits.IndexOf(Value: Boolean): Integer;\r
asm     //cmd    //opd\r
        PUSH     EDI\r
        MOV      EDI, [EAX].fList\r
        MOV      ECX, [EDI].TList.fCount\r
@@ret_1:\r
        OR       EAX, -1\r
        JECXZ    @@ret_EAX\r
        MOV      EDI, [EDI].TList.fItems\r
        TEST     DL, DL\r
        MOV      EDX, EDI\r
        JE       @@of_false\r
        INC      EAX\r
        REPZ     SCASD\r
        JE       @@ret_1\r
        MOV      EAX, [EDI-4]\r
        NOT      EAX\r
        JMP      @@calc_offset\r
        BSF      EAX, EAX\r
        SUB      EDI, EDX\r
        SHR      EDI, 2\r
        ADD      EAX, EDI\r
        JMP      @@ret_EAX\r
@@of_false:\r
        REPE     SCASD\r
        JE       @@ret_1\r
        MOV      EAX, [EDI-4]\r
@@calc_offset:\r
        BSF      EAX, EAX\r
        DEC      EAX\r
        SUB      EDI, 4\r
        SUB      EDI, EDX\r
        SHL      EDI, 3\r
        ADD      EAX, EDI\r
@@ret_EAX:\r
        POP      EDI\r
end;\r
{$ELSE ASM_VERSION} //Pascal\r
function TBits.IndexOf(Value: Boolean): Integer;\r
var I: Integer;\r
    D: DWORD;\r
begin\r
  Result := -1;\r
  if Value then\r
  begin\r
    for I := 0 to fList.Count-1 do\r
    begin\r
      D := DWORD( fList.fItems[ I ] );\r
      if D <> 0 then\r
      begin\r
        asm\r
          MOV  EAX, D\r
          BSF  EAX, EAX\r
          MOV  D, EAX\r
        end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};\r
        Result := I * 32 + Integer( D );\r
        break;\r
      end;\r
    end;\r
  end\r
    else\r
  begin\r
    for I := 0 to fList.fCount-1 do\r
    begin\r
      D := DWORD( fList.fItems[ I ] );\r
      if D <> $FFFFFFFF then\r
      begin\r
        asm\r
          MOV  EAX, D\r
          NOT  EAX\r
          BSF  EAX, EAX\r
          MOV  D, EAX\r
        end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};\r
        Result := I * 32 + Integer( D );\r
        break;\r
      end;\r
    end;\r
  end;\r
end;\r
{$ENDIF ASM_VERSION}\r
\r
//[function TBits.LoadFromStream]\r
function TBits.LoadFromStream(strm: PStream): Integer;\r
var\r
 i: Integer;\r
begin\r
 Result := strm.Read( i, 4 );\r
 if Result < 4 then Exit;\r
 \r
 bits[ i]:= false; //by miek\r
 fcount:= i;\r
\r
 i := (i + 7) div 8;\r
 Inc( Result, strm.Read( fList.fItems^, i ) );\r
end;\r
\r
//[function TBits.OpenBit]\r
function TBits.OpenBit: Integer;\r
begin\r
  Result := IndexOf( FALSE );\r
  if Result < 0 then Result := Count;\r
end;\r
\r
//[function TBits.Range]\r
function TBits.Range(Idx, N: Integer): PBits;\r
begin\r
  Result := NewBits;\r
  Result.AssignBits( 0, @ Self, Idx, N );\r
end;\r
\r
//[function TBits.SaveToStream]\r
function TBits.SaveToStream(strm: PStream): Integer;\r
begin\r
  Result := strm.Write( fCount, 4 );\r
  if fCount = 0 then Exit;\r
  Inc( Result, strm.Write( fList.fItems^, (fCount + 7) div 8 ) );\r
end;\r
\r
//[procedure TBits.SetBit]\r
procedure TBits.SetBit(Idx: Integer; const Value: Boolean);\r
var Msk: DWORD;\r
begin\r
  if Idx >= Capacity then\r
    Capacity := Idx + 1;\r
  Msk := 1 shl (Idx and $1F);\r
  if Value then\r
    fList.fItems[ Idx shr 5 ] := Pointer(\r
                  DWORD(fList.fItems[ Idx shr 5 ]) or Msk)\r
  else\r
    fList.fItems[ Idx shr 5 ] := Pointer(\r
                  DWORD(fList.fItems[ Idx shr 5 ]) and not Msk);\r
  if Idx >= fCount then\r
    fCount := Idx + 1;\r
end;\r
\r
//[procedure TBits.SetCapacity]\r
procedure TBits.SetCapacity(const Value: Integer);\r
var OldCap: Integer;\r
begin\r
  OldCap := fList.Capacity;\r
  fList.Capacity := (Value + 31) div 32;\r
  if OldCap < fList.Capacity then\r
    FillChar( PChar( Integer( fList.fItems ) + OldCap * Sizeof( Pointer ) )^,\r
              (fList.Capacity - OldCap) * sizeof( Pointer ), 0 );\r
end;\r
\r
{ ----------------------------------------------------------------------\r
\r
                TAction and TActionList\r
\r
----------------------------------------------------------------------- }\r
//[function NewActionList]\r
function NewActionList(AOwner: PControl): PActionList;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+} {++}(* Result := PActionList.Create; *){--}\r
  with Result{-}^{+} do begin\r
    FActions:=NewList;\r
    FOwner:=AOwner;\r
    RegisterIdleHandler(DoUpdateActions);\r
  end;\r
end;\r
//[END NewActionList]\r
\r
//[function NewAction]\r
function NewAction(const ACaption, AHint: string; AOnExecute: TOnEvent): PAction;\r
begin\r
  {-}\r
  New( Result, Create );\r
  {+} {++}(* Result := PAction.Create; *){--}\r
  with Result{-}^{+} do begin\r
    FControls:=NewList;\r
    Enabled:=True;\r
    Visible:=True;\r
    Caption:=ACaption;\r
    Hint:=AHint;\r
    OnExecute:=AOnExecute;\r
  end;\r
end;\r
//[END NewAction]\r
\r
{ TAction }\r
\r
//[procedure TAction.LinkCtrl]\r
procedure TAction.LinkCtrl(ACtrl: PObj; ACtrlKind: TCtrlKind; AItemID: integer; AUpdateProc: TOnUpdateCtrlEvent);\r
var\r
  cr: PControlRec;\r
begin\r
  New(cr);\r
  with cr^ do begin\r
    Ctrl:=ACtrl;\r
    CtrlKind:=ACtrlKind;\r
    ItemID:=AItemID;\r
    UpdateProc:=AUpdateProc;\r
  end;\r
  FControls.Add(cr);\r
  AUpdateProc(cr);\r
end;\r
\r
//[procedure TAction.LinkControl]\r
procedure TAction.LinkControl(Ctrl: PControl);\r
begin\r
  LinkCtrl(Ctrl, ckControl, 0, UpdateCtrl);\r
  Ctrl.OnClick:=DoOnControlClick;\r
end;\r
\r
//[procedure TAction.LinkMenuItem]\r
procedure TAction.LinkMenuItem(Menu: PMenu; MenuItemIdx: integer);\r
{$IFDEF _FPC}\r
var\r
  arr1_DoOnMenuItem: array[ 0..0 ] of TOnMenuItem;\r
{$ENDIF _FPC}\r
begin\r
  LinkCtrl(Menu, ckMenu, MenuItemIdx, UpdateMenu);\r
  {$IFDEF _FPC}\r
  arr1_DoOnMenuItem[ 0 ] := DoOnMenuItem;\r
  Menu.AssignEvents(MenuItemIdx, arr1_DoOnMenuItem);\r
  {$ELSE}\r
  Menu.AssignEvents(MenuItemIdx, [ DoOnMenuItem ]);\r
  {$ENDIF}\r
end;\r
\r
//[procedure TAction.LinkToolbarButton]\r
procedure TAction.LinkToolbarButton(Toolbar: PControl; ButtonIdx: integer);\r
{$IFDEF _FPC}\r
var\r
  arr1_DoOnToolbarButtonClick: array[ 0..0 ] of TOnToolbarButtonClick;\r
{$ENDIF _FPC}\r
begin\r
  LinkCtrl(Toolbar, ckToolbar, ButtonIdx, UpdateToolbar);\r
  {$IFDEF _FPC}\r
  arr1_DoOnToolbarButtonClick[ 0 ] := DoOnToolbarButtonClick;\r
  Toolbar.TBAssignEvents(ButtonIdx, arr1_DoOnToolbarButtonClick);\r
  {$ELSE}\r
  Toolbar.TBAssignEvents(ButtonIdx, [DoOnToolbarButtonClick]);\r
  {$ENDIF}\r
end;\r
\r
//[destructor TAction.Destroy]\r
destructor TAction.Destroy;\r
begin\r
  FControls.Release;\r
  FCaption:='';\r
  FShortCut:='';\r
  FHint:='';\r
  inherited;\r
end;\r
\r
//[procedure TAction.DoOnControlClick]\r
procedure TAction.DoOnControlClick(Sender: PObj);\r
begin\r
  Execute;\r
end;\r
\r
//[procedure TAction.DoOnMenuItem]\r
procedure TAction.DoOnMenuItem(Sender: PMenu; Item: Integer);\r
begin\r
  Execute;\r
end;\r
\r
//[procedure TAction.DoOnToolbarButtonClick]\r
procedure TAction.DoOnToolbarButtonClick(Sender: PControl; BtnID: Integer);\r
begin\r
  Execute;\r
end;\r
\r
//[procedure TAction.Execute]\r
procedure TAction.Execute;\r
begin\r
  if Assigned(FOnExecute) and FEnabled then\r
    FOnExecute(PObj( @Self ));\r
end;\r
\r
//[procedure TAction.SetCaption]\r
procedure TAction.SetCaption(const Value: string);\r
var\r
  i: integer;\r
  c, ss: string;\r
\r
begin\r
  i:=Pos(#9, Value);\r
  if i <> 0 then begin\r
    c:=Copy(Value, 1, i - 1);\r
    ss:=Copy(Value, i + 1, MaxInt);\r
  end\r
  else begin\r
    c:=Value;\r
    ss:='';\r
  end;\r
  if (FCaption = c) and (FShortCut = ss) then exit;\r
  FCaption:=c;\r
  FShortCut:=ss;\r
  UpdateControls;\r
end;\r
\r
//[procedure TAction.SetChecked]\r
procedure TAction.SetChecked(const Value: boolean);\r
begin\r
  if FChecked = Value then exit;\r
  FChecked := Value;\r
  UpdateControls;\r
end;\r
\r
//[procedure TAction.SetEnabled]\r
procedure TAction.SetEnabled(const Value: boolean);\r
begin\r
  if FEnabled = Value then exit;\r
  FEnabled := Value;\r
  UpdateControls;\r
end;\r
\r
//[procedure TAction.SetHelpContext]\r
procedure TAction.SetHelpContext(const Value: integer);\r
begin\r
  if FHelpContext = Value then exit;\r
  FHelpContext := Value;\r
  UpdateControls;\r
end;\r
\r
//[procedure TAction.SetHint]\r
procedure TAction.SetHint(const Value: string);\r
begin\r
  if FHint = Value then exit;\r
  FHint := Value;\r
  UpdateControls;\r
end;\r
\r
//[procedure TAction.SetOnExecute]\r
procedure TAction.SetOnExecute(const Value: TOnEvent);\r
begin\r
  if @FOnExecute = @Value then exit;\r
  FOnExecute:=Value;\r
  UpdateControls;\r
end;\r
\r
//[procedure TAction.SetVisible]\r
procedure TAction.SetVisible(const Value: boolean);\r
begin\r
  if FVisible = Value then exit;\r
  FVisible := Value;\r
  UpdateControls;\r
end;\r
\r
//[procedure TAction.UpdateControls]\r
procedure TAction.UpdateControls;\r
var\r
  i: integer;\r
begin\r
  with FControls{-}^{+} do\r
    for i:=0 to Count - 1 do\r
      PControlRec(Items[i]).UpdateProc(Items[i]);\r
end;\r
\r
//[procedure TAction.UpdateCtrl]\r
procedure TAction.UpdateCtrl(Sender: PControlRec);\r
begin\r
  with Sender^, PControl(Ctrl){-}^{+} do begin\r
    if Caption <> Self.FCaption then\r
      Caption:=Self.FCaption;\r
    if Enabled <> Self.FEnabled then\r
      Enabled:=Self.FEnabled;\r
    if Checked <> Self.FChecked then\r
      Checked:=Self.FChecked;\r
    if Visible <> Self.FVisible then\r
      Visible:=Self.FVisible;\r
  end;\r
end;\r
\r
//[procedure TAction.UpdateMenu]\r
procedure TAction.UpdateMenu(Sender: PControlRec);\r
var\r
  s: string;\r
begin\r
  with Sender^, PMenu(Ctrl).Items[ItemID]{-}^{+} do begin\r
    s:=Self.FCaption;\r
    if Self.FShortCut <> '' then\r
      s:=s + #9 + Self.FShortCut;\r
    if Caption <> s then\r
      Caption:=s;\r
    if Enabled <> Self.FEnabled then\r
      Enabled:=Self.FEnabled;\r
    if Checked <> Self.FChecked then\r
      Checked:=Self.FChecked;\r
    if Visible <> Self.FVisible then\r
      Visible:=Self.FVisible;\r
    if HelpContext <> Self.FHelpContext then\r
      HelpContext:=Self.FHelpContext;\r
    if Self.FAccelerator.Key <> 0 then {YS}  // Äîáàâèòü\r
      Accelerator:=Self.FAccelerator;\r
  end;\r
end;\r
\r
//[procedure TAction.UpdateToolbar]\r
procedure TAction.UpdateToolbar(Sender: PControlRec);\r
var\r
  i: integer;\r
  s: string;\r
begin\r
  with Sender^, PControl(Ctrl){-}^{+} do begin\r
    i:=TBIndex2Item(ItemID);\r
    s:=TBButtonText[i];\r
    if (s <> '') and (s <> Self.FCaption) then\r
      TBButtonText[i]:=Self.FCaption;\r
    TBSetTooltips(i, [PChar(Self.FHint)]);\r
    if TBButtonEnabled[ItemID] <> Self.FEnabled then\r
      TBButtonEnabled[ItemID]:=Self.FEnabled;\r
    if TBButtonVisible[ItemID] <> Self.FVisible then\r
      TBButtonVisible[ItemID]:=Self.FVisible;\r
    if TBButtonChecked[ItemID] <> Self.FChecked then\r
      TBButtonChecked[ItemID]:=Self.FChecked;\r
  end;\r
end;\r
\r
//[procedure TAction.SetAccelerator]\r
procedure TAction.SetAccelerator(const Value: TMenuAccelerator);\r
begin\r
  if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then exit;\r
  FAccelerator := Value;\r
  FShortCut:=GetAcceleratorText(FAccelerator);  // {YS}\r
  UpdateControls;\r
end;\r
\r
{ TActionList }\r
\r
//[function TActionList.Add]\r
function TActionList.Add(const ACaption, AHint: string; OnExecute: TOnEvent): PAction;\r
begin\r
  Result:=NewAction(ACaption, AHint, OnExecute);\r
  FActions.Add(Result);\r
end;\r
\r
//[procedure TActionList.Clear]\r
procedure TActionList.Clear;\r
begin\r
  while FActions.Count > 0 do\r
    Delete(0);\r
  FActions.Clear;  \r
end;\r
\r
//[procedure TActionList.Delete]\r
procedure TActionList.Delete(Idx: integer);\r
begin\r
  Actions[Idx].Free;\r
  FActions.Delete(Idx);\r
end;\r
\r
//[destructor TActionList.Destroy]\r
destructor TActionList.Destroy;\r
begin\r
  UnRegisterIdleHandler(DoUpdateActions);\r
  Clear;\r
  FActions.Free;\r
  inherited;\r
end;\r
\r
//[procedure TActionList.DoUpdateActions]\r
procedure TActionList.DoUpdateActions(Sender: PObj);\r
begin\r
  if Assigned(FOnUpdateActions) and (GetActiveWindow = FOwner.Handle) then\r
    FOnUpdateActions(PObj( @Self ));\r
end;\r
\r
//[function TActionList.GetActions]\r
function TActionList.GetActions(Idx: integer): PAction;\r
begin\r
  Result:=FActions.Items[Idx];\r
end;\r
\r
//[function TActionList.GetCount]\r
function TActionList.GetCount: integer;\r
begin\r
  Result:=FActions.Count;\r
end;\r
\r
{$IFDEF USE_CUSTOMEXTENSIONS}\r
  {$I CUSTOM_CODE_EXTENSION.inc} // See comments in TControl\r
{$ENDIF USE_CUSTOMEXTENSIONS}\r
\r
//[initialization]\r
initialization\r
//[finalization]\r
finalization\r
{$IFDEF UNLOAD_RICHEDITLIB}\r
  if FRichEditModule <> 0 then\r
    FreeLibrary( FRichEditModule );\r
{$ENDIF UNLOAD_RICHEDITLIB}\r
\r
//[END OF KOL.pas]\r
end.\r
\r