diff --git a/KOL.pas b/KOL.pas index b3d25b6..f45d8e9 100644 --- a/KOL.pas +++ b/KOL.pas @@ -11,7 +11,7 @@ KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL Key Objects Library (C) 2000 by Vladimir Kladov. **************************************************************** -* VERSION 3.23.svn +* VERSION 3.SVN **************************************************************** K.O.L. - is a set of objects and functions to create small programs with the Delphi, but without the VCL/CLX. KOL allows to create @@ -21,7 +21,7 @@ KOL is provided free with the source code. Copyright (C) Vladimir Kladov, 2000-2011. - For code provided by other developers (even if later + For code provided by other developers (even if later changed by me) authors are noted in the source. mailto: vk@kolmck.net; Web-Page: http://kolmck.net See also Mirror Classes Kit (M.C.K.) which allows to create KOL programs visually. @@ -31,89 +31,13 @@ Thaddy de Koning - thaddy@thaddy.com (merge 3.22) ****************************************************************} {$I KOLDEF.inc} -{$IFDEF WIN64} - {$DEFINE PAS_ONLY} - {.$ALIGN 8} - {$Z1} -{$ENDIF} - -{$IFDEF PAS_ONLY} {$DEFINE PAS_VERSION} {$ENDIF PAS_ONLY} {$IFDEF EXTERNAL_KOLDEFS} {$INCLUDE PROJECT_KOL_DEFS.INC} {$ENDIF EXTERNAL_KOLDEFS} {$IFDEF EXTERNAL_DEFINES} {$INCLUDE EXTERNAL_DEFINES.INC} {$ENDIF EXTERNAL_DEFINES} unit KOL; {* - Please note, that KOL does not use keyword 'class'. Instead, - poor Pascal 'object' is the base of our objects. So, remember, - how we worked earlier with such Object Pascal's objects: -|
- - to create objects dynamically, use P instead of - T to allocate a pointer for dynamically created - object instance; -|
- - remember, that constructors of objects can not be virtual. - Override procedure Init instead in your own derived objects; -|
- - rather then call constructors of objects, call global procedures - New (e.g. NewLabel). If not, first (for virtually - created objects) call New( ); then call constructor Create - (which calls Init) - but this is possible only if the constructor - is overridden by a new one. -|
- - the operator 'is' is not applicable to objects. And operator 'as' - is not necessary (and is not applicable too), use typecast to desired - object type, e.g.: "PSomeObjectType( C )" in place of "C as TSomeClassType". -|
-|
- Also remember, that IF [ MyObj: PMyObj ] THEN - - NOT[ with MyObj do ] BUT[ with MyObj^ do ] - - Though it is possible to skip '^' symbol when accessing member - fields, methods, properties, e.g. [ MyObj.Execute; ] -|
-|&U=   %0
-|&B=%0
-|&C=%0 -| -| -| -| -| -| -| -|
objects functions by category
- - - - - - - - - - - -| -| - Visual objects constructing functions -|

- - - - - - - - - - - - -|
- - Following conditional symbols can be used in a project (Project-Options-Directories/Conditional Defines) + Following conditional symbols can be used in a (Project-Options-Directories/Conditional Defines) to change code generated a bit. There are following: - + EXTERNAL_KOLDEFS - since there are a lot of such symbols, it may be not possible to include all the desired optional symbols in the Project Options (Delphi has a restriction to 256 @@ -133,55 +57,8 @@ unit KOL; only). This option should be included only in MCK package options and never in options of the KOL/MCK application. PAS_VERSION - to use Pascal version of the code. - USE_CMOV - force using CMOV machine instruction in asm code (not recommended, - still on some machines your application will not work). - SMALLEST_CODE - to create minimal code application (affected: - (o) SimpleGetCtlBrushHandle - returns solid silver brush - always; - (o) _NewWindowed - - only default system font used by default; - font of the parent control is not applied to its - children automatically (but see SMALLEST_CODE_PARENTFONT); - - fBrush always set to NIL by default (parent Brush - is not applied); - (o) WndProcDoEraseBkgnd - - child controls windows are not created in WM_ERASEBKGND - if were not created earlier (in most case, all OK - with this - controls are created BTW); - - SetBkColor, SetBkMode, SetBrushOrgEx are not - called (all OK therefore) - (o) by default, NOT_UNLOAD_RICHEDITLIB is defined if - UNLOAD_RICHEDITLIB is not defined in project options - (this minimizes finalization section). - (o) _NewControl - - BoundsRect initialized with a rectangle - (aParent.fMarginLeft, aParent.fMarginTop, - aParent.fMarginLeft+64, aParent.fMargin+64) - rather then with (aParent.fMargin+aParent.fMarginLeft, - aParent.fMargin+aParent.fMarginTop, - aParent.fMargin+aParent.fMarginLeft+64, - aParent.fMargin+aParent.fMarginTop+64). - In most cases this is enough. - (o) Int2Hex - there are no check for second parameter > 15 - (o) .... other see in code - SMALLER_CODE - like smallest code, but functionality is the same. The speed can be lower therefore. - SMALLEST_CODE_PARENTFONT - Parent font therefore is applied for child controls, but initially only. - SPEED_FASTER - by default (but off when SMALLEST_CODE on) - sorting of - TStrList.AnsiSort and comparing using AnsiCompareStrA, - AnsiCompareStrNoCaseA is much faster (about 5-6 times). - Also, sorting of lists and strlists is redirected to - SortArray which is faster about 5-15% (vs SortData). - To turn off, add a symbol SPEED_NORMAL. REGKEYGETSTREX_ALWAYS - If you use already RegKeyGetStrEx, add this option to redirect RegKeyGetStr to it. - NOT_USE_EXCEPTIONS - to prevent referencing unit ERR.PAS in uses even when KOLmath is listed there. - REDEFINE_ABS - usual Abs works as a macro which is better in most cases. But who knows... - CUSTOM_APPICON - when this option is defined, the resource name for the - application icon is extracted from a file - CusomAppIconRsrcName_PAS.inc (place it in your project - folder and type there name of the resource in quotes). - By default, string 'MAIN' is used like in usual Delphi application. USE_NAMES - to use property Name with any TObj. This makes also available method TObj.FindObj( name ): PObj. UNIQUE_NAMES - provide Name property to be unique among all siblings. @@ -195,30 +72,21 @@ unit KOL; DFLT_TLIST_NOUSE_BLOCKS - for TLIST_FAST: by default, do not make all TList objects using new (fast) algorithms, but only those of TList objects, which property UseBlocks was set to TRUE after creating it. - OLD_REGKEYGETSUBKEYS - to use elder version of RegKeyGetSubKeys functions - (new version is faster). - OLD_REGKEYGETVALUENAMES - to use elder version of RegKeyGetValueNames - (newer version is faster). USE_CUSTOMEXTENSIONS - to extend TControl with custom additions. DATE0_0001 - to correct correctly TDateTime to TSystemTime and vice versa even for dates earlier then 1-Jan-1601. UNICODE_CTRLS - to use Unicode versions of controls (WM_XXXXW messages, etc.) - SAFE_CODE - use more safe code in some algorithms (but more slowly - and taking more code a bit). USE_OnIdle - to use OnIdle event - SNAPMOUSE2DFLTBTN - for all MessageBox-based functions, snap mouse to - default button is provided if such option is on in - mouse driver settings. - BUTTON_DBLCLICK - to prevent clicking buttons with double click (separate - event OnMouseDblClk is fired in such case), this takes - smaller code but buttons can not be pressed with mouse - fast. When SMALLEST_CODE on, this option also is on. - ALL_BUTTONS_RESPOND_TO_ENTER - obvious (by default, buttons respond to key - SPACE, since those are working this way in Windows). - CLICK_DEFAULT_CANCEL_BTN_DIRECTLY - to prevent visual effect of default/cancel - button pressing with Enter/Escape keys. Also, button - don't become focused in such case. + SNAPMOUSE2DFLTBTN - for all MessageBox-based functions, snap mouse to default button is + provided if such option is on in mouse driver settings. + BUTTON_DBLCLICK - to prevent clicking buttons with double click (separate event + OnMouseDblClk is fired in such case), this takes smaller code but buttons + can not be pressed with mouse fast. + ALL_BUTTONS_RESPOND_TO_ENTER - obvious (by default, buttons respond to key SPACE, since those are + working this way in Windows). + CLICK_DEFAULT_CANCEL_BTN_DIRECTLY - to prevent visual effect of default/cancel button pressing + with Enter/Escape keys. Also, button don't become focused in such case. DEFAULT_CANCEL_BTN_EXCLUSIVE - to disable assigning to a button properties DefaultBtn and CancelBtn simultaneously. NO_DEFAULT_BUTTON_BOLD - to prevent DefaultBtn to be visually with a bold border. @@ -231,11 +99,6 @@ unit KOL; KEY_PREVIEW - form also receive WM_KEYDOWN (OnKeyDown event fired) SUPPORT_ONDEADCHAR - to support OnKeyDeadChar event in response to WM_DEADCHAR, WM_SYSDEADCHAR AUTO_CONTEXT_HELP - to use automatic respond to WM_CONTEXTMENU to call context help. - NOT_FIX_MODAL - not to fix modal (if fixed, click on any window - activates the application. If not fixed, code is - smaller very a little, but only click on modal form - activates the application). This does not fix calling - MsgBox though. MODAL_ACTIVATE_FIX - if this option is set, all the windows of clicked app with active modal form are brought to foreground, not only modal form itself. This option is not necessary if @@ -245,13 +108,10 @@ unit KOL; USE_SETMODALRESULT - to guarantee ModalResult property assigning handling. USE_SHOWMODALPARENTED_ALWAYS - to use TControl.ShowModalParented( Applet ) instead of TControl.ShowModal always. - USE_MENU_CURCTL - to use CurCtl property in popup menu to detect which - control initiated a pop-up. + USE_MENU_CURCTL - to use CurCtl property in popup menu to detect which control initiated a pop-up. NEW_MENU_ACCELL - to use new menu accelerators handling, without AcceleratorTable (not tested for all cases) USE_DROPDOWNCOUNT - to force setting combobox dropdown count. - NOT_UNLOAD_RICHEDITLIB - to stop unload Rich Edit library in finalization - section (to economy several byte of code). NOT_USE_RICHEDIT - not use richedit (it will not be possible to create richedit) TV_DRAG_RBUTTON - to allow dragging tree view items with right mouse button too. TOOLBAR_FORCE_CHILDALIGN - this option provides Align working for child @@ -270,11 +130,6 @@ unit KOL; CANRESIZE_THICKFRAME - to use elder version of CanResize, changing border style of the window (this cause incorrect form view in Vista Aero theme (due a bug in Vista?)). - ANCHORS_WM_SIZE - to check WM_SIZE message in Anchor handling window - procedure. By default, now used WM_WINDOWPOSCHANGED. - USE_PROP - to use GetProp / SetProp (old style) in place of - Get / SetWindowLong( wnd, GWL_USERDATA... ) (slower?) - PROVIDE_EXITCODE - PostQuitMessage( value ) assigns value to ExitCode INITIALFORMSIZE_FIXMENU - form size initially is really the same as defined at design time even for forms having main menu bar USE_GRAPHCTLS - to use graphic (non-windowed) controls @@ -315,25 +170,11 @@ unit KOL; paths (принудительное использование альтернативного имени пути и имени файла для юникод путей) NEW_GRADIENT - to use new gradient painting by homm (fast). - OLD_ALIGN - to prevent using new Align by Galkov. - NEW_ALIGN - (default) - to use new Align implementation (faster). - OLD_TRANSPARENT - to prevent using NEW_TRANSPARENT - NEW_TRANSPARENT - created by Alexander Karpinsky a.k.a. homm (faster) - OLD_REFCOUNT - to prevent using new RefInc/RefDec behavior (new style works better). - OLD_FREE - to declare Free as a method as in earlier versions of KOL. - In new versions, Free is declared as a property, and - "calling" it just redirects call to RefDec. OLD_FREE - can be used for compatibility with compilers not - understanding "calling" a property without assigning - something to or from it (Turbo Delphi?). FILE_EXISTS_EX - to use more correct (but a bit large code in FileExists function) - USE_AUTOFREE4CONTROLS - (default) - from 2.40, most of control sub-objects are - destroying using Add2AutoFree (smaller code). ENDSESSION_HALT - to halt the process when WM_ENDSESSION comes. FILESTREAM_POSITION - in PAS_VERSION, Stream..fData.fPosition always show current position (for debug purposes) PSEUDO_THREADS - to use pseudo-threads instead of normal threads. - WAIT_SLEEP - for PSEUDO_THREADS: sleep 10 ms in a WaitForMultipleObjects loop. ENUM_DYN_HANDLERS_AFTER_RUN - to allow all the events handling even when AppletTerminated become TRUE. STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED - use this long-named option to prevent any functionality of WndProcTransparent after @@ -345,7 +186,6 @@ unit KOL; to handle such events). DEBUG_MENU - to debug menu. DEBUG_GDIOBJECTS - to allow counting all the GDI objects used. - CHK_BITBLT - to check BitBlt operations. DEBUG_ENDSESSION - to allow debugging WM_ENDSESSION handling. DEBUG_CREATEWINDOW - to debug CreateWindow. CRASH_DEBUG - to fill object memory with $DD before freeing it @@ -372,9 +212,8 @@ unit KOL; more then 50 flags occupying earlies 1 byte for each flag). This option is turned on by default. To turn off, define a symbol USE_OLD_FLAGS ! - EVENTS_DYNAMIC - to create events record (about 600 bytes) only for - controls having assigned events. To turn off, define a - symbol EVENTS_STATIC. + EVENTS_DYNAMIC - to create events record (about 600 bytes) only for controls having + assigned events. To turn off, define a symbol EVENTS_STATIC. NIL_EVENTS - by default, is off. This option returns back again checking TControl's events if it is assigned before calling. By default, now this option is off, all events are assigned @@ -382,15 +221,9 @@ unit KOL; is assigned is not necessary. But it is not allowed to assign NIL to the event, instead call ResetEvent method with the correspondent index (e.g. idx_fOnMessage). - COMMANDACTIONS_OBJ - to store command actions certain for different control - kinds in shared objects, separately from TControl object - instances. To turn off, define a symbol COMMANDACTIONS_RECORD. - PACK_COMMANDACTIONS - this option must be defined together with COMMANDACTIONS_OBJ - and must not with COMMANDACTIONS_RECORD (just do nothing - and this is applied automatically). + PACK_COMMANDACTIONS - use packed version of COMMANDACTIONSOBJ | } -// = K.O.L - ключевая библиотека объектов. (C) Кладов Владимир, 2000-2007. {$IFNDEF WIN64} {$A-} // align off, otherwise code is not good {$Q-} // no overflow check: this option makes code wrong @@ -398,7 +231,6 @@ unit KOL; {$Z-} {$ENDIF} {$T-} // not typed @-operator -//{$D+} {$IFDEF PUREPASCAL} {$DEFINE PAS_VERSION} @@ -422,54 +254,9 @@ unit KOL; {$ENDIF} interface -{$IFnDEF CREATE_VISIBLE} - {$DEFINE CREATE_HIDDEN} -{$ENDIF} -{$IFDEF NEW_ALIGN} - {$UNDEF OLD_ALIGN} -{$ELSE} - {$IFNDEF OLD_ALIGN} - {$DEFINE NEW_ALIGN} - {$ENDIF} -{$ENDIF} -{$IFDEF OLD_ALIGN} - {$UNDEF NEW_ALIGN} -{$ELSE} - {$IFNDEF NEW_ALIGN} - {$DEFINE NEW_ALIGN} - {$ENDIF} -{$ENDIF} -{$IFNDEF OLD_TRANSPARENT} - {$DEFINE NEW_TRANSPARENT} -{$ENDIF} -{$DEFINE USE_AUTOFREE4CONTROLS} -{$DEFINE USE_AUTOFREE4CHILDREN} -{$IFDEF SMALLEST_CODE} - {$DEFINE NOT_UNLOAD_RICHEDITLIB} - {$DEFINE SMALLER_CODE} - {$DEFINE CREATE_VISIBLE} -{$ELSE} - {$IFnDEF SPEED_NORMAL} - {$DEFINE SPEED_FASTER} - {$ENDIF} -{$ENDIF} -{$IFDEF SAFE_CODE} - {$UNDEF NO_SAFE_CODE} -{$ENDIF} -{$IFDEF NO_SAFE_CODE} - {$UNDEF SAFE_CODE} -{$ENDIF} -{$IFnDEF NO_SAFE_CODE} -{$IFnDEF SMALLER_CODE} - {$DEFINE SAFE_CODE} -{$ENDIF} -{$ENDIF} -{$IFDEF NOT_USE_RICHEDIT} - {$DEFINE NOT_UNLOAD_RICHEDITLIB} -{$ENDIF} uses - Messages, Windows{$IFNDEF NOT_USE_RICHEDIT}, RichEdit{$ENDIF}{$IFDEF CHK_GDI}, ChkGdi {$ENDIF}; + Windows, Messages {$IFNDEF NOT_USE_RICHEDIT}, RichEdit{$ENDIF}; var AppTheming: Boolean; @@ -531,6 +318,8 @@ type {$ENDIF} {$ENDIF FPC} +PKOLString = ^KOLString; + {$IFNDEF ASM_VERSION} {$DEFINE PAS_VERSION} {$ENDIF ASM_VERSION} @@ -546,7 +335,7 @@ type {$I delphicommctrl.inc} {$ELSE} {$I delphicommctrl.inc} - {$I KOL_API.inc.pas} + {$I KOL_API.inc} {$ENDIF FPC} type @@ -593,9 +382,6 @@ type {$ENDIF} fRefCount: Integer; fOnDestroy: TOnEvent; - {$IFDEF OLD_REFCOUNT} - procedure DoDestroy; - {$ENDIF} protected fAutoFree: PList; {* Is called from a constructor to initialize created object instance @@ -659,17 +445,13 @@ type вызов Free немедленно ПЕРЕД последним RefDec. } property RefCount: Integer read fRefCount; {* } - {$IFDEF OLD_FREE} - procedure Free; - {$ELSE NEW_FREE} - property Free: Integer read RefDec; + procedure Free; inline; {* Before calling destructor of object, checks if passed pointer is not nil - similar what is done in VCL for TObject. It is ALWAYS recommended to use Free instead of Destroy - see also comments to RefInc, RefDec. } {= До вызова деструктора, проверяет, не передан ли nil в качестве параметра. ВСЕГДА рекомендуется использовать Free вместо Destroy - см. так же RefInc, RefDec. } - {$ENDIF NEW_FREE} // By Vyacheslav Gavrik: function InstanceSize: Integer; {* Returns a size of object instance. } @@ -698,6 +480,8 @@ type {* Adds an event handler to the list of events, called in destructor. This method is mainly for internal use, and allows to auto-destroy VCL components, located on KOL form at design time (in MCK project). } + procedure Add2AutoFreeStr(var S: String); + {* dufa: like Add2AutoFree, but for string *} procedure RemoveFromAutoFree( Obj: PObj ); {* Removes an object from auto-free list } procedure RemoveFromAutoFreeEx( Proc: TObjectMethod ); @@ -805,6 +589,10 @@ type procedure ReleaseItems; //dufa {* Especially for lists of pointers to dynamically allocated memory. Releases all pointed memory blocks only. } + procedure ReleaseObjectsOnly; + {* Especially for a list of objects derived from TObj. + Calls Free for every of the object in the list, and then calls + Clear } procedure ReleaseObjects; {* Especially for a list of objects derived from TObj. Calls Free for every of the object in the list, and then calls @@ -1356,18 +1144,22 @@ RT_VERSION Version resource { ------------------------- string list objects ------------------------------ } type - TCompareStrListFun = function( const S1, S2: PAnsiChar ): Integer; - TSwapEvent = procedure (const Data : Pointer; const e1,e2 : Dword); + TCompareStrListFun = function(const S1, S2: PAnsiChar): Integer; + { * TODO DESC } + TSwapEvent = procedure(const Data : Pointer; const e1, e2: DWORD); {* Event type to define swap procedure which is swapping two elements of the sorting data. } - TCompareArrayEvent = function(e1,e2 : DWord_PTR) : PtrInt; + TCompareArrayEvent = function(e1, e2: DWORD_PTR): PtrInt; {* Event type to define comparison function between two elements of an array. Like in TCompareEvent, but e1 and e2 are not indexes in the array but items themselves. } - PStrList = ^TStrList; + // TStrList options. dufa + TStrListOption = (sloCaseSensitive, sloAnsi, sloNames); + TStrListOptions = set of TStrListOption; { --------------------------------------------------------------------- TStrList - string list ---------------------------------------------------------------------- } + PStrList = ^TStrList; TStrList = object(TObj) {* Easy string list implementation (non-visual, just to store string data). It is well improved and has very high performance allowing to work fast with huge text files @@ -1376,18 +1168,6 @@ type the rest of a line. Be careful, if your data contain such characters. } protected procedure Init; virtual; - protected - fList: PList; - fCount: Integer; - FItemIndex: Integer; //dufa - fTextBuf: PAnsiChar; - fTextSiz: DWORD; - fCompareStrListFun: TCompareStrListFun; - fCaseSensitiveSort: Boolean; - fAnsiSort: Boolean; - function GetPChars(Idx: Integer): PAnsiChar; - //procedure AddTextBuf( Src: PAnsiChar; Len: DWORD ); - protected {$IFDEF TLIST_FAST} function GetUseBlocks: Boolean; procedure SetUseBlocks(const Value: Boolean); @@ -1401,21 +1181,47 @@ type function GetValueNoCase(const AName: AnsiString): AnsiString; procedure SetValue(const AName, Value: Ansistring); procedure SetValueNoCase(const AName, Value: AnsiString); + function GetPChars(Idx: Integer): PAnsiChar; + procedure UpdateCompare; // dufa + // by Alexander Pravdin: + function GetLineName( Idx: Integer ): AnsiString; + procedure SetLineName( Idx: Integer; const NV: AnsiString ); + function GetLineValue(Idx: Integer): Ansistring; + procedure SetLineValue(Idx: Integer; const Value: Ansistring); + procedure SetOptions(const Value: TStrListOptions); + function GetValueSorted(const AName: AnsiString): AnsiString; + procedure SetValueSorted(const AName, Value: AnsiString); + protected + fList: PList; + fCount: Integer; + fTextBuf: PAnsiChar; + fTextSiz: DWORD; + FColsCount: Integer; // dufa + FItemIndex: Integer; // dufa + FCompare: TCompareStrListFun; // dufa + FOptions: TStrListOptions; // dufa + fNameDelim: AnsiChar; // by Alexander Pravdin: public function IndexOfName(const AName: AnsiString): Integer; {* Returns index of line starting like Name=... } function IndexOfName_NoCase(const AName: AnsiString): Integer; {* Returns index of line starting like Name=... (case insensitive) } property Values[const AName: Ansistring]: AnsiString read GetValue write SetValue; - {* Returns right side of a line starting like Name=... } + {* Returns right side of a line starting like Name=..., Name case insensitive } property Values_Nocase[const AName: AnsiString]: AnsiString read GetValueNocase write SetValueNoCase; + {* Returns right side of a line starting like Name=..., when list options is [sloNames] } + property Values_Sorted[const AName: AnsiString]: AnsiString read GetValueSorted write SetValueSorted; {* Returns right side of a line starting like Name=... (case insensitive) } function Add(const S: Ansistring): Integer; {* Adds a string to list. } - function AddSorted(const S: Ansistring): Integer; - {* Adds a string to sorted list. } + function AddValue(const AName, AValue: AnsiString): Integer; + {* Adds a name=value to list. dufa} + function AddSorted(const S: AnsiString; const Uniq: Boolean = False): Integer; + {* Adds a string to sorted list. With uniq option - no duplicates. dufa} procedure AddStrings(Strings: PStrList); {* Merges string list with given one. Very fast - more preferable to use than any loop with calling Add method. } + procedure AddStrings_Fast(src: PStrList); + {* dufa } procedure Assign(Strings: PStrList); {* Fills string list with strings from other one. The same as AddStrings, but Clear is called first. } procedure Clear; @@ -1428,10 +1234,14 @@ type {* Removes first entry of a Value in the list. } procedure RemoveByName(AName: Ansistring); {* Removes first entry of a line starting like "AName=" in the list. } + procedure RemoveByNameNoCase(AName: Ansistring); + {* Removes first entry of a line starting like "AName=" in the list (while comparing it + without case sensitivity). } procedure DeleteLast; {* Deletes the last string (it *must* exist). } function IndexOf(const S: AnsiString): Integer; function IndexOf_Fast(const S: AnsiString): Integer; + function IndexOf_New(const S: AnsiString): Integer; {* Returns index of first string, equal to given one. } function IndexOf_NoCase(const S: Ansistring): Integer; function IndexOf_Fast_NoCase(const S: AnsiString): Integer; @@ -1445,14 +1255,19 @@ type works only for sorted TStrList object. Returns TRUE if exact string found, otherwise nearest (greater then a pattern) string index is returned, and the result is FALSE. And in such _case Index is returned negated - when the S string is less then the string found. } + when the S string is less then the string found. + Use [sloNames] - for find by LineName (LiveValue ignored) dufa } function FindFirst(const S: AnsiString; var Index: Integer): Boolean; {* Like above but always returns Index of the first string, equal or greater to given pattern. Also works only for sorted TStrList object. Returns TRUE if exact string found, otherwise nearest (greater then a pattern) string index is returned, and the result is FALSE. } + function FindVCL_(const S: string; var Index: Integer): Boolean; + {* TODO DESC. dufa} procedure Insert(Idx: integer; const S: Ansistring); {* Inserts string before one with given index. } + procedure InsertValue(Idx: Integer; const AName, AValue: AnsiString); + {* Inserts name=value before one with given index. dufa } procedure Move(CurIndex, NewIndex: integer); {* Moves string to another location. } procedure SetText(const S: Ansistring; Append2List: Boolean); @@ -1463,7 +1278,7 @@ type Assign, AddStrings). } procedure SetUnixText( const S: AnsiString; Append2List: Boolean ); {* Allows to assign UNIX-style text (with #10 as string separator). } - property Count: integer read fCount; + property Count: Integer read fCount; {* Number of strings in a string list. } property Items[Idx: integer]: Ansistring read Get write Put; default; {* Strings array items. If item does not exist, empty string is returned. @@ -1472,38 +1287,34 @@ type {* Fast access to item strings as PChars. } function Last: AnsiString; {* Last item (or '', if string list is empty). } + function First: AnsiString; + {* First item (or '', if string list is empty). dufa} property Text: Ansistring read GetTextStr write SetTextStr; {* Content of string list as a single string (where strings are separated by chars $0D,$0A) } - procedure Swap( Idx1, Idx2 : Integer ); + procedure Swap(Idx1, Idx2 : Integer); {* Swaps to strings with given indexes. } - procedure Sort( CaseSensitive: Boolean ); - {* Call it to sort string list. } - procedure AnsiSort( CaseSensitive: Boolean ); - {* Call it to sort ANSI string list. } - procedure SortEx(const CompareFun: TCompareEvent); + procedure Sort(AOptions: TStrListOptions); + {* Call it to sort string list. Use [sloNames] - for sort by LineName (LiveValue ignored). Dufa } + procedure SortEx(const CompareFun: TCompareEvent; const SwapProc: TSwapEvent); overload; + {* Call it to sort via your own compare procedure + swap proc. Dufa } + procedure SortEx(const CompareFun: TCompareEvent); overload; {* Call it to sort via your own compare procedure. Dufa } - property IsAnsiSorted: Boolean read fAnsiSort write fAnsiSort; - {* TODO DESC } - property IsCaseSensitiveSorted: Boolean read fCaseSensitiveSort write fCaseSensitiveSort; - {* TODO DESC } - protected // by Alexander Pravdin: - fNameDelim: AnsiChar; - function GetLineName( Idx: Integer ): AnsiString; - procedure SetLineName( Idx: Integer; const NV: AnsiString ); - function GetLineValue(Idx: Integer): Ansistring; - procedure SetLineValue(Idx: Integer; const Value: Ansistring); - public + property Options: TStrListOptions read FOptions write SetOptions; + {* TODO DESC. Dufa } + property Compare: TCompareStrListFun read FCompare write FCompare; + {* TODO DESC. Dufa } property LineName[ Idx: Integer ]: Ansistring read GetLineName write SetLineName; + {* TODO DESC } property LineValue[ Idx: Integer ]: Ansistring read GetLineValue write SetLineValue; + {* TODO DESC } property NameDelimiter: AnsiChar read fNameDelim write fNameDelim; - function Join( const sep: AnsiString ): AnsiString; + {* TODO DESC } + function Join(const sep: AnsiString; const AddLastSep: Boolean = True): AnsiString; {* by Sergey Shishmintzev } function LoadFromFile(const FileName: KOLString): Boolean; - {* Loads string list from a file. (If file does not exist, nothing - happens). Very fast even for huge text files. } + {* Loads string list from a file. (If file does not exist - nothing happens). Very fast even for huge text files. } procedure LoadFromStream(Stream: PStream; Append2List: Boolean); - {* Loads string list from a stream (from current position to the end of - a stream). Very fast even for huge text. } + {* Loads string list from a stream (from current position to the end of a stream). Very fast even for huge text. } procedure MergeFromFile(const FileName: KOLString); {* Merges string list with strings in a file. Fast. } function SaveToFile(const FileName: KOLString): Boolean; @@ -1513,12 +1324,10 @@ type function AppendToFile(const FileName: KOLString): Boolean; {* Appends strings of string list to the end of a file. } procedure OptimizeForRead; - {* } + {* TODO DESC } {$IFDEF TLIST_FAST} property UseBlocks: Boolean read GetUseBlocks write SetUseBlocks; {$ENDIF TLIST_FAST} - public - ColsCount: Integer; {* For Matrix-Items access, Cols count. dufa } procedure DeleteRange(Idx, Len: Integer); {* Like TList.DeleteRange. dufa } @@ -1539,12 +1348,18 @@ type But for assign to property, string with given index *must* exist. } procedure Swap2(Idx1, Idx2: Integer); {* For Matrix-Items access, like Swap. dufa} - function IndexOf2(const S2: array of AnsiString): Integer; + function IndexOf2(const S: array of AnsiString; const FullMatch: Boolean): Integer; overload; + function IndexOf2(const S: AnsiString; const Col: Integer): Integer; overload; + function IndexOf2_NoCase(const S: AnsiString; const Col: Integer): Integer; {* For Matrix-Items access, like IndexOf. dufa} + function Last2(Col: Integer): AnsiString; + {* For Matrix-Items access, like Last. dufa} function IsEmpty: Boolean; {* Is list empty? dufa } function GetRandomItem: AnsiString; {* Get random item. dufa } + procedure Shuffle; + {* Randomize list items. dufa } procedure ItemFirst; {* Select first item - ItemIndex = 0, Dufa } procedure ItemLast; @@ -1555,8 +1370,10 @@ type {* Select next item and return False if End Of List. Dufa } function ItemPrev(var Item: AnsiString): Boolean; {* Select prev item and return False if Start Of List. Dufa } - property ItemIndex: Integer read FItemIndex; + property ItemIndex: Integer read FItemIndex write FItemIndex; {* Current ItemIndex. Dufa } + property ColsCount: Integer read FColsCount write FColsCount; + {* For Matrix-Items access: columns count. Dufa } end; var DefaultNameDelimiter: AnsiChar = '='; @@ -1618,17 +1435,14 @@ type {* Moves string to another location. } procedure Swap( Idx1, Idx2 : Integer ); {* Swaps to strings with given indexes. } - procedure Sort( CaseSensitive: Boolean ); + procedure Sort(AOptions: TStrListOptions); // dufa {* Call it to sort string list. } procedure SortEx(const CompareFun: TCompareEvent); - {* Call it to sort string list by CompareFun.dufa } - procedure AnsiSort( CaseSensitive: Boolean ); - {* Call it to sort ANSI string list. } + {* Call it to sort string list by CompareFun. dufa } function LastObj: PtrUInt; {* Object associated with the last string. } function AddObject( const S: AnsiString; Obj: PtrUInt ): Integer; - {* Adds a string and associates given number with it. Index of the item added - is returned. } + {* Adds a string and associates given number with it. Index of the item added is returned. } procedure InsertObject( Before: Integer; const S: AnsiString; Obj: PtrUInt ); {* Inserts a string together with object associated. } function IndexOfObj( Obj: Pointer ): Integer; @@ -3492,8 +3306,7 @@ type At the same time, to use pointer to object in 'WITH' operator, it is necessary to apply suffix '^' to pointer to get know to compiler, what do You want. } - TWindowFunc = function( Sender: PControl; var Msg: TMsg; var Rslt: LRESULT ) - : Boolean; + TWindowFunc = function( Sender: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; {* Event type to define custom extended message handlers (as pointers to procedure entry points). Such handlers are usually defined like add-ons, extending behavior of certain controls and attached using AttachProc @@ -3620,7 +3433,6 @@ type aItem2XY: Word; end; - {$IFDEF COMMANDACTIONS_OBJ} PCommandActionsObj = ^TCommandActionsObj; TCommandActionsObj = object(TObj) aClear: procedure( Sender: PControl ); @@ -3645,7 +3457,6 @@ type fIndexInActions: Integer; destructor Destroy; virtual; end; - {$ENDIF} TTextAlign = ( taLeft, taRight, taCenter ); {* Text alignments available. } @@ -4153,7 +3964,7 @@ type fTBBtMinWidth: Integer; fTBBtMaxWidth: Integer; fTBttCmd: PList; - fTBttTxt: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF}; + fTBttTxt: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF}; // TODO: to TKOLStrList fTBCurItem: Integer; fDefaultTBBtnStyle: Byte; // for Toolbars fTBDropped: Boolean; @@ -4458,21 +4269,6 @@ type function Get_SizeRedraw: Boolean; procedure Set_SizeRedraw(const Value: Boolean); {$ENDIF USE_FLAGS} - public //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - FormString: KOLString; - {* строка текущего параметра. Очищается после каждого вызова - FormExecuteCommands, так что специальная очистка не требуется. } - function FormGetIntParam: PtrInt; - {* извлекает очередной целочисленный параметр до ',' или до ';' } - function FormGetColorParam: Integer; - {* извлекает очередной целочисленный параметр до ',' или до ';' } - procedure FormGetStrParam; - {* извлекает очередной строковый параметр до ',' или до ';' -> FormString } - procedure FormCreateParameters( alphabet: PFormInitFuncArray; params: PAnsiChar ); - {* задает первоначальный алфавит и параметры с командами } - procedure FormExecuteCommands(AForm: PControl; ControlPtrOffsets: PSmallIntArray); - {* выполняет команды (с параметрами) до конца или до ';' } - protected function GetDate: TDateTime; function GetTime: TDateTime; @@ -4588,7 +4384,7 @@ type function TBGetBtnWidth(BtnID: Integer): Integer; procedure TBSetBtnWidth(BtnID: Integer; const Value: Integer); - procedure TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer); + procedure TBSetBtMinMaxWidth(const Idx, Value: Integer); procedure TBFreeTBevents; function TBGetButtonLParam(const Idx: Integer): PtrUInt; procedure TBSetButtonLParam(const Idx: Integer; const Value: PtrUInt); @@ -4893,11 +4689,7 @@ type {$ENDIF} { } public - {$IFDEF COMMANDACTIONS_OBJ} fCommandActions: PCommandActionsObj; - {$ELSE} - fCommandActions: TCommandActions; - {$ENDIF} {$IFDEF EVENTS_DYNAMIC} EV: PEvents; protected @@ -4915,10 +4707,8 @@ type fMenuObj: PObj; {* PMenu pointer to TMenu object. Freed automatically with entire chain of menu objects attached to a control (or form). } -{$IFNDEF NEW_MENU_ACCELL} fAccelTable: HAccel; procedure DoDestroyAccelTable; -{$ENDIF} protected {* Handle of accelerator table created by menu(s). } fImageList: PImageList; @@ -5441,8 +5231,7 @@ type also ScreenCursor. } procedure CursorLoad( Inst: HINST; ResName: PKOLChar ); {* Loads Cursor from the resource. See also comments for Icon property. } - property Icon: HIcon read {$IFDEF SMALLEST_CODE} DF.fIcon {$ELSE} GetIcon {$ENDIF} - write SetIcon; + property Icon: HIcon read GetIcon write SetIcon; {* |<#appbutton> |<#form> Icon. By default, icon of the Applet is used. To load icon from the @@ -5524,100 +5313,68 @@ type selection. For rich edit, use RE_Text[ reText, TRUE ], if you want to read correctly characters from another locale then ANSI only. } procedure SelectAll; - {* |<#edit> - |<#memo> - |<#richedit> - Makes all the text in editbox or RichEdit, or all items in listbox - selected. } + {* |<#edit> <#memo> <#richedit> + Makes all the text in editbox or RichEdit, or all items in listbox selected. } procedure ReplaceSelection( const Value: KOLString; aCanUndo: Boolean ); - {* |<#edit> - |<#memo> - |<#richedit> + {* |<#edit> <#memo> <#richedit> Replaces selection (in edit, RichEdit). Unlike assigning new value to Selection property, it is possible to specify, if operation can be undone. - |
Use this method or assigning value to a Selection property to format text initially in the rich edit. E.g.: ! RichEdit1.RE_FmtBold := TRUE; ! RichEdit1.Selection := 'bold text'#13#10; ! RichEdit1.RE_FmtBold := FALSE; ! RichEdit1.RE_FmtItalic := TRUE; - ! RichEdit1.Selection := 'italic text'; - !... } + ! RichEdit1.Selection := 'italic text'; ... } procedure DeleteLines( FromLine, ToLine: Integer ); - {* |<#edit> - |<#memo> - |<#richedit> + {* |<#edit> <#memo> <#richedit> Deletes lines from FromLine to ToLine (inclusively, i.e. 0 to 0 deletes one line with index 0). Current selection is restored as possible. } property CurIndex: Integer read GetCurIndex write SetCurIndex; - {* |<#listbox> - |<#combo> - |<#toolbar> + {* |<#listbox> <#combo> <#toolbar> Index of current item (for listbox, combobox) or button index pressed - or dropped down (for toolbar button, and only in appropriate event - handler call). - |
+ or dropped down (for toolbar button, and only in appropriate event handler call). You cannot use it to set or remove a selection in a multiple-selection list box, so you should set option loNoExtendSel to true. - |
In OnClick event handler, CurIndex has not yet changed for listbox or combobox. Use OnSelChange to respond to selection changes. } property Count: Integer read GetItemsCount write SetItemsCount; - {* |<#listbox> - |<#combo> - |<#listview> - |<#treeview> - |<#edit> - |<#memo> - |<#richedit> - |<#toolbar> + {* |<#listbox> <#combo> <#listview> <#treeview> <#edit> <#memo> <#richedit> <#toolbar> Number of items (listbox, combobox, listview) or lines (multiline editbox, richedit control) or buttons (toolbar). It is possible to assign a value to this property only for listbox control with loNoData style and for list view control with lvoOwnerData style (virtual list box and list view). } property Items[ Idx: Integer ]: KOLString read GetItems write SetItems; - {* |<#edit> - |<#listbox> - |<#combo> - |<#memo> - |<#richedit> - Obvious. Used with editboxes, listbox, combobox. With list view, use - property LVItems instead. } + {* |<#edit> <#listbox> <#combo> <#memo> <#richedit> + Obvious. Used with editboxes, listbox, combobox. With list view, use property LVItems. } function Item2Pos( ItemIdx: Integer ): DWORD; - {* |<#edit> - |<#memo> + {* |<#edit> <#memo> Only for edit controls: converts line index to character position. } function Pos2Item( Pos: Integer ): DWORD; - {* |<#edit> - |<#memo> + {* |<#edit> <#memo> Only for edit controls: converts character position to line index. } function SavePosition: TEditPositions; - {* |<#edit> - |<#memo> + {* |<#edit> <#memo> Only for edit controls: saves current editor selection and scroll positions. To restore position, use RestorePosition with a structure, containing saved position as a parameter. } procedure RestorePosition( const p: TEditPositions ); - {* |<#edit> - |<#memo> + {* |<#edit> <#memo> Call RestorePosition with a structure, containing saved position as a parameter (this structure filled in in SavePosition method). If you set RestoreScroll to FALSE, only selection is restored, without scroll position. } procedure UpdatePosition( var p: TEditPositions; FromPos, CountInsertDelChars, CountInsertDelLines: Integer ); - {* |<#edit> - |<#memo> + {* |<#edit> <#memo> If you called SavePosition and then make some changes in the edit control, calling RestorePosition will fail if changes are affecting selection size. The problem can be solved updating saved position info using this method. Pass a count of inserted characters and lines as a positive number and a count of deleted characters as a negative number here. CountInsertDelLines - is optional parameters: if you do not specify it, only selection is fixed. - } + is optional parameters: if you do not specify it, only selection is fixed. } function EditTabChar: PControl; {* |<#edit> |<#memo> @@ -5640,44 +5397,34 @@ type list box or combobox, item is finding by enumerating all the Items one by one. See also IndexOf method. } property ItemSelected[ ItemIdx: Integer ]: Boolean read GetItemSelected write SetItemSelected; - {* |<#edit> - |<#memo> - |<#listbox> - |<#combo> - |<#listview> + {* |<#edit> <#memo> <#listbox> <#combo> <#listview> Returns True, if a line (in editbox) or an item (in listbox, combobox, listview) is selected. Can be set only for listboxes. For listboxes, which are not multiselect, and for combo lists, it is possible only to set to True, to change selection. } property ItemData[ Idx: Integer ]: PtrInt read GetItemData write SetItemData; - {* |<#listbox> - |<#combo> - Access to user-defined data, associated with the item of a list box and - combo box. } + {* |<#listbox> <#combo> + Access to user-defined data, associated with the item of a list box and combo box. } property OnDropDown: TOnEvent index idx_FOnDropDown read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnDropDown {$ENDIF} write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnDropDown {$ENDIF}; - {* |<#combo> - |<#toolbar> + {* |<#combo> <#toolbar> Is called when combobox is dropped down (or drop-down button of toolbar is pressed - see also OnTBDropDown). } property OnCloseUp: TOnEvent index idx_FOnCloseUp read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnCloseUp {$ENDIF} write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnCloseUp {$ENDIF}; {* |<#combo> - Is called when combobox is closed up. When drop down list is closed - because user pressed "Escape" key, previous selection is restored. - To test if it is so, call GetKeyState( VK_ESCAPE ) and check, if - negative value is returned (i.e. Escape key is pressed when event - handler is calling). } + Is called when combobox is closed up. When drop down list is closed because user pressed + "Escape" key, previous selection is restored. To test if it is so, + call GetKeyState( VK_ESCAPE ) and check, if negative value is returned + (i.e. Escape key is pressed when event handler is calling). } property DroppedWidth: Integer read DF.FDroppedWidth write SetDroppedWidth; {* |<#combo> - Allows to change width of dropped down items list for combobox (only!) - control. } + Allows to change width of dropped down items list for combobox (only!) control. } property DroppedDown: Boolean read GetDroppedDown write SetDroppedDown; {* |<#combo> - Dropped down state for combo box. Set it to TRUE or FALSE to change - dropped down state. } + Dropped down state for combo box. Set it to TRUE or FALSE to change dropped down state. } procedure AddDirList( const Filemask: KOLString; Attrs: DWORD ); {* |<#listbox> |<#combo> @@ -6223,10 +5970,9 @@ type property OnResize: TOnEvent read {$IFDEF EVENTS_DYNAMIC} Get_OnResize {$ELSE} EV.FOnResize {$ENDIF} write SetOnResize; {* Called whenever control receives message WM_SIZE (thus is, if control is resized. } property OnMove: TOnEvent read {$IFDEF EVENTS_DYNAMIC} Get_OnMove {$ELSE} EV.FOnMove {$ENDIF} write SetOnMove; - {* Called whenever control receives message WM_MOVE (i.e. when control is moved over its parent). } + {* Called whenever control recv. message WM_MOVE (i.e. when control is moved over its parent). } property OnMoving: TOnEventMoving read {$IFDEF EVENTS_DYNAMIC} Get_OnMoving {$ELSE} EV.FOnMoving {$ENDIF} write SetOnMoving; - {* Called whenever control receives message WM_MOVE (i.e. when control is - moved over its parent). } + {* Called whenever control recv. message WM_MOVE (i.e. when control is moved over its parent). } property MinSizePrev: Integer read DF.fSplitMinSize1 write DF.fSplitMinSize1; {* |<#splitter> Minimal allowed (while dragging splitter) size of previous control @@ -6483,14 +6229,12 @@ type (which can be used as a parent for controls to place on the page). } procedure TC_Delete( Idx: Integer ); {* |<#tabcontrol> Removes tab from tab control, destroying all its child controls. } -{$IFNDEF OLD_ALIGN} procedure TC_InsertControl( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer; Page: PControl); {* |<#tabcontrol> Inserts new tab before given, but not construct this Page (this control must be created before inserting, and may be not a Panel). } function TC_Remove( Idx: Integer ):PControl; {* |<#tabcontrol> Only removes tab from tab control, and return this Page as Result. } -{$ENDIF} property TC_Items[ Idx: Integer ]: KOLString read TCGetItemText write TCSetItemText; {* |<#tabcontrol> Text, displayed on tab control tabs. } property TC_Images[ Idx: Integer ]: Integer read TCGetItemImgIDx write TCSetItemImgIdx; @@ -6551,7 +6295,8 @@ type property LVColAlign[ Idx: Integer ]: TTextAlign read GetLVColalign write SetLVColalign; {* |<#listview> Column text aligning. } property LVColImage[ Idx: Integer ]: Integer index LVCF_IMAGE or (24 shl 16) read GetLVColEx write SetLVColEx; - {* |<#listview> Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to set an image for list view column itself from the ImageListSmall. } + {* |<#listview> Only starting from comctrl32.dll of version 4.70 (IE4+). + Allows to set an image for list view column itself from the ImageListSmall. } property LVColOrder[ Idx: Integer ]: Integer index LVCF_ORDER or (28 shl 16) read GetLVColEx write SetLVColEx; {* |<#listview> Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to @@ -6568,7 +6313,8 @@ type property allows also to set actual count of list view items when a list view is virtual. } property LVCurItem: Integer read GetLVCurItem write SetLVCurItem; - {* |<#listview> Returns first selected item index in a list view. See also LVNextSelected, LVNextItem and LVFocusItem functions. } + {* |<#listview> Returns first selected item index in a list view. See also LVNextSelected, + LVNextItem and LVFocusItem functions. } property LVFocusItem: Integer read GetLVFocusItem; {* |<#listview> Returns focused item index in a list view. See also LVCurItem. } function LVNextItem( IdxPrev: Integer; Attrs: DWORD ): Integer; @@ -6835,12 +6581,10 @@ type drawing for the (sub)item during this drawing cycle. CDRF_NEWFONT - informs the system, that font is changed and default drawing should be performed with changed font; - | If you want to get notifications for each subitem, do not use option lvoOwnerDrawFixed, because such style prevents system from notifying the application for each subitem to be drawn in the listview and only notifications will be sent about entire items. - |
See also NM_CUSTOMDRAW in API Help. } property OnLVSubitemDraw: TOnLVSubitemDraw read Get_OnLVSubitemDraw write SetOnLVSubitemDraw; procedure Set_LVItemHeight(Value: Integer); @@ -6852,8 +6596,7 @@ type loOwnerDrawFixed or loOwnerDrawVariable for listbox and coOwnerDrawFixed or coOwnerDrawVariable for combobox. At least, the control should have such option while creating it (after showing it - the first time it is possible to change its options to avoid owner - drawing later). } + the first time it is possible to change its options to avoid owner drawing later). } //======== TreeView specific properties and methods: function TVInsert( nParent, nAfter: THandle; const Txt: KOLString ): THandle; {* |<#treeview> @@ -6884,8 +6627,7 @@ type Returns or sets given item to top of tree view. } property TVIndent: Integer index TVM_GETINDENT read GetIntVal write SetIntVal; {* |<#treeview> - The amount, in pixels, that child items are indented relative to their - parent items. } + The amount, in pixels, that child items are indented relative to their parent items. } property TVVisibleCount: Integer index TVM_GETVISIBLECOUNT read GetIntVal; {* |<#treeview> Returns number of fully (not partially) visible items in tree view. } @@ -8138,169 +7880,6 @@ function DummyOnSBBeforeScrollProc(Dummy: Pointer; Sender: PControl; procedure InvalidateWindowed( Sender: PObj ); procedure InvalidateNonWindowed( Sender: PObj ); {$ENDIF} -function FormNewLabel( Form: PControl ): PControl; -function FormNewWordWrapLabel( Form: PControl ): PControl; -function FormNewLabelEffect( Form: PControl ): PControl; -function FormNewButton( Form: PControl ): PControl; -function FormNewBitBtn( Form: PControl ): PControl; -function FormNewPanel( Form: PControl ): PControl; -function FormNewGradientPanel( Form: PControl ): PControl; -function FormNewGradientPanelEx( Form: PControl ): PControl; -function FormNewGroupbox( Form: PControl ): PControl; -function FormNewPaintbox( Form: PControl ): PControl; -function FormNewImageShow( Form: PControl ): PControl; -function FormNewEditBox( Form: PControl ): PControl; -{$IFDEF USE_RICHEDIT} -function FormNewRichEdit( Form: PControl ): PControl; -{$ENDIF} -function FormNewCombobox( Form: PControl ): PControl; -function FormNewCheckbox( Form: PControl ): PControl; -function FormNewRadiobox( Form: PControl ): PControl; -function FormNewSplitter( Form: PControl ): PControl; -function FormNewListbox( Form: PControl ): PControl; -function FormNewListView( Form: PControl ): PControl; -function FormNewTreeView( Form: PControl ): PControl; -function FormNewScrollbox( Form: PControl ): PControl; -function FormNewScrollboxEx( Form: PControl ): PControl; -function FormNewScrollBar( Form: PControl ): PControl; -function FormNewProgressBar( Form: PControl ): PControl; -function FormNewProgressBarEx( Form: PControl ): PControl; -//function FormNewToolbar( Form: PControl ): PControl; -function FormNewDateTimePicker( Form: PControl ): PControl; -function FormNewTabControl( Form: PControl ): PControl; -procedure FormSetSize( Form: PControl ); -procedure FormSetHeight( Form: PControl ); -procedure FormSetWidth( Form: PControl ); -procedure FormSetPosition( Form: PControl ); -procedure FormSetClientSize( Form: PControl ); -procedure FormSetAlign( Form: PControl ); -procedure FormSetTag( Form: PControl ); -{$IFDEF USE_NAMES} -procedure FormSetName( Form: PControl ); -{$ENDIF USE_NAMES} -{$IFDEF UNICODE_CTRLS} -procedure FormSetUnicode( Form: PControl ); -{$ENDIF UNICODE_CTRLS} -procedure FormAssignHelpContext( Form: PControl ); -procedure FormSetCanResizeFalse( Form: PControl ); -procedure FormInitMenu( Form: PControl ); - -procedure FormSizeGripFalse( Form: PControl ); -procedure FormSetExStyle( Form: PControl ); -procedure FormSetVisibleFalse( Form: PControl ); -procedure FormSetEnabledFalse( Form: PControl ); -procedure FormResetStyles( Form: PControl ); -procedure FormSetStyle( Form: PControl ); -procedure FormSetAlphaBlend( Form: PControl ); -procedure FormSetHasBorderFalse( Form: PControl ); -procedure FormSetHasCaptionFalse( Form: PControl ); -procedure FormResetCtl3D( Form: PControl ); -procedure FormIconLoad_hInstance( Form: PControl ); -procedure FormIconLoadCursor_0( Form: PControl ); -procedure FormSetIconNeg1( Form: PControl ); -procedure FormIconLoad_hInstance_str( Form: PControl ); -procedure FormSetWindowState( Form: PControl ); -procedure FormCursorLoad_0( Form: PControl ); -procedure FormCursorLoad_hInstance( Form: PControl ); -procedure FormSetColor( Form: PControl ); -procedure FormSetBrushStyle( Form: PControl ); -procedure FormSetBrushBitmap( Form: PControl ); -procedure FormSetFontColor( Form: PControl ); -procedure FormSetFontStyles( Form: PControl ); -procedure FormSetFontHeight( Form: PControl ); -procedure FormSetFontWidth( Form: PControl ); -procedure FormSetFontName( Form: PControl ); -procedure FormSetFontOrientation( Form: PControl ); -procedure FormSetFontCharset( Form: PControl ); -procedure FormSetFontPitch( Form: PControl ); -procedure FormSetBorder( Form: PControl ); -procedure FormSetMarginTop( Form: PControl ); -procedure FormSetMarginBottom( Form: PControl ); -procedure FormSetMarginLeft( Form: PControl ); -procedure FormSetMarginRight( Form: PControl ); -procedure FormSetSimpleStatusText( Form: PControl ); -procedure FormSetStatusText( Form: PControl ); -procedure FormRemoveCloseIcon( Form: PControl ); -procedure FormSetEraseBkgndTrue( Form: PControl ); -procedure FormSetMinWidth( Form: PControl ); -procedure FormSetMaxWidth( Form: PControl ); -procedure FormSetMinHeight( Form: PControl ); -procedure FormSetMaxHeight( Form: PControl ); -procedure FormSetKeyPreviewTrue( Form: PControl ); -// BitBtn only: -procedure FormSetRepeatInterval( Form: PControl ); -procedure FormSetTextShiftX( Form: PControl ); -procedure FormSetTextShiftY( Form: PControl ); -// LabelEffect only: -procedure FormSetColor2( Form: PControl ); - -procedure FormSetTextAlign( Form: PControl ); -procedure FormSetTextVAlign( Form: PControl ); -procedure FormSetTabStopFalse( Form: PControl ); -procedure FormSetIgnoreDefault( Form: PControl ); -procedure FormSetHintText( Form: PControl ); -procedure FormSetAnchor( Form: PControl ); -procedure FormSetCaption( Form: PControl ); -procedure FormSetGradienStyle( Form: PControl ); -procedure FormOverrideScrollbars( Form: PControl ); -// RichEdit only: -{$IFDEF USE_RICHEDIT} -procedure FormSetRE_AutoFontFalse( Form: PControl ); -procedure FormSetRE_AutoFontSizeAdjustFalse( Form: PControl ); -procedure FormSetRE_DualFontTrue( Form: PControl ); -procedure FormSetRE_UIFontsTrue( Form: PControl ); -procedure FormSetRE_IMECancelCompleteTrue( Form: PControl ); -procedure FormSetRE_IMEAlwaysSendNotifyTrue( Form: PControl ); -procedure FormSetMaxTextSize( Form: PControl ); -procedure FormSetRE_AutoKeyboardTrue( Form: PControl ); -procedure FormSetRE_DisableOverwriteChangeTrue( Form: PControl ); -procedure FormSetRE_Zoom( Form: PControl ); -{$ENDIF USE_RICHEDIT} -procedure FormSetListItems( Form: PControl ); -procedure FormSetCount( Form: PControl ); -procedure FormSetDroppedWidth( Form: PControl ); -procedure FormSetButtonIcon( Form: PControl ); -procedure FormSetButtonImage( Form: PControl ); -procedure FormSetButtonBitmap( Form: PControl ); -procedure FormSetDefaultBtn( Form: PControl ); -// progress -procedure FormSetMaxProgress( Form: PControl ); -procedure FormSetProgress( Form: PControl ); -// list view -procedure FormLVColumsAdd( Form: PControl ); -procedure FormSetLVColOrder( Form: PControl ); -procedure FormSetLVColImage( Form: PControl ); -// tree view -procedure FormSetTVIndent( Form: PControl ); -// toolbar -procedure FormSetTBBtnImgWidth( Form: PControl ); -procedure FormTBAddBitmap( Form: PControl ); -procedure FormSetTBButtonSize( Form: PControl ); -procedure FormTBSetTooltips( Form: PControl ); -procedure FormSetTBButtonsMinWidth( Form: PControl ); -procedure FormSetTBButtonsMaxWidth( Form: PControl ); -procedure FormHideToolbarButton( Form: PControl ); -procedure FormDisableToolbarButton( Form: PControl ); -procedure FormFixFlatXPToolbar( Form: PControl ); -// datetimepicker -procedure FormSetDateTimeFormat( Form: PControl ); -procedure FormSetDateTimeColor( Form: PControl ); -// tabcontrol -procedure FormSetCurrentTab( Form: PControl ); -procedure FormSetCurIdx( Form: PControl ); -// scrollbar -procedure FormSetSBMin( Form: PControl ); -procedure FormSetSBMax( Form: PControl ); -procedure FormSetSBPosition( Form: PControl ); -procedure FormSetSBPageSize( Form: PControl ); -procedure FormLastCreatedChildAsNewCurrentParent( Form: PControl ); -procedure FormSetUpperParent( Form: PControl ); -procedure FormSetTabpageAsParent( Form: PControl ); - -procedure FormSetCurCtl( Form: PControl ); -procedure FormSetParent( Form: PControl ); -procedure FormSetEvent( Form: PControl ); -procedure FormSetIndexedEvent( Form: PControl ); function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect; {* Use this function instead of reading TControl.TBButtonRect, if you want @@ -8378,10 +7957,7 @@ procedure InitCommonControlCommonNotify( Ctrl: PControl ); procedure DummyAttachProcExtension ( DynHandlers: PList ); procedure TransparentAttachProcExtension ( DynHandlers: PList ); -{$IFNDEF SMALLEST_CODE} var Global_AttachProcExtension: procedure( DynHandlers: PList ) = DummyAttachProcExtension; -{$ENDIF} - var HelpFilePath: PKOLChar; {* Path to application help file. If not assigned, application path with extension replaced to '.hlp' used. To use '.chm' file (HtmlHelp), @@ -8948,10 +8524,10 @@ function StringToOleStr(const Source: Ansistring): PWideChar; {* } { -- Constructors for visual controls -- } -{$IFDEF COMMANDACTIONS_OBJ} + function NewCommandActionsObj: PCommandActionsObj; function NewCommandActionsObj_Packed( fromPack: PAnsiChar ): PCommandActionsObj; -{$ENDIF} + function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar; Ctl3D: Boolean; ACommandActions: TCommandActionsParam): PControl; //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv @@ -9282,12 +8858,10 @@ function NewTabControl( AParent: PControl; const Tabs: array of PKOLChar; Option property) to make the border raised. |
Other methods and properties, suitable for tab control, are: |#tabcontrol } -{$IFNDEF OLD_ALIGN} function NewTabEmpty( AParent: PControl; Options: TTabControlOptions; ImgList: PImageList ): PControl; {* |<#control> Creates new empty tab control for using methods TC_Insert (to create Pages as Panel), or TC_InsertControl (if you want using your custom Pages).} -{$ENDIF} var ToolbarDfltWidth: WORD = 1000; ToolbarDfltHeight: WORD = 26; @@ -9580,13 +9154,6 @@ function ShowMsgCentered( Ctl: PControl; const S: KOLString; Flags: DWORD ): DWO given by Ctl parameter. } procedure ShowMessage( const S: KOLString ); {* Like ShowMsg, but has only styles MB_OK and MB_SETFOREGROUND. } - -{$IFNDEF PAS_ONLY} -procedure SpeakerBeep( Freq: Word; Duration: DWORD ); -{* On Windows NT, calls Windows.Beep. On Windows 9x, produces beep on speaker - of desired frequency during given duration time (in milliseconds). } -{$ENDIF PAS_ONLY} - function SysErrorMessage(ErrorCode: Integer): KOLString; {* Creates and returns a string containing formatted system error message. It is possible then to display this message or write it to a log @@ -9749,10 +9316,6 @@ function Min( X, Y: Integer ): Integer; {* minimum of two integers } function Max( X, Y: Integer ): Integer; {* maximum of two integers } -{$IFDEF REDEFINE_ABS} -function Abs( X: Integer ): Integer; -{* absolute value } -{$ENDIF} function Sgn( X: Integer ): Integer; {* sign of X: if X < 0, -1 is returned, if > 0, then +1, otherwise 0. } function iSqrt( X: Integer ): Integer; @@ -9837,9 +9400,7 @@ function smartOem2ansiRus(const s: AnsiString): AnsiString; {* Smartly converts string from OEM to ANSI (only Russian!). See code. } {$IFNDEF _FPC} -//{$IFNDEF PAS_ONLY} function Format( const fmt: KOLString; params: array of const ): KOLString; -//{$ENDIF} {* Uses API call to wvsprintf, so does not understand extra formats, such as floating point, date/time, currency conversions. See list of available formats in win32.hlp (topic wsprintf). @@ -9851,61 +9412,38 @@ function Format( const fmt: KOLString; params: array of const ): KOLString; function StrComp(const Str1, Str2: PAnsiChar): Integer; {* Compares two strings fast. -1: Str1Str2 } -{$IFDEF PAS_ONLY} -function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; -function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -{$ELSE} -{$IFDEF SMALLER_CODE} function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; {* Compares two strings fast without case sensitivity. Returns: -1 when Str1Str2 } +function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; //SysUtils +{* Compare two strings (fast). Terminating 0 is not considered, so if strings are equal, comparing + is continued up to MaxLen bytes. Since this, pass minimum of lengths as MaxLen. } function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -{* Compare two strings fast without case sensitivity. - Terminating 0 is not considered, so if strings are equal, - comparing is continued up to MaxLen bytes. - Since this, pass minimum of lengths as MaxLen. } -{$ELSE} -function StrComp_NoCase1(const Str1, Str2: PAnsiChar): Integer; -var StrComp_NoCase: function(const Str1, Str2: PAnsiChar): Integer = StrComp_NoCase1; -{* Compares two strings fast without case sensitivity. - Returns: -1 when Str1Str2 } -function StrLComp_NoCase1(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -var StrLComp_NoCase: function(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer = StrLComp_NoCase1; -{$ENDIF} -{$ENDIF} -function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -{* Compare two strings (fast). Terminating 0 is not considered, so if - strings are equal, comparing is continued up to MaxLen bytes. - Since this, pass minimum of lengths as MaxLen. } +{* Compare two strings fast without case sensitivity. Terminating 0 is not considered, so if strings + are equal, comparing is continued up to MaxLen bytes. Since this, pass minimum of lengths as MaxLen. } function StrCopy( Dest, Source: PAnsiChar ): PAnsiChar; {* Copy source string to destination (fast). Pointer to Dest is returned. } function StrCat( Dest, Source: PAnsiChar ): PAnsiChar; {* Append source string to destination (fast). Pointer to Dest is returned. } function StrLen(const Str: PAnsiChar): Cardinal; -{* StrLen returns the number of characters in Str, not counting the null - terminator. } +{* StrLen returns the number of characters in Str, not counting the null terminator. } function StrScanLen(Str: PAnsiChar; Chr: AnsiChar; Len: Integer): PAnsiChar; {* Fast scans string Str of length Len searching character Chr. - Pointer to a character next to found or to Str[Len] (if no one found) - is returned. } + Pointer to a character next to found or to Str[Len] (if no one found) is returned. } function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; -{* Fast search of given character in a string. Pointer to found character - (or nil) is returned. } +{* Fast search of given character in a string. Pointer to found character (or nil) is returned. } function StrRScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; -{* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr - does not occur in Str, StrRScan returns NIL. The null terminator is - considered to be part of the string. } +{* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr does not occur in Str, + StrRScan returns NIL. The null terminator is considered to be part of the string. } function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean; {* Returns True, if string Str is starting from Pattern, i.e. if - Copy( Str, 1, StrLen( Pattern ) ) = Pattern. Str must not be nil! } + Copy( Str, 1, StrLen( Pattern ) ) = Pattern. Str must not be nil! } function StrIsStartingFromNoCase( Str, Pattern: PAnsiChar ): Boolean; {* Like StrIsStartingFrom above, but without case sensitivity. } function TrimLeft(const S: KOLString): KOLString; -{* Removes spaces, tabulations and control characters from the starting - of string S. } +{* Removes spaces, tabulations and control characters from the starting of string S. } function TrimRight(const S: KOLString): KOLString; -{* Removes spaces, tabulates and other control characters from the - end of string S. } +{* Removes spaces, tabulates and other control characters from the end of string S. } function Trim( const S : KOLString): KOLString; {* Makes TrimLeft and TrimRight for given string. } function RemoveSpaces( const S: KOLString ): KOLString; @@ -9953,13 +9491,13 @@ function AnsiCompareStr(const S1, S2: KOLString): Integer; {* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare operation is controlled by the current Windows locale. The return value is the same as for CompareStr. } -function _AnsiCompareStr(S1, S2: PKOLChar): Integer; +function _AnsiCompareStr(const S1, S2: PKOLChar): Integer; {* The same, but for PChar ANSI strings } function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer; {* AnsiCompareStrNoCase compares S1 to S2, without case-sensitivity. The compare operation is controlled by the current Windows locale. The return value is the same as for CompareStr. } -function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer; +function _AnsiCompareStrNoCase(const S1, S2: PKOLChar): Integer; {* The same, but for PChar ANSI strings } function AnsiCompareText( const S1, S2: KOLString ): Integer; {* } @@ -9973,23 +9511,16 @@ function AnsiCompareStrA(const S1, S2: AnsiString): Integer; operation is controlled by the current Windows locale. The return value is the same as for CompareStr. } function _AnsiCompareStrA_Slow(const S1, S2: PAnsiChar): Integer; function _AnsiCompareStrA_Fast(const S1, S2: PAnsiChar): Integer; -var _AnsiCompareStrA: TCompareStrListFun = {$IFDEF SPEED_FASTER} _AnsiCompareStrA_Fast {$ELSE} _AnsiCompareStrA_Slow {$ENDIF}; +function _AnsiCompareStrA(const S1, S2: PAnsiChar): Integer; {* The same, but for PChar ANSI strings } -function _AnsiCompareStrA_Fast2(const S1, S2: PAnsiChar): Integer; -function _AnsiCompareStrNoCaseA_Fast2(const S1, S2: PAnsiChar): Integer; +function _AnsiCompareStrNoCaseA_Fast(const S1, S2: PAnsiChar): Integer; function AnsiCompareStrNoCaseA(const S1, S2: AnsiString): Integer; {* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare operation is controlled by the current Windows locale. The return value is the same as for CompareStr. } -function _AnsiCompareStrNoCaseA_Slow(const S1, S2: PAnsiChar): Integer; -function _AnsiCompareStrNoCaseA_Fast(const S1, S2: PAnsiChar): Integer; -var _AnsiCompareStrNoCaseA: TCompareStrListFun = {$IFDEF SPEED_FASTER} _AnsiCompareStrNoCaseA_Fast{$ELSE}_AnsiCompareStrNoCaseA_Slow {$ENDIF}; +function _AnsiCompareStrNoCaseA(const S1, S2: PAnsiChar): Integer; {* The same, but for PChar ANSI strings } function AnsiCompareTextA( const S1, S2: AnsiString ): Integer; {$IFNDEF _FPC} -function LStrFromPWCharLen(Source: PWideChar; Length: Integer): AnsiString; -{* from Delphi5 - because D2 does not contain it. } -function LStrFromPWChar(Source: PWideChar): AnsiString; -{* from Delphi5 - because D2 does not contain it. } {$ENDIF _FPC} function WCharIn( C: KOLChar; const Chars: array of KOLChar ): Boolean; function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString; @@ -10276,8 +9807,7 @@ function Time2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString; (the second part). If Fmt string is empty, default system time format for short date string used. } function DateTime2StrShort( D: TDateTime ): KOLString; -{* Formats date and time to string in short date format using current user - locale. } +{* Formats date and time to string in short date format using current user locale. } function Str2DateTimeFmt( const sFmtStr, sS: KOLString ): TDateTime; {* Restores date or/and time from string correspondently to a format string. Date and time formatting string can contain following pictures (case @@ -11213,8 +10743,7 @@ type String list does not cleared before processing. Section names are added to the end of the string list. } procedure SectionData(Names:PKOLStrList); - {* Read/write current section content to/from string list. (Depending on - current Mode value). } + {* Read/write current section content to/from string list. (Depending on current Mode value). } {$IFNDEF UNICODE_CTRLS}function GetSectionNamesStr: KOLString;{$ENDIF} //dufa {* like GetSectionNames, but return string } end; @@ -11345,8 +10874,8 @@ type procedure SetItemChecked( Item : PtrInt; Value : Boolean ); function GetItemBitmap(Idx: PtrInt): HBitmap; procedure SetItemBitmap(Idx: PtrInt; const Value: HBitmap); - function GetItemText(Idx: PtrInt): KOLString; - procedure SetItemText(Idx: PtrInt; const Value: KOLString); + function GetItemText(Idx: PtrInt): KOLString; + procedure SetItemText(Idx: PtrInt; const Value: KOLString); function GetItemEnabled(Idx: PtrInt): Boolean; procedure SetItemEnabled(Idx: PtrInt; const Value: Boolean); function GetItemVisible(Idx: PtrInt): Boolean; @@ -11550,7 +11079,7 @@ type only - for checked menu items default checkmark bitmap is used). } procedure AssignBitmaps( StartIdx: PtrInt; Bitmaps: array of HBitmap ); {* Can be used to assign bitmaps to several menu items during one call. } - property ItemText[ Idx: PtrInt ]: KOLString read GetItemText write SetItemText; + property ItemText[ Idx: PtrInt ]: KOLString read GetItemText write SetItemText; {* This property allows to get / modify menu item text at run time. } property ItemEnabled[ Idx: PtrInt ]: Boolean read GetItemEnabled write SetItemEnabled; {* Controls enabling / disabling menu items. Disabled menu items are @@ -11575,12 +11104,12 @@ type property ItemSubmenu[ Idx: PtrInt ]: HMenu read GetItemSubmenu; // write SetItemSubmenu; {* Retrieves submenu item dynamically. See also SubMenu property. } // by Sergey Shisminzev: - function AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer; + function AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer; {* Adds menu item dynamically. Returns ID of the added item. } - function InsertItem(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer; + function InsertItem(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer; {* Inserts menu item before an item with ID, given by InsertBefore parameter. } - function InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions; - ByPosition: Boolean): Integer; + function InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; + Options: TMenuOptions; ByPosition: Boolean): Integer; {* Inserts menu item by command or by position, dependent on ByPosition parameter } procedure RedrawFormMenuBar; {* } @@ -11589,7 +11118,6 @@ type {* By Alexander Pravdin. This property is assigned to a control which were initiated a pop-up, for popup menu. } {$ENDIF USE_MENU_CURCTL} - end; @@ -11782,10 +11310,6 @@ function ParamCount: Integer; {$ENDIF} {$ENDIF} -//{$DEFINE CHK_BITBLT} -{$IFDEF CHK_BITBLT} -procedure Chk_BitBlt; -{$ENDIF} {$IFDEF ASM_VERSION} {$DEFINE ASM_DC} {$ENDIF} @@ -11814,7 +11338,6 @@ procedure ClearCombobox( Sender: PControl ); procedure ClearListView( Sender: PControl ); procedure ClearTreeView( TV: PControl ); -{$IFDEF COMMANDACTIONS_OBJ} const OTHER_ACTIONS = 0; LABEL_ACTIONS = 1; BUTTON_ACTIONS = 2; @@ -11829,7 +11352,7 @@ const OTHER_ACTIONS = 0; TOOLBAR_ACTIONS = 11; LAST_ACTIONS = 11; var AllActions_Objs: array[ 0..LAST_ACTIONS ] of PCommandActionsObj; -{$ENDIF} + const {$IFDEF PACK_COMMANDACTIONS} ButtonActions_Packed: PAnsiChar = AnsiChar(BUTTON_ACTIONS) + @@ -12616,7 +12139,27 @@ function WndProcCMExec( Sender: PControl; var Msg: TMsg; var Rslt: LRESULT ): Bo {$I MCKfakeClasses200x.inc} // Dufa {$ENDIF} +//dufa: moved or added here +procedure Init_Upper; +function CompareStrListItems(const Sender: Pointer; const e1, e2: DWORD): Integer; +function CompareStrListNames(const Sender: Pointer; const e1, e2: DWORD): Integer; + +type + PSortAnsiRec = ^TSortAnsiRec; + TSortAnsiRec = record + A: array[AnsiChar] of PAnsiChar; + end; + +var + IsUpperInit: Boolean = False; + IsAnsiInit: Boolean = False; + IsAnsiNoCaseInit: Boolean = False; + Upper: array[AnsiChar] of AnsiChar; + SortAnsiOrder: array[AnsiChar] of SmallInt; + SortAnsiOrderNoCase: array[AnsiChar] of SmallInt; + implementation + {$UNDEF CALL_INHERITED} {$IFnDEF NIL_EVENTS} {$DEFINE CALL_INHERITED} {$ENDIF} @@ -12733,49 +12276,6 @@ const CC_SOLIDCOLOR = $00000080; CC_ANYCOLOR = $00000100; - -{$IFDEF CHK_BITBLT} -procedure Chk_BitBlt_ShowError; -var Rslt: Integer; -begin - Rslt := GetLastError; - ShowMessage( 'BitBlt ERROR: ' + Int2Str( Rslt ) - + ' ' + SysErrorMessage( Rslt ) ); -end; - -procedure Chk_BitBlt; -var Rslt: Integer; -begin - asm - MOV Rslt, EAX - end; - if Rslt = 0 then begin - Chk_BitBlt_ShowError; - asm - int 3; - end; - end; -end; -{$ENDIF CHK_BITBLT} - -{$IFDEF _D2009orHigher} -{$IFNDEF PAS_ONLY} -procedure _aLStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); -asm - push 0 - CALL System.@LStrFromPCharLen -end; - -procedure _aLStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); -asm - push ecx - xor ecx, ecx - CALL System.@LStrFromPChar - pop ecx -end; -{$ENDIF} -{$ENDIF} - type TInitCommonControlsEx = record dwSize: DWORD; @@ -12794,10 +12294,7 @@ begin if ComCtl32_Module = 0 then ComCtl32_Module := LoadLibrary( 'comctl32' ); @ Proc := GetProcAddress( ComCtl32_Module, 'InitCommonControlsEx' ); - {$IFDEF SAFE_CODE} // DoInitCommonControls should work usually. If not, the System is - if Assigned( Proc ) then // not in normal state, and should be repaired anyway. - {$ENDIF} - begin + if Assigned( Proc ) then begin // not in normal state, and should be repaired anyway. ICC.dwSize := Sizeof( ICC ); ICC.dwICC := dwICC; Proc( @ ICC ); @@ -12879,10 +12376,6 @@ function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Bool function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: LRESULT ) : Boolean; forward; function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: LRESULT ) : Boolean; forward; function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; forward; -function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward; -function CompareAnsiStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward; -function CompareStrListItems_NoCase( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward; -function CompareStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward; procedure ApplyImageLists2Control( Sender: PControl ); forward; procedure ApplyImageLists2ListView( Sender: PControl ); forward; function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer; @@ -12932,158 +12425,164 @@ var MapFile: PKOLStrList; BelowBasePtr: PDWORD; CrackedStack: KOLString; -function DoCrackSingleFrame( RetAddr: DWORD; BasePtr: DWORD ): Boolean; +function DoCrackSingleFrame(RetAddr: DWORD; BasePtr: DWORD): Boolean; var i, j, R: Integer; A, Prev_A, N, Prev_N: DWORD; s, CurUnit: KOLString; Add_string: KOLString; Line_found: Boolean; begin - Result := FALSE; - if Length( CrackedStack ) > MaxCrackStackLen then Exit; {>>>>>>>>>>>>>>>>>>} + Result := FALSE; + if (Length(CrackedStack) > MaxCrackStackLen) then + Exit; {>>>>>>>>>>>>>>>>>>} + + if (RetAddr >= $70000000) then begin + CrackedStack := CrackedStack + #13#10'$' + Int2Hex( RetAddr, 8 ); Result := TRUE; - if RetAddr >= $70000000 then begin - CrackedStack := CrackedStack + #13#10'$' + Int2Hex( RetAddr, 8 ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := FALSE; - if RetAddr < $400000 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if HandleSuspicious then - if (BelowBasePtr <> nil) and (BasePtr <> 0) - and (PtrUInt( BelowBasePtr ) < BasePtr) then begin - BelowBasePtr := Pointer( PtrUInt( BelowBasePtr ) + SizeOf(Pointer) ); - while PtrUInt( BelowBasePtr ) < BasePtr do begin - A := BelowBasePtr^; - if (A > $400000) and (A < $700000) then - DoCrackSingleFrame( A, 0 ); - BelowBasePtr := Pointer( PtrUInt( BelowBasePtr ) + SizeOf(Pointer) ); - end; - end; - if BasePtr <> 0 then - BelowBasePtr := Pointer( BasePtr ); + Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + end; - Add_string := ''; + if (RetAddr < $400000) then + Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // 1st: find - Prev_A := 0; - for i := 0 to MapFile.Count-1 do begin - s := MapFile.Items[ i ]; - if s = '' then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - R := 0; - j := 1; - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - while (j <= Length( s )) and - ( (s[j] >= '0') and (s[j] <= '9') or - (s[j] >= 'A') and (s[j] <= 'F') ) do begin - if s[j] <= '9' then R := R * 16 + Ord( s[j] ) - Ord( '0' ) - else R := R * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; - inc( j ); - end; - if (j > Length( s )) or (s[ j ] <> ':') then Exit; {>>>>>>>>>>>>>>>>>>>} - inc( j ); - A := 0; - while (j <= Length( s )) and - ( (s[j] >= '0') and (s[j] <= '9') or - (s[j] >= 'A') and (s[j] <= 'F') ) do begin - if s[j] <= '9' then A := A * 16 + Ord( s[j] ) - Ord( '0' ) - else A := A * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; - inc( j ); - end; - A := A + $401000; - if (Prev_A <= RetAddr) and (A > RetAddr) and (Prev_A > 0) and (R = 1) then begin - s := MapFile.Items[ i-1 ]; - j := pos( AnsiString(':'), s ); - if j <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - s := Copy( s, j+1, MaxInt ); - for j := 1 to Length( s ) do - if s[ j ] <= ' ' then begin - s := Trim( Copy( s, j, MaxInt ) ); - Add_string := #13#10; - if BasePtr = 0 then - Add_string := Add_string + '? ' + Int2Hex( RetAddr, 8 ) + ':'; - Add_string := Add_string + s; - Result := TRUE; - break; - end; - end; - Prev_A := A; - if Result then break; - end; - if not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // 2nd: find line no - Line_found := FALSE; - CurUnit := ''; - Prev_N := 0; - Prev_A := 0; - for i := LineNumbersFrom to MapFile.Count-1 do begin - s := MapFile.Items[ i ]; - if Copy( s, 1, 4 ) = 'Line' then begin - j := pos( AnsiString('('), s ); - if j > 0 then begin - s := Copy( s, j+1, MaxInt ); - j := pos( AnsiString(')'), s ); - if j > 0 then - s := Copy( s, 1, j-1 ); - end; - CurUnit := s; - Prev_N := 0; - end else - if s <> '' then begin - j := 1; - while j < Length( s ) do begin - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - N := 0; - while (j <= Length( s )) and - (s[j] >= '0') and (s[j] <= '9') do begin - N := N * 10 + Ord( s[j] ) - Ord( '0' ); - inc( j ); - end; - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - R := 0; - while (j < Length( s )) and - ( (s[j] >= '0') and (s[j] <= '9') or - (s[j] >= 'A') and (s[j] <= 'F') ) do begin - if s[j] <= '9' then - R := R * 16 + Ord( s[j] ) - Ord( '0' ) - else R := R * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; - inc( j ); - end; - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - if (j <= Length(s)) and (s[ j ] = ':') then inc( j ); - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - A := 0; - while (j <= Length( s )) and - ( (s[j] >= '0') and (s[j] <= '9') or - (s[j] >= 'A') and (s[j] <= 'F') ) do begin - if s[j] <= '9' then - A := A * 16 + Ord( s[j] ) - Ord( '0' ) - else A := A * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; - inc( j ); - end; - A := A + $401000; - if (Prev_A <= RetAddr) and (A > RetAddr) then begin - if (Prev_A > 0) and (Prev_N > 0) then begin - Add_string := Add_string + ' in ' + CurUnit + ', line: ' + - Int2Str( Prev_N ); - Line_found := TRUE; - end; - s := ''; - break; - end; - Prev_N := N; - Prev_A := A; - if Line_found then break; - end; - end; - if Line_found then break; - end; - if not Line_found and (BasePtr = 0) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>} - CrackedStack := CrackedStack + Add_string; - if Length( CrackedStack ) > MaxCrackStackLen then begin - CrackedStack := Copy( CrackedStack, 1, MaxCrackStackLen ); - Result := FALSE; // stop cracking + if HandleSuspicious then begin + if (BelowBasePtr <> nil) and (BasePtr <> 0) + and (PtrUInt( BelowBasePtr ) < BasePtr) then begin + BelowBasePtr := Pointer( PtrUInt( BelowBasePtr ) + SizeOf(Pointer) ); + while PtrUInt( BelowBasePtr ) < BasePtr do begin + A := BelowBasePtr^; + if (A > $400000) and (A < $700000) then + DoCrackSingleFrame( A, 0 ); + BelowBasePtr := Pointer( PtrUInt( BelowBasePtr ) + SizeOf(Pointer) ); + end; end; + end; + + if (BasePtr <> 0) then + BelowBasePtr := Pointer(BasePtr); + + Add_string := ''; + + // 1st: find + Prev_A := 0; + for i := 0 to MapFile.Count-1 do begin + s := MapFile.Items[ i ]; + if s = '' then + Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + R := 0; + j := 1; + while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); + while (j <= Length( s )) and + ( (s[j] >= '0') and (s[j] <= '9') or + (s[j] >= 'A') and (s[j] <= 'F') ) do begin + if s[j] <= '9' then R := R * 16 + Ord( s[j] ) - Ord( '0' ) + else R := R * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; + inc( j ); + end; + if (j > Length( s )) or (s[ j ] <> ':') then Exit; {>>>>>>>>>>>>>>>>>>>} + inc( j ); + A := 0; + while (j <= Length( s )) and + ( (s[j] >= '0') and (s[j] <= '9') or + (s[j] >= 'A') and (s[j] <= 'F') ) do begin + if s[j] <= '9' then A := A * 16 + Ord( s[j] ) - Ord( '0' ) + else A := A * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; + inc( j ); + end; + A := A + $401000; + if (Prev_A <= RetAddr) and (A > RetAddr) and (Prev_A > 0) and (R = 1) then begin + s := MapFile.Items[ i-1 ]; + j := pos( AnsiString(':'), s ); + if j <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + s := Copy( s, j+1, MaxInt ); + for j := 1 to Length( s ) do + if s[ j ] <= ' ' then begin + s := Trim( Copy( s, j, MaxInt ) ); + Add_string := #13#10; + if BasePtr = 0 then + Add_string := Add_string + '? ' + Int2Hex( RetAddr, 8 ) + ':'; + Add_string := Add_string + s; + Result := TRUE; + break; + end; + end; + Prev_A := A; + if Result then break; + end; + if not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + // 2nd: find line no + Line_found := FALSE; + CurUnit := ''; + Prev_N := 0; + Prev_A := 0; + for i := LineNumbersFrom to MapFile.Count-1 do begin + s := MapFile.Items[ i ]; + if Copy( s, 1, 4 ) = 'Line' then begin + j := pos( AnsiString('('), s ); + if j > 0 then begin + s := Copy( s, j+1, MaxInt ); + j := pos( AnsiString(')'), s ); + if j > 0 then + s := Copy( s, 1, j-1 ); + end; + CurUnit := s; + Prev_N := 0; + end else + if s <> '' then begin + j := 1; + while j < Length( s ) do begin + while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); + N := 0; + while (j <= Length( s )) and + (s[j] >= '0') and (s[j] <= '9') do begin + N := N * 10 + Ord( s[j] ) - Ord( '0' ); + inc( j ); + end; + while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); + R := 0; + while (j < Length( s )) and + ( (s[j] >= '0') and (s[j] <= '9') or + (s[j] >= 'A') and (s[j] <= 'F') ) do begin + if s[j] <= '9' then + R := R * 16 + Ord( s[j] ) - Ord( '0' ) + else R := R * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; + inc( j ); + end; + while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); + if (j <= Length(s)) and (s[ j ] = ':') then inc( j ); + while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); + A := 0; + while (j <= Length( s )) and + ( (s[j] >= '0') and (s[j] <= '9') or + (s[j] >= 'A') and (s[j] <= 'F') ) do begin + if s[j] <= '9' then + A := A * 16 + Ord( s[j] ) - Ord( '0' ) + else A := A * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; + inc( j ); + end; + A := A + $401000; + if (Prev_A <= RetAddr) and (A > RetAddr) then begin + if (Prev_A > 0) and (Prev_N > 0) then begin + Add_string := Add_string + ' in ' + CurUnit + ', line: ' + + Int2Str( Prev_N ); + Line_found := TRUE; + end; + s := ''; + break; + end; + Prev_N := N; + Prev_A := A; + if Line_found then break; + end; + end; + if Line_found then break; + end; + if not Line_found and (BasePtr = 0) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>} + CrackedStack := CrackedStack + Add_string; + if Length( CrackedStack ) > MaxCrackStackLen then begin + CrackedStack := Copy( CrackedStack, 1, MaxCrackStackLen ); + Result := FALSE; // stop cracking + end; end; procedure DoCrackStack; @@ -13100,83 +12599,86 @@ asm jnz @@loop end; -function CrackStack( Max_length: Integer; HandleSuspiciousAddresses: Boolean ): KOLString; +function CrackStack(Max_length: Integer; HandleSuspiciousAddresses: Boolean): KOLString; begin - TRY - MaxCrackStackLen := Max_length; - HandleSuspicious := HandleSuspiciousAddresses; - CrackedStack := ''; - DoCrackStack; - EXCEPT - END; - Result := CrackedStack; + TRY + MaxCrackStackLen := Max_length; + HandleSuspicious := HandleSuspiciousAddresses; + CrackedStack := ''; + DoCrackStack; + EXCEPT + END; + Result := CrackedStack; end; procedure PrepareMapFile; var i, j: Integer; s: KOLString; begin - for i := 0 to MapFile.Count-1 do begin - s := MapFile.Items[ i ]; - if pos( AnsiString('Publics by Value'), s ) > 0 then begin - j := i; - if Trim( MapFile.Items[ j+1 ] ) = '' then - inc( j ); - for j := j downto 0 do - MapFile.Delete( j ); - for j := 0 to MapFile.Count-1 do begin - s := Trim( MapFile.Items[ j ] ); - if (s = '') and (LineNumbersFrom = 0) then begin - LineNumbersFrom := j; - end; - if s = 'Bound resource files' then begin - while MapFile.Count > j do - MapFile.Delete( j ); - break; - end; - end; - break; + for i := 0 to MapFile.Count-1 do begin + s := MapFile.Items[i]; + if (Pos(AnsiString('Publics by Value'), s ) > 0) then begin + j := i; + if (Trim(MapFile.Items[j + 1]) = '') then + inc(j); + for j := j downto 0 do + MapFile.Delete(j); + for j := 0 to MapFile.Count - 1 do begin + s := Trim(MapFile.Items[j]); + if (s = '') and (LineNumbersFrom = 0) then begin + LineNumbersFrom := j; end; + if (s = 'Bound resource files') then begin + while MapFile.Count > j do + MapFile.Delete(j); + break; + end; + end; + break; end; + end; + MapFile.SaveToFile('prepared.map'); end; -function CrackStack_MapInResource( const MapName: KOLString; Max_length: Integer; - HandleSuspiciousAddresses: Boolean ): KOLString; +function CrackStack_MapInResource(const MapName: KOLString; Max_length: Integer; + HandleSuspiciousAddresses: Boolean): KOLString; var MapStrm: PStream; begin - Result := ''; - if MapFile = nil then begin - MapStrm := NewMemoryStream; - TRY - Resource2Stream( MapStrm, hInstance, PKOLChar( MapName ), PKOLChar(RT_RCDATA) ); - if MapStrm.Size = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - MapFile := NewKOLStrList; - MapStrm.Position := 0; - MapFile.LoadFromStream( MapStrm, FALSE ); - PrepareMapFile; - FINALLY - MapStrm.Free; - END; - end; - if MapFile = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := CrackStack( Max_length, HandleSuspiciousAddresses ); + Result := ''; + if MapFile = nil then begin + MapStrm := NewMemoryStream; + TRY + Resource2Stream( MapStrm, hInstance, PKOLChar( MapName ), PKOLChar(RT_RCDATA) ); + if MapStrm.Size = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + MapFile := NewKOLStrList; + MapStrm.Position := 0; + MapFile.LoadFromStream( MapStrm, FALSE ); + PrepareMapFile; + FINALLY + MapStrm.Free; + END; + end; + if MapFile = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + Result := CrackStack( Max_length, HandleSuspiciousAddresses ); end; -function CrackStack_MapInFile( const MapFileName: KOLString; Max_length: Integer; - HandleSuspiciousAddresses: Boolean ): KOLString; +function CrackStack_MapInFile(const MapFileName: KOLString; Max_length: Integer; + HandleSuspiciousAddresses: Boolean): KOLString; begin - Result := ''; - if MapFile = nil then begin - MapFile := NewKOLStrList; - MapFile.LoadFromFile( MapFileName ); - if MapFile.Count = 0 then - Free_And_Nil( MapFile ) - else PrepareMapFile; - end; - if MapFile = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := CrackStack( Max_length, HandleSuspiciousAddresses ); + Result := ''; + if (MapFile = nil) then begin + MapFile := NewKOLStrList; + MapFile.LoadFromFile(MapFileName); + if (MapFile.Count = 0) then + Free_And_Nil(MapFile) + else + PrepareMapFile; + end; + if (MapFile = nil) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + Result := CrackStack(Max_length, HandleSuspiciousAddresses); end; {$ENDIF _no_PAS_ONLY} + {$IFDEF GRAPHCTL_XPSTYLES} {$I visual_xp_styles.inc} {$ENDIF} @@ -13228,27 +12730,20 @@ end; function MsgBox( const S: KOLString; Flags: DWORD ): DWORD; var Title: PKOLChar; begin - {$IFnDEF NO_SAFE_CODE} // MsgBox should be called when Applet already created Title := nil; // (and yet not destroyed) if assigned( Applet ) then - {$ENDIF} begin Title := PKOLChar( Applet.fCaption ); end; {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFDEF SAFE_CODE} - if Assigned( Applet ) then - {$ENDIF} - begin + if Assigned( Applet ) then begin Applet.AttachProc( WndProcSnapMouse2DfltBtn ); Applet.Postmsg( 0, 0, 0 ); end; {$ENDIF} Result := MessageBox( 0, PKOLChar( S ), Title, Flags ); {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFnDEF NO_SAFE_CODE} if Assigned( Applet ) then - {$ENDIF} Applet.DetachProc( WndProcSnapMouse2DfltBtn ); {$ENDIF} end; @@ -13265,16 +12760,13 @@ var Title: PKOLChar; Wnd: HWnd; begin {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFDEF SAFE_CODE} if Assigned( Applet ) then - {$ENDIF} Applet.AttachProc( WndProcSnapMouse2DfltBtn ); {$ENDIF} - {$IFDEF SAFE_CODE} + Title := nil; Wnd := 0; if assigned( Applet ) then - {$ENDIF} begin Title := PKOLChar( Applet.fCaption ); //{$IFNDEF SNAPMOUSE2DFLTBTN} @@ -13283,9 +12775,7 @@ begin end; Result := MessageBox( Wnd, PKOLChar( S ), Title, Flags ); {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFDEF SAFE_CODE} if Assigned( Applet ) then - {$ENDIF} Applet.DetachProc( WndProcSnapMouse2DfltBtn ); {$ENDIF} end; @@ -13330,42 +12820,6 @@ begin ShowMsg( S, MB_OK or MB_SETFOREGROUND or MB_DEFBUTTON1 ); end; -{$IFDEF PAS_ONLY} -procedure SpeakerBeep( Freq: Word; Duration: DWORD ); -begin - Windows.Beep( Freq, Duration ); -end; -{$ELSE} -procedure SpeakerBeep( Freq: Word; Duration: DWORD ); -begin - if WinVer >= wvNT then - Windows.Beep( Freq, Duration ) - else begin - if Freq < 18 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Freq := 1193181 div Freq; - if Freq = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - asm - mov al,0b6H - out 43H,al - mov ax,Freq - //xchg al, ah - out 42h,al - xchg al, ah - out 42h,al - in al,61H - or al,03H - out 61H,al - end; - Sleep(Duration); - asm - in al,61H - and al,0fcH - out 61H,al - end; - end; -end; -{$ENDIF} - function SysErrorMessage(ErrorCode: Integer): KOLString; var Len: Integer; @@ -13537,28 +12991,14 @@ end; {$IFNDEF PAS_ONLY} function Min( X, Y: Integer ): Integer; asm - {$IFDEF USE_CMOV} CMP EAX, EDX CMOVG EAX, EDX - {$ELSE} - CMP EAX, EDX - JLE @@exit - MOV EAX, EDX -@@exit: - {$ENDIF} end; function Max( X, Y: Integer ): Integer; asm - {$IFDEF USE_CMOV} CMP EAX, EDX CMOVL EAX, EDX - {$ELSE} - CMP EAX, EDX - JGE @@exit - MOV EAX, EDX -@@exit: - {$ENDIF} end; {$ELSE} function Min( X, Y: Integer ): Integer; @@ -13576,29 +13016,13 @@ end; {$ENDIF} {$IFNDEF PAS_ONLY} -{$IFDEF REDEFINE_ABS} -function Abs( X: Integer ): Integer; -asm - cdq - xor eax, edx - sub eax, edx -end; -{$ENDIF} function Sgn( X: Integer ): Integer; asm CMP EAX, 0 - {$IFDEF USE_CMOV} MOV EDX, -1 CMOVL EAX, EDX MOV EDX, 1 CMOVG EAX, EDX - {$ELSE} - JZ @@exit - MOV EAX, 1 - JG @@exit - MOV EAX, -1 -@@exit: - {$ENDIF} end; {$ELSE} function Sgn( X: Integer ): Integer; @@ -13899,44 +13323,52 @@ begin Init; end; -{$IFDEF OLD_REFCOUNT} -procedure TObj.DoDestroy; -begin - {$IFDEF OLD_REFCOUNT} - if fRefCount > 0 then begin - if not LongBool( fRefCount and 1) then - Dec( fRefCount, 2 ); - RefDec; - end else - Self.Destroy; - if fRefCount <> 0 then begin - if not LongBool( fRefCount and 1) then - Dec( fRefCount ); - end else - Self.Destroy; - {$ELSE} - if fRefCount > 0 then - RefDec - else Self.Destroy; - {$ENDIF} -end; -{$ENDIF OLD_REFCOUNT} - function TObj.RefDec: Integer; begin Result := 0; // stop Delphi alerting the Warning if @ Self = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} Dec( fRefCount, 2 ); - {$IFDEF OLD_REFCOUNT} - if (fRefCount < 0) and LongBool(fRefCount and 1) then - Destroy; - {$ELSE} if fRefCount < 0 then Destroy; - {$ENDIF} end; + +procedure TObj.Add2AutoFree(Obj: PObj); +begin + if fAutoFree = nil then + fAutoFree := NewList; + fAutoFree.Insert( 0, Obj ); + fAutoFree.Insert( 0, Pointer( @TObj.RefDec ) ); +end; + +procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod ); +begin + if fAutoFree = nil then + fAutoFree := NewList; + + fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Data ) ); + fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Code ) ); +end; + +procedure TObj.RemoveFromAutoFree(Obj: PObj); +var i: Integer; +begin + if fAutoFree <> nil then begin + i := fAutoFree.IndexOf( Obj ); + if i >= 0 then begin + fAutoFree.DeleteRange( i and not 1, 2 ); + if fAutoFree.Count = 0 then + Free_And_Nil( fAutoFree ); + end; + end; +end; + {$ENDIF PAS_VERSION} +procedure TObj.Free; +begin + RefDec; +end; + procedure TObj.RefInc; begin Inc(fRefCount, 2); @@ -13962,15 +13394,6 @@ asm {$ENDIF} end; -{$IFDEF OLD_FREE} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure TObj.Free; -begin - RefDec; -end; -{$ENDIF PAS_VERSION} -{$ENDIF OLD_FREE} - {$UNDEF ASM_LOCAL} {$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF} {$IFDEF CRASH_DEBUG} {$UNDEF ASM_LOCAL} {$ENDIF} @@ -14069,38 +13492,16 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TObj.Add2AutoFree(Obj: PObj); +procedure FreeString(var S: String); // dufa: free string like Free_And_Nil for obj begin - if fAutoFree = nil then - fAutoFree := NewList; - fAutoFree.Insert( 0, Obj ); - fAutoFree.Insert( 0, Pointer( @TObj.RefDec ) ); + S := ''; end; -procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod ); +procedure TObj.Add2AutoFreeStr(var S: String); // dufa: AutoFree for string begin - if fAutoFree = nil then - fAutoFree := NewList; - - fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Data ) ); - fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Code ) ); + Add2AutoFreeEx(TObjectMethod(MakeMethod(@S, @FreeString))); end; -procedure TObj.RemoveFromAutoFree(Obj: PObj); -var i: Integer; -begin - if fAutoFree <> nil then begin - i := fAutoFree.IndexOf( Obj ); - if i >= 0 then begin - fAutoFree.DeleteRange( i and not 1, 2 ); - if fAutoFree.Count = 0 then - Free_And_Nil( fAutoFree ); - end; - end; -end; -{$ENDIF PAS_VERSION} - procedure TObj.RemoveFromAutoFreeEx(Proc: TObjectMethod); var i: Integer; begin @@ -14224,9 +13625,126 @@ end; {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal destructor TList.Destroy; begin - Clear; - inherited; + Clear; + inherited; end; + +procedure TList.SetCapacity( Value: Integer ); +begin + {$IFDEF TLIST_FAST} + if fUseBlocks and (fBlockList <> nil) then begin + if Value > 256 then // Capacity в обычном смысле работает только для первого + Value := 256; // блока - до 256 элементов, далее оно смысла не имеет, + fCapacity := Value; // т.к. все прочие блоки всегда содержат по 256 позиций + // для элементов, независимо от процента использования. + end else + {$ENDIF} + begin + if Value < Count then + Value := Count; + if Value = fCapacity then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + ReallocMem( fItems, Value * Sizeof( Pointer ) ); + fCapacity := Value; + end; +end; + +procedure TList.Clear; +{$IFDEF TLIST_FAST} +var i: Integer; +{$ENDIF} +begin + if fItems <> nil then + FreeMem( fItems ); + fItems := nil; + fCount := 0; + fCapacity := 0; + {$IFDEF TLIST_FAST} + if fBlockList <> nil then begin + for i := 0 to fBlockList.Count div 2 - 1 do + FreeMem( fBlockList.Items[ i*2 ] ); + Free_And_Nil( fBlockList ); + end; + fLastKnownBlockIdx := 0; + fLastKnownCountBefore := 0; + {$ENDIF} +end; + +procedure TList.Put( Idx: Integer; Value: Pointer ); +{$IFDEF TLIST_FAST} +var i: Integer; + BlockStart: Pointer; + CountBefore, CountCurrent: Integer; +{$ENDIF} +begin + if (Idx < 0) or (Idx >= Count) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + {$IFDEF TLIST_FAST} + if fUseBlocks and ( fBlockList <> nil ) then begin + CountBefore := 0; + i := 0; + if (fLastKnownBlockIdx > 0) and + (Idx >= fLastKnownCountBefore) then begin + i := fLastKnownBlockIdx; + CountBefore := fLastKnownCountBefore; + end; + while i < fBlockList.fCount div 2 do begin + BlockStart := fBlockList.fItems[ i * 2 ]; + CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] ); + if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then begin + fLastKnownBlockIdx := i; + fLastKnownCountBefore := CountBefore; + PPtrUInt( PAnsiChar( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ := + PtrUInt( Value ); + Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + end; + inc( CountBefore, CountCurrent ); + inc( i ); + end; + end else + {$ENDIF} + fItems[ Idx ] := Value; +end; + +function TList.Get( Idx: Integer ): Pointer; +{$IFDEF TLIST_FAST} +var i: Integer; + BlockStart: Pointer; + CountBefore, CountCurrent: Integer; +{$ENDIF} +begin + Result := nil; + if (Idx < 0) or (Idx >= fCount) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + {$IFDEF TLIST_FAST} + if fUseBlocks and Assigned(fBlockList) then begin + if fNotOptimized then begin + CountBefore := 0; + i := 0; + if (fLastKnownBlockIdx > 0) and (Idx >= fLastKnownCountBefore) then begin + i := fLastKnownBlockIdx; + CountBefore := fLastKnownCountBefore; + end; + while {i < fBlockList.fCount div 2} TRUE do begin + BlockStart := fBlockList.fItems[ i * 2 ]; + CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] ); + if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then begin + fLastKnownBlockIdx := i; + fLastKnownCountBefore := CountBefore; + Result := Pointer( PPtrUint( PAnsiChar( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ ); + Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + end; + Inc( CountBefore, CountCurrent ); + Inc( i ); + end; + end else begin // optimized! + i := Idx shr 8; + BlockStart := fBlockList.fItems[ i * 2 ]; + i := Idx and 255; + Result := Pointer( PPtrUInt( PAnsiChar( BlockStart ) + i * Sizeof( Pointer ) )^ ); + end; + end else + {$ENDIF} + Result := fItems[ Idx ]; +end; + {$ENDIF PAS_VERSION} {$IFDEF ASM_TLIST} @@ -14275,56 +13793,26 @@ begin Clear; end; -procedure TList.ReleaseObjects; +procedure TList.ReleaseObjectsOnly; var I: Integer; begin - if @ Self = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - for I := fCount-1 downto 0 do - PObj( {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} [ I ] ).Free; - Free; -end; + if Assigned(@Self) then begin + for I := Pred(fCount) downto 0 do begin + if {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ] <> nil then + PObj( {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} [ I ] ).Free; + end; -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TList.SetCapacity( Value: Integer ); -begin - {$IFDEF TLIST_FAST} - if fUseBlocks and (fBlockList <> nil) then begin - if Value > 256 then // Capacity в обычном смысле работает только для первого - Value := 256; // блока - до 256 элементов, далее оно смысла не имеет, - fCapacity := Value; // т.к. все прочие блоки всегда содержат по 256 позиций - // для элементов, независимо от процента использования. - end else - {$ENDIF} - begin - if Value < Count then - Value := Count; - if Value = fCapacity then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ReallocMem( fItems, Value * Sizeof( Pointer ) ); - fCapacity := Value; + Clear; end; end; -procedure TList.Clear; -{$IFDEF TLIST_FAST} -var i: Integer; -{$ENDIF} +procedure TList.ReleaseObjects; begin - if fItems <> nil then - FreeMem( fItems ); - fItems := nil; - fCount := 0; - fCapacity := 0; - {$IFDEF TLIST_FAST} - if fBlockList <> nil then begin - for i := 0 to fBlockList.Count div 2 - 1 do - FreeMem( fBlockList.Items[ i*2 ] ); - Free_And_Nil( fBlockList ); - end; - fLastKnownBlockIdx := 0; - fLastKnownCountBefore := 0; - {$ENDIF} + if Assigned(@Self) then begin + ReleaseObjectsOnly; + Free; + end; end; -{$ENDIF PAS_VERSION} procedure TList.SetAddBy(Value: Integer); begin @@ -14389,9 +13877,9 @@ begin Add( AItems[ i ] ); end; -procedure TList.Delete( Idx: Integer ); +procedure TList.Delete(Idx: Integer); begin - DeleteRange( Idx, 1 ); + DeleteRange(Idx, 1); end; {$IFDEF ASM_TLIST} @@ -14542,83 +14030,6 @@ begin Result := Pointer( PAnsiChar( fItems ) + Idx * Sizeof( Pointer ) ); end; -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure TList.Put( Idx: Integer; Value: Pointer ); -{$IFDEF TLIST_FAST} -var i: Integer; - BlockStart: Pointer; - CountBefore, CountCurrent: Integer; -{$ENDIF} -begin - if (Idx < 0) or (Idx >= Count) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF TLIST_FAST} - if fUseBlocks and ( fBlockList <> nil ) then begin - CountBefore := 0; - i := 0; - if (fLastKnownBlockIdx > 0) and - (Idx >= fLastKnownCountBefore) then begin - i := fLastKnownBlockIdx; - CountBefore := fLastKnownCountBefore; - end; - while i < fBlockList.fCount div 2 do begin - BlockStart := fBlockList.fItems[ i * 2 ]; - CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] ); - if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then begin - fLastKnownBlockIdx := i; - fLastKnownCountBefore := CountBefore; - PPtrUInt( PAnsiChar( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ := - PtrUInt( Value ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - inc( CountBefore, CountCurrent ); - inc( i ); - end; - end else - {$ENDIF} - fItems[ Idx ] := Value; -end; -function TList.Get( Idx: Integer ): Pointer; -{$IFDEF TLIST_FAST} -var i: Integer; - BlockStart: Pointer; - CountBefore, CountCurrent: Integer; -{$ENDIF} -begin - Result := nil; - if (Idx < 0) or (Idx >= fCount) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF TLIST_FAST} - if fUseBlocks and Assigned(fBlockList) then begin - if fNotOptimized then begin - CountBefore := 0; - i := 0; - if (fLastKnownBlockIdx > 0) and (Idx >= fLastKnownCountBefore) then begin - i := fLastKnownBlockIdx; - CountBefore := fLastKnownCountBefore; - end; - while {i < fBlockList.fCount div 2} TRUE do begin - BlockStart := fBlockList.fItems[ i * 2 ]; - CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] ); - if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then begin - fLastKnownBlockIdx := i; - fLastKnownCountBefore := CountBefore; - Result := Pointer( PPtrUint( PAnsiChar( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Inc( CountBefore, CountCurrent ); - Inc( i ); - end; - end else begin // optimized! - i := Idx shr 8; - BlockStart := fBlockList.fItems[ i * 2 ]; - i := Idx and 255; - Result := Pointer( PPtrUInt( PAnsiChar( BlockStart ) + i * Sizeof( Pointer ) )^ ); - end; - end else - {$ENDIF} - Result := fItems[ Idx ]; -end; -{$ENDIF PAS_VERSION} - {$IFDEF ASM_TLIST} function TList.IndexOf( Value: Pointer ): Integer; asm @@ -14631,12 +14042,7 @@ asm MOV EAX, EDX REPNZ SCASD POP EDX - {$IFDEF USE_CMOV} CMOVNZ EDI, EDX - {$ELSE} - JZ @@succ - MOV EDI, EDX -@@succ: {$ENDIF} MOV EAX, EDI STC SBB EAX, EDX @@ -14906,116 +14312,7 @@ begin fCount := SrcList.fCount; end; -{$UNDEF ASM_LOCAL} -{$IFDEF ASM_noVERSION} - {$DEFINE ASM_LOCAL} -{$ENDIF} - -{$IFDEF ASM_LOCAL} //!!//!! -function CallCtlWndProc( Ctl: PControl; var Msg: TMsg ): LResult; -begin - Result := Ctl.WndProc( Msg ); -end; - -{ -- Window procedure -- } -function WndFunc( W: HWnd; Msg: Cardinal; wParam: WPARAM; lParam: LPARAM ) - : LRESULT; stdcall; -const size_TMsg = sizeof( TMsg ); -asm - ADD ESP, -size_TMsg - MOV EDX, ESP - - PUSH ESI - PUSH EDI - - MOV EDI, EDX - LEA ESI, [W] - - MOVSD - MOVSD - MOVSD - MOVSD - - MOV EDI, EDX - MOV EAX, [EDI] - TEST EAX, EAX - JZ @@self_is_nil - - MOV ECX, [CreatingWindow] - JECXZ @@get_self_prop - - MOV [ECX].TControl.fHandle, EAX - - PUSH ECX - PUSH ECX - {$IFDEF USE_PROP} - PUSH Offset[ID_SELF] - PUSH EAX - CALL SetProp - {$ELSE} - PUSH GWL_USERDATA - PUSH EAX - CALL SetWindowLongPtr - {$ENDIF} - XOR EAX, EAX - MOV [CreatingWindow], EAX - POP EAX // EAX = self_ - JMP @@self_got - -@@get_self_prop: - {$IFDEF USE_PROP} - PUSH Offset[ID_SELF] - PUSH EAX - CALL GetProp - {$ELSE} - PUSH GWL_USERDATA - PUSH EAX - CALL GetWindowLongPtr - {$ENDIF} - TEST EAX, EAX - JNZ @@self_got - -@@self_is_nil: - OR EAX, [ Applet ] - JNZ @@self_got - - POP EDI - POP ESI - MOV ESP, EBP - POP EBP - JMP DefWindowProc - -@@self_got: - MOV ESI, EAX - INC WORD PTR [ESI].TControl.fNestedMsgHandling - MOV EDX, EDI - CALL CallCtlWndProc - DEC WORD PTR [ESI].TControl.fNestedMsgHandling - JA @@1 - {$IFDEF USE_FLAGS} - TEST [ESI].TControl.fFlagsG2, (1 shl G2_BeginDestroying) - JZ @@1 - {$ELSE} - CMP [ESI].TControl.fBeginDestroying, 0 - JZ @@1 - {$ENDIF} - CMP [ESI].TObj.fRefCount, 0 - JNZ @@1 - CMP ESI, [Applet] - JZ @@1 - XCHG EAX, ESI - CALL TObj.Free - XCHG ESI, EAX -@@1: - - POP EDI - POP ESI - - MOV ESP, EBP -end; -{$ELSE PAS_VERSION} //Pascal -function WndFunc( W: HWnd; Msg: Cardinal; wParam: WPARAM; lParam: LPARAM ) - : LRESULT; stdcall; +function WndFunc( W: HWnd; Msg: Cardinal; wParam: WPARAM; lParam: LPARAM ): LRESULT; stdcall; var M: TMsg; self_: PControl; begin @@ -15057,21 +14354,10 @@ begin {$ENDIF DEBUG_CREATEWINDOW} self_ := CreatingWindow; CreatingWindow.fHandle := W; - {$IFDEF USE_PROP} - {$IFDEF INPACKAGE} - Log( '//// SetProp' ); - {$ENDIF INPACKAGE} - SetProp( W, ID_SELF, THandle( CreatingWindow ) ); - {$ELSE} SetWindowLongPtr( W, GWLP_USERDATA, PtrInt( CreatingWindow ) ); - {$ENDIF} CreatingWindow := nil; end else - {$IFDEF USE_PROP} - self_ := Pointer( GetProp( W, ID_SELF ) ); - {$ELSE} self_ := Pointer( GetWindowLongPtr( W, GWLP_USERDATA ) ); - {$ENDIF} end; if (self_ <> nil) then begin @@ -15106,7 +14392,7 @@ begin OnMonitorMessage( M, FALSE ); {$ENDIF} end; -{$ENDIF PAS_VERSION} + procedure TList.OptimizeForRead; {$IFDEF TLIST_FAST} var i, j, N: Integer; @@ -15206,6 +14492,16 @@ begin end; end; +function CallTControlCreateWindow( Ctl: PControl ): Boolean; +begin + Result := FALSE; + TRY + if Ctl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + Result := Ctl.CreateWindow; + EXCEPT + END; +end; + {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} procedure TerminateExecution( var AppletCtl: PControl ); var App: PControl; @@ -15227,23 +14523,7 @@ begin App.RefDec; end; end; -{$ENDIF PAS_VERSION} -function CallTControlCreateWindow( Ctl: PControl ): Boolean; -begin - {$IFDEF SAFE_CODE} - Result := FALSE; - TRY - if Ctl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Ctl.CreateWindow; - EXCEPT - END; - {$ELSE} - Result := Ctl.CreateWindow; - {$ENDIF} -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal procedure Run( var AppletCtl: PControl ); {$IFDEF PSEUDO_THREADS} var n: Integer; @@ -15398,49 +14678,8 @@ function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle; forward; var ApplyFont2Wnd_Proc: procedure( _Self: PObj ) = DummyObjProc; procedure DoApplyFont2Wnd( _Self: PControl ); forward; -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewBrush: PGraphicTool; -begin - Global_GetCtlBrushHandle := NormalGetCtlBrushHandle; - Result := _NewGraphicTool; - with Result^ do begin - fNewProc := @ NewBrush; - fType := gttBrush; - fMakeHandleProc := @ MakeBrushHandle; - Result.fData.Color := clBtnFace; - Result.fData.Brush.Style := bsSolid; - end; -end; -function NewPen: PGraphicTool; -begin - Result := _NewGraphicTool; - with Result^ do begin - fNewProc := @ NewPen; - fType := gttPen; - fMakeHandleProc := @ MakePenHandle; - fData.Pen.Mode := pmCopy; - end; -end; -function NewFont: PGraphicTool; -begin - ApplyFont2Wnd_Proc := @ DoApplyFont2Wnd; - Result := _NewGraphicTool; - with Result^ do begin - fNewProc := @ NewFont; - fType := gttFont; - fMakeHandleProc := @ MakeFontHandle; - fData.Color := DefFontColor; - Move( DefFont, fData.Font, Sizeof( TGDIFont ) ); - end; -end; -function Color2RGB( Color: TColor ): TColor; -begin - if (Color < 0) then - Result := GetSysColor(Color and $7F) - else - Result := Color; -end; -{$ENDIF PAS_VERSION} +{ TGraphicTool } + function RGB2BGR( Color: TColor ): TColor; begin Result := ((Color shr 16) or (Color shl 16) or Color and $00FF00) and $FFFFFF; @@ -15490,6 +14729,51 @@ begin end; {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal +function NewBrush: PGraphicTool; +begin + Global_GetCtlBrushHandle := NormalGetCtlBrushHandle; + Result := _NewGraphicTool; + with Result^ do begin + fNewProc := @ NewBrush; + fType := gttBrush; + fMakeHandleProc := @ MakeBrushHandle; + Result.fData.Color := clBtnFace; + Result.fData.Brush.Style := bsSolid; + end; +end; + +function NewPen: PGraphicTool; +begin + Result := _NewGraphicTool; + with Result^ do begin + fNewProc := @ NewPen; + fType := gttPen; + fMakeHandleProc := @ MakePenHandle; + fData.Pen.Mode := pmCopy; + end; +end; + +function NewFont: PGraphicTool; +begin + ApplyFont2Wnd_Proc := @ DoApplyFont2Wnd; + Result := _NewGraphicTool; + with Result^ do begin + fNewProc := @ NewFont; + fType := gttFont; + fMakeHandleProc := @ MakeFontHandle; + fData.Color := DefFontColor; + Move( DefFont, fData.Font, Sizeof( TGDIFont ) ); + end; +end; + +function Color2RGB( Color: TColor ): TColor; +begin + if (Color < 0) then + Result := GetSysColor(Color and $7F) + else + Result := Color; +end; + function Color2RGBQuad( Color: TColor ): TRGBQuad; var C: Integer; begin @@ -15497,6 +14781,7 @@ begin C := ((C shr 16) and $FF) or ((C shl 16) and $FF0000) or (C and $FF00); Result := TRGBQuad( C ); end; + function Color2Color16( Color: TColor ): WORD; begin Color := Color2RGB( Color ); @@ -15504,18 +14789,13 @@ begin (Color shr 5) and $7E0 or (Color shl 8) and $F800; end; -{ TGraphicTool } + function TGraphicTool.Assign(Value: PGraphicTool): PGraphicTool; var _Self: PGraphicTool; begin Result := nil; if Value = nil then begin - {$IFDEF OLD_REFCOUNT} - if @Self <> nil then - DoDestroy; - {$ELSE} Free; - {$ENDIF} Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} end; _Self := @Self; @@ -15535,6 +14815,7 @@ begin Move( Value.fData, _Self.fData, Sizeof( fData ) ); _Self.Changed; // to inform owner control, that its tool (font, brush) changed end; + procedure TGraphicTool.Changed; var H: THandle; begin @@ -15560,6 +14841,7 @@ begin end; end; + destructor TGraphicTool.Destroy; begin @@ -15583,12 +14865,14 @@ begin inherited; end; + function TGraphicTool.ReleaseHandle: THandle; begin Changed; Result := fHandle; fHandle := 0; end; + procedure TGraphicTool.SetInt( const Index: Integer; Value: Integer ); var Where: PInteger; begin @@ -15597,6 +14881,7 @@ begin Where^ := Value; Changed; end; + function TGraphicTool.IsFontTrueType: Boolean; var OldFont: HFont; DC: HDC; @@ -15610,7 +14895,9 @@ begin SelectObject( DC, OldFont ); ReleaseDC( 0, DC ); end; + {$ENDIF PAS_VERSION} + function TGraphicTool.GetInt(const Index: Integer): Integer; var Where: PInteger; begin @@ -16926,8 +16213,13 @@ begin D := 1.0; while I <= Length( S ) do begin case S[ I ] of - '.' {$IFNDEF SMALLEST_CODE}, ','{$ENDIF}: - if not Pt then Pt := TRUE else break; + '.', ',': + begin + if not Pt then + Pt := TRUE + else + break; + end; '0'..'9': if not Pt then Result := Result * 10 + Integer( S[ I ] ) - Integer( '0' ) else begin @@ -16964,7 +16256,7 @@ begin D := 1.0; while I <= Length( S ) do begin case S[ I ] of - '.' {$IFNDEF SMALLEST_CODE}, ','{$ENDIF}: + '.', ',': if not Pt then Pt := TRUE else break; '0'..'9': if not Pt then Result := Result * 10 + Integer( S[ I ] ) - Integer( '0' ) @@ -17606,8 +16898,65 @@ begin Move(Source^, Dest^, L + 1); Result := Dest; end; -{$ELSE} -function StrCopy( Dest, Source: PAnsiChar ): PAnsiChar; assembler; + +function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; // by dufa +begin + if Assigned(Str) then begin + repeat + if (Str^ = Chr) then begin + Result := Str; + Exit; + end else if (Str^ = #0) then + Break; + // next + Inc(Str); + until False; + end; + // not found or null input + Result := nil; +end; + +function StrRScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; // by dufa +begin + // not found or null input + Result := nil; + if Assigned(Str) then begin + repeat + if (Str^ = Chr) then + Result := Str; + if (Str^ = #0) then + Break; + // next + Inc(Str); + until False; + end; +end; + +function StrScanLen(Str: PAnsiChar; Chr: AnsiChar; Len: Integer): PAnsiChar; // todo: check +begin + while (Str^ <> #0) and (Len > 0) do begin + if Str^ = Chr then begin + Inc(Str); + break; + end; + inc(Str); + dec(Len); + end; + Result := Str; +end; + +procedure Str2LowerCase( S: PAnsiChar ); +begin + while S^ <> #0 do begin + if (S^ >= 'A') and (S^ <= 'Z') then + S^ := AnsiChar(Ord(S^)+32); + inc(S); + end; +end; + +{$ELSE PAS_ONLY} + +function StrCopy(Dest, Source: PAnsiChar): PAnsiChar; assembler; asm PUSH EDI PUSH ESI @@ -17629,42 +16978,7 @@ asm POP ESI POP EDI end; -{$ENDIF PAS_ONLY} -function StrCat(Dest, Source: PAnsiChar): PAnsiChar; // by dufa -var - str: PAnsiChar; -begin - str := StrScan(Dest, #0); - if Assigned(str) then - StrCopy(str, Source); - Result := Dest; -end; - -{$IFDEF PAS_ONLY} -//function bugStrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; -//begin -// while Str^ <> Chr do -// begin -// if Str^ = #0 then break; -// inc(Str); -// end; -// Result := Str; -//end; -function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; // by Netspirit -begin - Result := nil; - if (Str = nil) then Exit; - - while (Str^ <> #0) do begin - if (Str^ = Chr) then begin - Result := Str; - Break; - end; - Inc(Str); - end; -end; -{$ELSE} function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; assembler; asm PUSH EDI @@ -17687,20 +17001,7 @@ asm @@1: DEC EAX end; -{$ENDIF PAS_ONLY} -{$IFDEF PAS_ONLY} -function StrRScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; -begin - Result := nil; - while Str^ <> #0 do begin - if Str^ = Chr then Result := Str; - inc(Str); - end; - if Result = nil then - Result := Str; -end; -{$ELSE} function StrRScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; assembler; asm PUSH EDI @@ -17720,22 +17021,7 @@ asm @@1: CLD POP EDI end; -{$ENDIF PAS_ONLY} -{$IFDEF PAS_ONLY} -function StrScanLen(Str: PAnsiChar; Chr: AnsiChar; Len: Integer): PAnsiChar; -begin - while (Str^ <> #0) and (Len > 0) do begin - if Str^ = Chr then begin - Inc(Str); - break; - end; - inc(Str); - dec(Len); - end; - Result := Str; -end; -{$ELSE} function StrScanLen(Str: PAnsiChar; Chr: AnsiChar; Len: Integer): PAnsiChar; assembler; asm PUSH EDI @@ -17747,7 +17033,41 @@ asm { -> EAX => to next character after found or to the end of Str, ZF = 0 if character found. } end; -{$ENDIF} + +procedure Str2LowerCase( S: PAnsiChar ); +asm + XOR ECX, ECX +@@1: + MOV CL, byte ptr [EAX] + JECXZ @@exit {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + SUB CL, 'A' + CMP CL, 'Z'-'A' + JA @@2 + ADD byte ptr [EAX], 32 +@@2: INC EAX + JMP @@1 +@@exit: +end; + +{$ENDIF PAS_ONLY} + +function StrCat(Dest, Source: PAnsiChar): PAnsiChar; // by dufa +var + str: PAnsiChar; +begin + str := StrScan(Dest, #0); + if Assigned(str) then + StrCopy(str, Source); + Result := Dest; +end; + +function RemoveSpaces( const S: KOLString ): KOLString; +var I: Integer; +begin + Result := S; + for I := Length( S ) downto 1 do + if S[ I ] <= ' ' then Delete( Result, I, 1 ); +end; {$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal function TrimLeft(const S: KOLString): KOLString; @@ -17775,43 +17095,7 @@ function Trim( const S : KOLString): KOLString; begin Result := TrimLeft( TrimRight( S ) ); end; -{$ENDIF PAS_VERSION} -function RemoveSpaces( const S: KOLString ): KOLString; -var I: Integer; -begin - Result := S; - for I := Length( S ) downto 1 do - if S[ I ] <= ' ' then Delete( Result, I, 1 ); -end; - -{$IFDEF PAS_ONLY} -procedure Str2LowerCase( S: PAnsiChar ); -begin - while S^ <> #0 do begin - if (S^ >= 'A') and (S^ <= 'Z') then - S^ := AnsiChar(Ord(S^)+32); - inc(S); - end; -end; -{$ELSE} -procedure Str2LowerCase( S: PAnsiChar ); -asm - XOR ECX, ECX -@@1: - MOV CL, byte ptr [EAX] - JECXZ @@exit {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SUB CL, 'A' - CMP CL, 'Z'-'A' - JA @@2 - ADD byte ptr [EAX], 32 -@@2: INC EAX - JMP @@1 -@@exit: -end; -{$ENDIF PAS_ONLY} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal function LowerCase(const S: Ansistring): Ansistring; var I : Integer; begin @@ -17890,10 +17174,7 @@ begin Len := L; Delete( S, L - Len + 1, Len ); end; -{$ENDIF PAS_VERSION} -{$IFNDEF TEST_INDEXOFCHARS_COMPAT} -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer; var //P, F : PChar; i, l : integer; @@ -17909,45 +17190,6 @@ begin end; end; {$ENDIF PAS_VERSION} -{$ELSE TEST_INDEXOFCHARS_COMPAT}//////////////////////////////////////////////// -function IndexOfChar_Old( const S : AnsiString; Chr : AnsiChar ) : Integer; -var P, F : PAnsiChar; -begin - P := PAnsiChar( S ); - F := StrScan( P, Chr ); - Result := -1; - if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := PtrInt( F ) - PtrInt( P ) + 1; -end; /////////////////////////////////////////////////////////////////////////// -function IndexOfChar_New( const S : AnsiString; Chr : AnsiChar ) : Integer; -var P, F : PAnsiChar; -begin - P := PAnsiChar( S ); - F := StrScanLen( P, Chr, Length( S ) ); - Result := -1; - if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := PtrInt( F ) - PtrInt( P ); - if {(Result > Length(S)) or} (S[ Result ] <> Chr) then - Result := -1; -end; /////////////////////////////////////////////////////////////////////////// -function Replace0with_( const s: AnsiString ): AnsiString; -var i: Integer; -begin - Result := s; - for i := 1 to Length( s ) do - if s[i] = #0 then Result[i] := '_'; -end; -function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer; -begin - Result := IndexOfChar_Old( S, Chr ); - if Result <> IndexOfChar_New( S, Chr ) then begin - LogFileOutput( 'c:\kol\TEST_INDEXOFCHARS_COMPAT.txt', - 'S=' + Replace0with_( S ) + #13#10 + - 'C=' + Replace0with_( Chr ) + ' Old=' + Int2Str( Result ) + - ' New=' + Int2Str( IndexOfChar_New( S, Chr ) ) + #13#10 ); - end; -end; -{$ENDIF} function WIndexOfChar( const S : KOLWideString; Chr : WideChar ) : Integer; var i, l : integer; @@ -18006,76 +17248,11 @@ begin end; {$ENDIF _FPC} -{$DEFINE ASM_LOCAL} -{$IFDEF PAS_VERSION} {$UNDEF ASM_LOCAL}{$ENDIF} -{$IFDEF UNICODE_CTRLS}{$UNDEF ASM_LOCAL}{$ENDIF} -{$IFDEF ASM_LOCAL} -function IndexOfStr( const S, Sub : KOLString ) : Integer; -asm - PUSH EBX - PUSH ESI - PUSH EDI - - PUSH EAX - MOV EAX, EDX - PUSH EDX - CALL System.@LStrLen - MOV EDI, EAX - POP EAX - CALL EAX2PChar - MOV BL, [EAX] - XCHG EAX, [ESP] - CALL EAX2PChar - - MOV ESI, EAX - - DEC EAX -@@1: INC EAX - MOV DL, BL - MOV ECX, [ESI-4] - SUB ECX, EAX - ADD ECX, ESI - - CMP ECX, EDI - JL @@ret__1 - - CALL StrScanLen - TEST EAX, EAX - JE @@exit__1 - DEC EAX - - POP EDX - PUSH EDX - - MOV ECX, EDI - PUSH EAX - //CALL StrLComp - CALL CompareMem - TEST AL, AL - POP EAX - JZ @@1 - - SUB EAX, ESI - INC EAX - JMP @@exit - -@@ret__1: - XOR EAX, EAX -@@exit__1: - DEC EAX -@@exit: - POP EDX - POP EDI - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal function IndexOfStr( const S, Sub : KOLString ) : Integer; begin Result := pos( Sub, S ); if Result = 0 then Result := -1; end; -{$ENDIF PAS_VERSION} {$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal function Parse(var S: KOLString; const Separators: KOLString): KOLString; @@ -18432,14 +17609,13 @@ end; function WStrRScan(Str: PWideChar; Chr: WideChar): PWideChar; begin - Result := nil; - while Str^ <> #0 do begin - if Str^ = Chr then - Result := Str; - inc(Str); - end; - if Result = nil then - Result := Str; + Result := nil; // Hubert Bannwarth: Return nil if string not found + while Str^ <> #0 do begin + if Str^ = Chr then + Result := Str; + + inc(Str); + end; end; {$ENDIF _FPC} @@ -18453,23 +17629,14 @@ begin Result := CompareStringA(LOCALE_USER_DEFAULT, 0, PAnsiChar(S1), -1, PAnsiChar(S2), -1 ) - 2; end; -function _AnsiCompareStr(S1, S2: PKOLChar): Integer; +function _AnsiCompareStr(const S1, S2: PKOLChar): Integer; begin - Result := CompareString( LOCALE_USER_DEFAULT, 0, S1, -1, S2, -1) - 2; + Result := CompareString(LOCALE_USER_DEFAULT, 0, S1, -1, S2, -1) - 2; end; -type - PSortAnsiRec = ^TSortAnsiRec; - TSortAnsiRec = record - A: array[ AnsiChar ] of PAnsiChar; - end; - -var SortAnsiOrderNoCase: array[ AnsiChar ] of SmallInt; - SortAnsiOrder: array[ AnsiChar ] of SmallInt; - function _AnsiCompareStrA_Slow(const S1, S2: PAnsiChar): Integer; begin - Result := CompareStringA( LOCALE_USER_DEFAULT, 0, S1, -1, S2, -1) - 2; + Result := CompareStringA(LOCALE_USER_DEFAULT, 0, S1, -1, S2, -1) - 2; end; function CompareAnsiRec( R: PSortAnsiRec; const e1, e2: Integer ): Integer; @@ -18492,7 +17659,7 @@ begin end; {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function _AnsiCompareStrA_Fast2(const S1, S2: PAnsiChar): Integer; +function _AnsiCompareStrA_Fast(const S1, S2: PAnsiChar): Integer; var P1: PAnsiChar; P2: PAnsiChar; @@ -18512,61 +17679,13 @@ begin Result := SortAnsiOrder[P1^] - SortAnsiOrder[P2^]; if (Result <> 0) or (P1^ = #0) or (P2^ = #0) then Break; - + Inc(P1); Inc(P2); end; end; -{$ENDIF PAS_VERSION} -function _AnsiCompareStrA_Fast(const S1, S2: PAnsiChar): Integer; -var c: AnsiChar; - R: TSortAnsiRec; - Buf: array[ 0..511 ] of AnsiChar; - P: PAnsiChar; -begin - P := @Buf[0]; - for c := Low(c) to High(c) do begin - P^ := c; - R.A[c] := P; - inc( P ); - P^ := #0; - inc( P ); - end; - SortData( @R, 256, @CompareAnsiRec, @SwapAnsiRec ); - for c := Low(c) to High(c) do - SortAnsiOrder[AnsiChar(R.A[c][0])] := Ord(c); - _AnsiCompareStrA := _AnsiCompareStrA_Fast2; - Result := _AnsiCompareStrA_Fast2( S1, S2 ); -end; - -function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer; -begin - Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PKOLChar(S1), -1, PKOLChar(S2), -1 ) - 2; -end; - -function AnsiCompareStrNoCaseA(const S1, S2: AnsiString): Integer; -begin - Result := CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PAnsiChar(S1), -1, PAnsiChar(S2), -1 ) - 2; -end; - -function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer; -begin - Result := CompareString( LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1, S2, -1) - 2; -end; - -function _AnsiCompareStrNoCaseA_Slow(const S1, S2: PAnsiChar): Integer; -begin - Result := CompareStringA( LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1, S2, -1) - 2; -end; - -function CompareAnsiRecNoCase( R: PSortAnsiRec; const e1, e2: Integer ): Integer; -begin - Result := _AnsiCompareStrNoCaseA_Slow(R.A[AnsiChar(e1)] + 1, R.A[AnsiChar(e2)] + 1); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function _AnsiCompareStrNoCaseA_Fast2(const S1, S2: PAnsiChar): Integer; +function _AnsiCompareStrNoCaseA_Fast(const S1, S2: PAnsiChar): Integer; var P1: PAnsiChar; P2: PAnsiChar; @@ -18586,14 +17705,64 @@ begin Result := SortAnsiOrderNoCase[P1^] - SortAnsiOrderNoCase[P2^]; if (Result <> 0) or (P1^ = #0) or (P2^ = #0) then Break; - + Inc(P1); Inc(P2); end; end; {$ENDIF PAS_VERSION} -function _AnsiCompareStrNoCaseA_Fast(const S1, S2: PAnsiChar): Integer; +function CompareAnsiRecNoCase(R: PSortAnsiRec; const e1, e2: Integer): Integer; +begin + Result := CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE, + R.A[AnsiChar(e1)] + 1, -1, R.A[AnsiChar(e2)] + 1, -1) - 2; +end; + +procedure InitAnsi; +var + Buf: array[0..511] of AnsiChar; + R: TSortAnsiRec; + P: PAnsiChar; + c: AnsiChar; +begin + if not IsAnsiInit then begin + P := @Buf[0]; + for c := Low(c) to High(c) do begin + P^ := c; + R.A[c] := P; + Inc( P ); + P^ := #0; + Inc( P ); + end; + SortData(@R, 256, @CompareAnsiRec, @SwapAnsiRec); + + for c := Low(c) to High(c) do + SortAnsiOrder[AnsiChar(R.A[c][0])] := Ord(c); + + IsAnsiInit := True; + end; +end; + +function _AnsiCompareStrA(const S1, S2: PAnsiChar): Integer; +//begin +// if not IsAnsiInit then +// InitAnsi; +// +// Result := _AnsiCompareStrA_Fast(S1, S2); +asm + CMP BYTE PTR [IsAnsiInit], $00 + JNZ @@Start +@@Upper: + PUSH S1 + PUSH S2 + CALL InitAnsi + POP S2 + POP S1 +@@Start: + CALL _AnsiCompareStrA_Fast +end; + +procedure InitAnsiNoCase; var c: AnsiChar; R: TSortAnsiRec; Buf: array[ 0..767 ] of AnsiChar; @@ -18602,37 +17771,75 @@ var c: AnsiChar; a: PAnsiChar; {$ENDIF} begin + if not IsAnsiNoCaseInit then begin P := @Buf[0]; for c := Low(c) to High(c) do begin - R.A[c] := P; - P^ := c; - inc( P ); - P^ := AnsiLowerCase( c )[1]; - inc( P ); - P^ := #0; - inc( P ); - //R.X[c] := Ord(c); + R.A[c] := P; + P^ := c; + inc( P ); + P^ := AnsiLowerCase( c )[1]; + inc( P ); + P^ := #0; + inc( P ); + //R.X[c] := Ord(c); end; SortData( @R, 256, @CompareAnsiRecNoCase, @SwapAnsiRec ); for c := Succ(Low(c)) to High(c) do begin - //R.X[c] := Byte(c); - if _AnsiCompareStrNoCaseA_Slow( R.A[Pred(c)] + 1, R.A[c] + 1 ) = 0 then begin - if _AnsiCompareStrA( R.A[Pred(c)], R.A[c] ) < 0 then begin - {$IFDEF PAS_ONLY} - a := R.A[Pred(c)]; - R.A[Pred(c)] := R.A[c]; - R.A[c] := a; - {$ELSE} - Swap( PtrInt( R.A[Pred(c)] ), PtrInt( R.A[c] ) ); - {$ENDIF} - end; + //R.X[c] := Byte(c); + if (CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE, R.A[Pred(c)] + 1, -1, R.A[c] + 1, + -1) = 2) then begin + if (_AnsiCompareStrA(R.A[Pred(c)], R.A[c]) < 0) then begin + {$IFDEF PAS_ONLY} + a := R.A[Pred(c)]; + R.A[Pred(c)] := R.A[c]; + R.A[c] := a; + {$ELSE} + Swap(PtrInt(R.A[Pred(c)]), PtrInt(R.A[c])); + {$ENDIF} end; - // R.X[c] := R.X[Pred(c)]; + end; + // R.X[c] := R.X[Pred(c)]; end; + for c := Low(c) to High(c) do - SortAnsiOrderNoCase[AnsiChar(R.A[c][0])] := Ord( R.A[c][1] ); // Ord(c); // R.X[c]; - _AnsiCompareStrNoCaseA := _AnsiCompareStrNoCaseA_Fast2; - Result := _AnsiCompareStrNoCaseA_Fast2( S1, S2 ); + SortAnsiOrderNoCase[AnsiChar(R.A[c][0])] := Ord( R.A[c][1] ); // Ord(c); // R.X[c]; + + IsAnsiNoCaseInit := True; + end; +end; + +function _AnsiCompareStrNoCaseA(const S1, S2: PAnsiChar): Integer; +//begin +// if not IsAnsiNoCaseInit then +// InitAnsiNoCase; +// +// Result := _AnsiCompareStrNoCaseA_Fast(S1, S2); +asm + CMP BYTE PTR [IsAnsiNoCaseInit], $00 + JNZ @@Start +@@Upper: + PUSH S1 + PUSH S2 + CALL InitAnsiNoCase + POP S2 + POP S1 +@@Start: + CALL _AnsiCompareStrNoCaseA_Fast +end; + +function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer; +begin + Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PKOLChar(S1), -1, PKOLChar(S2), -1 ) - 2; +end; + +function AnsiCompareStrNoCaseA(const S1, S2: AnsiString): Integer; +begin + Result := CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PAnsiChar(S1), -1, PAnsiChar(S2), -1 ) - 2; +end; + +function _AnsiCompareStrNoCase(const S1, S2: PKOLChar): Integer; +begin + Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1, S2, -1) - 2; end; function AnsiCompareText( const S1, S2: KOLString ): Integer; @@ -18645,53 +17852,6 @@ begin Result := AnsiCompareStrNoCaseA( S1, S2 ); end; -{$IFDEF PAS_ONLY} -function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; -var Src: PAnsiChar; -begin - Src := Source; - while MaxLen > 0 do begin - Dest^ := Src^; - if Src^ = #0 then break; - inc(Dest); - inc(Src); - dec(MaxLen); - end; - Result := Dest; -end; -{$ELSE} -function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; assembler; -asm - PUSH EDI - PUSH ESI - PUSH EBX - MOV ESI,EAX - MOV EDI,EDX - MOV EBX,ECX - XOR AL,AL - TEST ECX,ECX - JZ @@1 - REPNE SCASB - JNE @@1 - INC ECX -@@1: SUB EBX,ECX - MOV EDI,ESI - MOV ESI,EDX - MOV EDX,EDI - MOV ECX,EBX - SHR ECX,2 - REP MOVSD - MOV ECX,EBX - AND ECX,3 - REP MOVSB - STOSB - MOV EAX,EDX - POP EBX - POP ESI - POP EDI -end; -{$ENDIF} - {$IFNDEF _FPC} function WAnsiEq( const S1, S2 : KOLWideString ) : Boolean; begin @@ -18904,60 +18064,6 @@ begin end; {$ENDIF _FPC} -{$IFDEF ASM_VERSION} - {$IFDEF UNICODE_CTRLS} - function StrRepeat( const S: KOLString; Count: Integer ): KOLString; - var L: Integer; - begin - Result := ''; - L := Length(S); - if L = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SetLength( Result, Count * Length( S ) ); - Move( S[1], Result[1], Length(S)*Sizeof(KOLChar) ); - if Count > 1 then - DoMove( Result[1], Result[1+Length(S)], - (Length(Result)-Length(S))*Sizeof(KOLChar) ); - end; - {$ELSE notUNICODE} -function StrRepeat( const S: KOLString; Count: Integer ): KOLString; -asm - PUSH EBX - PUSH ESI - PUSH EDI - MOV EBX, ECX - MOV EDI, EDX - XCHG ESI, EAX - - MOV EAX, ECX - CALL System.@LStrClr - TEST ESI, ESI - JZ @@exit - MOV EDX, [ESI-4] - imul edx, EDI - PUSH EDX - MOV EAX, EBX - CALL System.@LStrSetLength - PUSH ESI - PUSH EDI - MOV ECX, [ESI-4] - MOV EDI, [EBX] - REP MOVSB - POP EAX - POP ESI - DEC EAX - POP ECX - JLE @@exit - SUB ECX, [ESI-4] - MOV ESI, [EBX] - REP MOVSB -@@exit: - POP EDI - POP ESI - XCHG EAX, EBX - POP EBX -end; -{$ENDIF notUNICODE_CTRLS} -{$ELSE ASM_VERSION} function StrRepeat( const S: KOLString; Count: Integer ): KOLString; var I, L: Integer; begin @@ -18966,9 +18072,7 @@ begin for I := 0 to Count-1 do Move( S[ 1 ], Result[ 1 + I * L * Sizeof(KOLChar) ], L ); end; -{$ENDIF PAS_VERSION} -{$IFDEF ASM_noVERSION}{$ELSE PAS_VERSION} //Pascal procedure NormalizeUnixText( var S: AnsiString ); var I, J, N: Integer; begin @@ -18997,7 +18101,6 @@ begin end; end; end; -{$ENDIF PAS_VERSION} var Koi8_to_Ansi: array[ Char ] of AnsiChar; procedure Koi8ToAnsi( s: PAnsiChar ); @@ -19016,262 +18119,370 @@ begin end; end; -{$IFDEF PAS_ONLY} -function StrComp(const Str1, Str2: PAnsiChar): Integer; -var S1, S2: PAnsiChar; +procedure Init_Upper; // dufa: new variant - smaller and faster +var + C: AnsiChar; begin - S1 := Str1; - S2 := Str2; - while (S1^ <> #0) and (S2^ <> #0) do begin - Result := Integer(Ord(S1^)) - Integer(Ord(S2^)); - if Result <> 0 then Exit; - inc(S1); - inc(S2); - end; - Result := 0; -end; -{$ELSE} -function StrComp(const Str1, Str2: PAnsiChar): Integer; assembler; -asm - PUSH EDI - PUSH ESI - MOV EDI,EDX - XCHG ESI,EAX - OR ECX, -1 - XOR EAX,EAX - REPNE SCASB - NOT ECX - MOV EDI,EDX - XOR EDX,EDX - REPE CMPSB - MOV AL,[ESI-1] - MOV DL,[EDI-1] - SUB EAX,EDX - POP ESI - POP EDI -end; -{$ENDIF PAS_ONLY} - -var Upper: array[AnsiChar] of AnsiChar; - Upper_initialized: Boolean; - -procedure Init_Upper; -var c: AnsiChar; - s: AnsiString; -begin - if not Upper_initialized then begin - for c := Low(c) to High(c) do begin - s := c + AnsiChar( ' ' ); - Upper[c] := AnsiUpperCase( s )[1]; - end; - Upper_initialized := True; + if not IsUpperInit then begin + for C := Low(Upper) to High(Upper) do + Upper[C] := C; + // debug + //Mem2File('Init_Upper_orig', @Upper, SizeOf(Upper)); + AnsiUpperBuff(Upper, SizeOf(Upper)); + IsUpperInit := True; + // debug + //Mem2File('Init_Upper_case', @Upper, SizeOf(Upper)); end; end; -{$IFDEF PAS_ONLY} -function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -var S1, S2: PAnsiChar; - c1, c2: AnsiChar; +//{$IFDEF PAS_ONLY} //dufa +{$IFDEF PAS_VERSION} //dufa +function StrComp(const Str1, Str2: PAnsiChar): Integer; // by dufa +var + S1: PAnsiChar; + S2: PAnsiChar; begin - S1 := Str1; - S2 := Str2; - while (S1^ <> #0) and (S2^ <> #0) and (MaxLen > 0) do begin - c1 := S1^; - c2 := S2^; - Result := Integer(c1) - Integer(c2); - if Result <> 0 then Exit; - inc(S1); - inc(S2); + S1 := Str1; + S2 := Str2; + repeat + Result := Byte(S1^) - Byte(S2^); + if (Result <> 0) or (S1^ = #0) or (S2^ = #0) then + Exit; + Inc(S1); + Inc(S2); + until False; +end; + +function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; // by dufa +var + S1: PAnsiChar; + S2: PAnsiChar; +begin + if not IsUpperInit then + Init_Upper; + S1 := Str1; + S2 := Str2; + repeat + Result := Byte(Upper[S1^]) - Byte(Upper[S2^]); + if (Result <> 0) or (S1^ = #0) or (S2^ = #0) then + Exit; + Inc(S1); + Inc(S2); + until False; +end; + +function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; // by dufa +var + S1: PAnsiChar; + S2: PAnsiChar; +begin + S1 := Str1; + S2 := Str2; + repeat + Result := Byte(S1^) - Byte(S2^); + Dec(MaxLen); + if (Result <> 0) or (S1^ = #0) or (S2^ = #0) or (MaxLen = 0) then + Exit; + Inc(S1); + Inc(S2); + until False; +end; + +function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; // by dufa +var + S1: PAnsiChar; + S2: PAnsiChar; +begin + if not IsUpperInit then + Init_Upper; + S1 := Str1; + S2 := Str2; + repeat + Result := Byte(Upper[S1^]) - Byte(Upper[S2^]); + Dec(MaxLen); + if (Result <> 0) or (S1^ = #0) or (S2^ = #0) or (MaxLen = 0) then + Exit; + Inc(S1); + Inc(S2); + until False; +end; + +function StrLen(const Str: PAnsiChar): Cardinal; +begin + Result := Length(Str); +end; + +function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; +var Src: PAnsiChar; +begin + Src := Source; + while MaxLen > 0 do begin + Dest^ := Src^; + if Src^ = #0 then break; + inc(Dest); + inc(Src); dec(MaxLen); end; + Result := Dest; +end; + +function StrIsStartingFromNoCase( Str, Pattern: PAnsiChar ): Boolean; +begin + Result := FALSE; + while (Str^ <> #0) and (Pattern^ <> #0) do begin + if Str^ <> Pattern^ then Exit; + inc(Str^); + inc(Pattern^); + end; + Result := Pattern^ = #0; +end; + +procedure WStrCopy( Dest, Src: PWideChar ); +begin + while Src^ <> #0 do begin + Dest^ := Src^; + inc(Src); + inc(Dest); + end; + Dest^ := #0; //dmiko +end; + +function WStrCmp( W1, W2: PWideChar ): Integer; +begin + while (W1^ <> #0) and (w2^ <> #0) do begin + Result := Integer(Ord(w1^)) - Integer(Ord(w2^)); + if Result <> 0 then Exit; + inc(w1); + inc(w2); + end; Result := 0; end; -function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -var S1, S2: PAnsiChar; - c1, c2: AnsiChar; +function WStrLen( W: PWideChar ): Integer; begin - S1 := Str1; - S2 := Str2; - while (S1^ <> #0) and (S2^ <> #0) and (MaxLen > 0) do begin - c1 := S1^; - if (c1 >= 'a') and (c1 <= 'z') then - c1 := AnsiChar(Ord(c1)-32); - c2 := S2^; - if (c2 >= 'a') and (c2 <= 'z') then - c2 := AnsiChar(Ord(c2)-32); - Result := Integer(c1) - Integer(c2); - if Result <> 0 then Exit; - inc(S1); - inc(S2); - dec(MaxLen); - end; - Result := 0; + Result := 0; + while W^ <> #0 do begin + Inc(Result); + Inc(W); + end; end; -function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; -var S1, S2: PAnsiChar; - c1, c2: AnsiChar; -begin - S1 := Str1; - S2 := Str2; - while (S1^ <> #0) and (S2^ <> #0) do begin - c1 := S1^; - if (c1 >= 'a') and (c1 <= 'z') then - c1 := AnsiChar(Ord(c1)-32); - c2 := S2^; - if (c2 >= 'a') and (c2 <= 'z') then - c2 := AnsiChar(Ord(c2)-32); - Result := Integer(c1) - Integer(c2); - if Result <> 0 then Exit; - inc(S1); - inc(S2); - end; - Result := 0; -end; {$ELSE} -{$IFDEF SMALLER_CODE} -function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; + +function WStrLen( W: PWideChar ): Integer; asm - PUSH EDI - PUSH ESI - MOV EDI,EDX - XCHG ESI,EAX - OR ECX, -1 - XOR EAX,EAX - REPNE SCASB - - NOT ECX - MOV EDI,EDX - @@0: - XOR EDX,EDX - REPE CMPSB - MOV AL,[ESI-1] - MOV AH, AL - SUB AH, 'a' - CMP AH, 25 - JA @@1 - SUB AL, $20 - @@1: - MOV DL,[EDI-1] - MOV AH, DL - SUB AH, 'a' - CMP AH, 25 - JA @@2 - SUB DL, $20 - @@2: - MOV AH, 0 - SUB EAX,EDX - JNZ @@exit - CMP DL, 0 - JNZ @@0 - - @@exit: - POP ESI - POP EDI + XCHG EDI, EAX + XCHG EDX, EAX + OR ECX, -1 + XOR EAX, EAX + CMP EAX, EDI + JE @@exit0 + REPNE SCASW + DEC EAX + DEC EAX + SUB EAX, ECX +@@exit0: + MOV EDI, EDX end; -function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; +function WStrCmp( W1, W2: PWideChar ): Integer; +asm + PUSH ESI + PUSH EDI + XCHG ESI, EAX + MOV EDI, EDX + XOR EAX, EAX +@@loop: LODSW + MOVZX EDX, word ptr [EDI] + INC EDI + INC EDI + CMP EAX, EDX + JNE @@exit + TEST EAX, EAX + JNZ @@loop +@@exit: SUB EAX, EDX + POP EDI + POP ESI +end; + +procedure WStrCopy( Dest, Src: PWideChar ); asm PUSH EDI PUSH ESI - PUSH EBX - MOV EDI,EDX MOV ESI,EAX - MOV EBX,ECX - XOR EAX,EAX - OR ECX,ECX - JE @@exit - REPNE SCASB - SUB EBX,ECX - MOV ECX,EBX MOV EDI,EDX - @@0: - XOR EDX,EDX - REPE CMPSB - MOV AL,[ESI-1] - MOV AH, AL - SUB AH, 'a' - CMP AH, 25 - JA @@1 - SUB AL, $20 - @@1: - MOV DL,[EDI-1] - MOV AH, DL - SUB AH, 'a' - CMP AH, 25 - JA @@2 - SUB DL, $20 - @@2: - MOV AH, 0 - SUB EAX,EDX - JECXZ @@exit - JZ @@0 - - @@exit: - POP EBX + OR ECX, -1 + XOR EAX, EAX + REPNE SCASW + NOT ECX + MOV EDI,ESI + MOV ESI,EDX + REP MOVSW POP ESI POP EDI end; -{$ELSE not SMALLER_CODE} -function StrComp_NoCase2(const Str1, Str2: PAnsiChar): Integer; + +function StrIsStartingFromNoCase( Str, Pattern: PAnsiChar ): Boolean; asm - PUSH ESI - XCHG ESI, EAX - @@1: - MOVZX EAX, BYTE PTR [EDX] + XOR ECX, ECX + @@1: + MOV CL, [EDX] // pattern[ i ] INC EDX - MOV CL, BYTE PTR [EAX+Upper] - LODSB - SUB CL, BYTE PTR [EAX+Upper] - JNZ @@fin - CMP AL, CL - JNZ @@1 - @@fin:MOVSX EAX, CL - NEG EAX - POP ESI + MOV CH, [EAX] // str[ i ] + INC EAX + JECXZ @@2 // str = pattern; CL = #0, CH = #0 + CMP CL, 'a' + JB @@cl_ok + CMP CL, 'z' + JA @@cl_ok + SUB CL, 32 + @@cl_ok: + CMP CH, 'a' + JB @@ch_ok + CMP CH, 'z' + JA @@ch_ok + SUB CH, 32 + @@ch_ok: + CMP CL, CH + JE @@1 + @@2: + TEST CL, CL + SETZ AL end; -function StrComp_NoCase1(const Str1, Str2: PAnsiChar): Integer; -begin - Init_Upper; - StrComp_NoCase := @StrComp_NoCase2; - Result := StrComp_NoCase2( Str1, Str2 ); -end; - -function StrLComp_NoCase2(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; +function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; assembler; asm PUSH EDI PUSH ESI PUSH EBX + MOV ESI,EAX MOV EDI,EDX - XCHG ESI,EAX - XOR EBX, EBX - JECXZ @@fin - @@1: MOVZX EAX, BYTE PTR [EDI] - INC EDI - MOV BL, BYTE PTR [EAX+Upper] - LODSB - SUB BL, BYTE PTR [EAX+Upper] - JNZ @@fin - TEST EAX, EAX - JZ @@fin - LOOP @@1 - @@fin:MOVSX EAX, BL + MOV EBX,ECX + XOR AL,AL + TEST ECX,ECX + JZ @@1 + REPNE SCASB + JNE @@1 + INC ECX +@@1: SUB EBX,ECX + MOV EDI,ESI + MOV ESI,EDX + MOV EDX,EDI + MOV ECX,EBX + SHR ECX,2 + REP MOVSD + MOV ECX,EBX + AND ECX,3 + REP MOVSB + STOSB + MOV EAX,EDX POP EBX POP ESI POP EDI end; -function StrLComp_NoCase1(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -begin - Init_Upper; - StrComp_NoCase := @StrComp_NoCase2; - Result := StrLComp_NoCase2( Str1, Str2, MaxLen ); +function StrComp(const Str1, Str2: PAnsiChar): Integer; assembler; // by Aleksandr Sharahov +asm + sub edx, eax + jnz @next + xor eax, eax + jmp @ret +@next: + movzx ecx, [eax+edx] + cmp cl, [eax] + jne @stop + test cl, cl + jz @stop + movzx ecx, [eax+edx+1] + cmp cl, [eax+1] + jne @stop1 + test cl, cl + jz @stop1 + movzx ecx, [eax+edx+2] + cmp cl, [eax+2] + jne @stop2 + test cl, cl + jz @stop2 + movzx ecx, [eax+edx+3] + cmp cl, [eax+3] + jne @stop3 + add eax, 4 + test cl, cl + jz @stop4 + movzx ecx, [eax+edx] + cmp cl, [eax] + jne @stop + test cl, cl + jz @stop + movzx ecx, [eax+edx+1] + cmp cl, [eax+1] + jne @stop1 + test cl, cl + jz @stop1 + movzx ecx, [eax+edx+2] + cmp cl, [eax+2] + jne @stop2 + test cl, cl + jz @stop2 + movzx ecx, [eax+edx+3] + cmp cl, [eax+3] + jne @stop3 + add eax, 4 + test cl, cl + jnz @next +@stop4: + sub eax, 4 +@stop3: + add eax, 1 +@stop2: + add eax, 1 +@stop1: + add eax, 1 +@stop: + movzx eax, [eax] + sub eax, ecx +@ret: end; -{$ENDIF} -function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; assembler; +function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; +asm + CMP BYTE PTR [IsUpperInit], $00 //dufa + JNZ @@Start //dufa + +@@Upper: //dufa + PUSH Str1 //dufa + PUSH Str2 //dufa + CALL Init_Upper //dufa + POP Str2 //dufa + POP Str1 //dufa + +@@Start: + PUSH EBX //dufa + PUSH ESI + XCHG ESI, EAX + +@@1: + MOVZX EAX, BYTE PTR [EDX] + INC EDX + MOVZX ECX, BYTE PTR [EAX+Upper] //dufa + //MOV CL, BYTE PTR [EAX+Upper] //dufa + LODSB + //SUB CL, BYTE PTR [EAX+Upper] //dufa + MOVZX EBX, BYTE PTR [EAX+Upper] //dufa + SUB ECX, EBX //dufa + JNZ @@fin + CMP AL, CL + JNZ @@1 + +@@fin: + //MOVSX EAX, CL //dufa + MOV EAX, ECX //dufa + NEG EAX + POP ESI + POP EBX //dufa +end; + +function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; assembler; // by SysUtils asm PUSH EDI PUSH ESI @@ -19295,9 +18506,48 @@ asm POP ESI POP EDI end; -{$ENDIF PAS_ONLY} -{$IFNDEF PAS_ONLY} +function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; +asm + CMP BYTE PTR [IsUpperInit], $00 //dufa + JNZ @@Start //dufa + +@@Upper: //dufa + PUSH Str1 //dufa + PUSH Str2 //dufa + PUSH MaxLen //dufa + CALL Init_Upper //dufa + POP MaxLen //dufa + POP Str2 //dufa + POP Str1 //dufa + +@@Start: + PUSH EDI + PUSH ESI + PUSH EBX + MOV EDI, Str1//EDX //dufa + XCHG ESI, Str2//EAX //dufa + XOR EBX, EBX + JECXZ @@fin + +@@1: + MOVZX EAX, BYTE PTR [EDI] + INC EDI + MOV BL, BYTE PTR [EAX+Upper] + LODSB + SUB BL, BYTE PTR [EAX+Upper] + JNZ @@fin + TEST EAX, EAX + JZ @@fin + LOOP @@1 + +@@fin: + MOVSX EAX, BL + POP EBX + POP ESI + POP EDI +end; + function StrLen(const Str: PAnsiChar): Cardinal; assembler; asm XCHG EAX, EDI @@ -19313,11 +18563,6 @@ asm @@exit0: MOV EDI,EDX end; -{$ELSE} -function StrLen(const Str: PAnsiChar): Cardinal; -begin - Result := Length(Str); -end; {$ENDIF} {$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal @@ -19490,47 +18735,6 @@ begin end; {$ENDIF ASM_UNICODE} -{$IFDEF PAS_ONLY} -function StrIsStartingFromNoCase( Str, Pattern: PAnsiChar ): Boolean; -begin - Result := FALSE; - while (Str^ <> #0) and (Pattern^ <> #0) do begin - if Str^ <> Pattern^ then Exit; - inc(Str^); - inc(Pattern^); - end; - Result := Pattern^ = #0; -end; -{$ELSE} -function StrIsStartingFromNoCase( Str, Pattern: PAnsiChar ): Boolean; -asm - XOR ECX, ECX - @@1: - MOV CL, [EDX] // pattern[ i ] - INC EDX - MOV CH, [EAX] // str[ i ] - INC EAX - JECXZ @@2 // str = pattern; CL = #0, CH = #0 - CMP CL, 'a' - JB @@cl_ok - CMP CL, 'z' - JA @@cl_ok - SUB CL, 32 - @@cl_ok: - CMP CH, 'a' - JB @@ch_ok - CMP CH, 'z' - JA @@ch_ok - SUB CH, 32 - @@ch_ok: - CMP CL, CH - JE @@1 - @@2: - TEST CL, CL - SETZ AL -end; -{$ENDIF PAS_ONLY} - {$IFNDEF _FPC}{ TODO -odmiko : format for fpc } {$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal function Format( const fmt: KOLString; params: array of const): KOLString; @@ -19555,62 +18759,6 @@ begin FreeMem( ElsArray ); end; {$ENDIF PAS_VERSION} - -function LStrFromPWCharLen(Source: PWideChar; Length: Integer): AnsiString; -var - DestLen: Integer; - Buffer: array[0..2047] of AnsiChar; -begin - if Length <= 0 then begin - Result := ''; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if Length < SizeOf(Buffer) div 2 then begin - DestLen := WideCharToMultiByte(0, 0, Source, Length, - Buffer, SizeOf(Buffer), nil, nil); - if DestLen > 0 then begin - Result := Buffer; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil); - SetLength( Result, DestLen ); - WideCharToMultiByte(0, 0, Source, Length, Pointer(Result), DestLen, nil, nil); -end; - -{$IFDEF PAS_ONLY} -function LStrFromPWChar(Source: PWideChar): AnsiString; -begin - Result := AnsiString(WideString(Source)); -end; -{$ELSE} -function LStrFromPWChar(Source: PWideChar): AnsiString; -{* from Delphi5 - because D2 does not contain it. } -asm - PUSH EDX - XOR EDX,EDX - TEST EAX,EAX - JE @@5 - PUSH EAX -@@0: CMP DX,[EAX+0] - JE @@4 - CMP DX,[EAX+2] - JE @@3 - CMP DX,[EAX+4] - JE @@2 - CMP DX,[EAX+6] - JE @@1 - ADD EAX,8 - JMP @@0 -@@1: ADD EAX,2 -@@2: ADD EAX,2 -@@3: ADD EAX,2 -@@4: XCHG EDX,EAX - POP EAX - SUB EDX,EAX - SHR EDX,1 -@@5: POP ECX - JMP LStrFromPWCharLen -end; -{$ENDIF PAS_ONLY} {$ENDIF not_FPC} function WCharIn( C: KOLChar; const Chars: array of KOLChar ): Boolean; @@ -19748,7 +18896,6 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF ASM_VERSION_no}{$ELSE PAS_VERSION} //Pascal function File2Str(Handle: THandle): AnsiString; var Pos, Size: DWORD; begin @@ -19759,7 +18906,6 @@ begin SetString( Result, nil, Size - Pos ); FileRead( Handle, Result[ 1 ], Size - Pos ); end; -{$ENDIF PAS_VERSION} function File2WStr(Handle: THandle): KOLWideString; var Pos, Size: DWORD; @@ -19773,99 +18919,6 @@ begin Result[ Length(Result) ] := #0; // fixed by zhoudi end; -{$IFDEF ASM_noVERSION_UNICODE} -function FileFullPath( const FileName: AnsiString ) : AnsiString; -const - BkSlash: AnsiString = '\'; - szTShFileInfo = sizeof( TShFileInfo ); -asm - PUSH EBX - PUSH ESI - MOV EBX, EDX - PUSH EAX - - XCHG EAX, EDX - CALL System.@LStrClr - - POP EDX - PUSH 0 - MOV EAX, ESP - CALL System.@LStrAsg - MOV ESI, ESP - -@@loo: CMP dword ptr [ESI], 0 - JZ @@fin - - MOV EAX, ESI - MOV EDX, [BkSlash] - PUSH 0 - MOV ECX, ESP - CALL Parse - - CMP dword ptr [EBX], 0 - JE @@1 - MOV EAX, EBX - MOV EDX, [BkSlash] - CALL System.@LStrCat - JMP @@2 -@@1: - POP EAX - PUSH EAX - CALL System.@LStrLen - CMP EAX, 2 - JNE @@2 - POP EAX - PUSH EAX - CMP byte ptr [EAX+1], ':' - JNE @@2 - - MOV EAX, EBX - POP EDX - PUSH EDX - CALL System.@LStrAsg - JMP @@3 -@@2: - PUSH 0 - MOV EAX, ESP - MOV EDX, [EBX] - CALL System.@LStrAsg - MOV EAX, ESP - MOV EDX, [ESP+4] - CALL System.@LStrCat - POP EAX - PUSH EAX - SUB ESP, szTShFileInfo - MOV EDX, ESP - PUSH SHGFI_DISPLAYNAME - PUSH szTShFileInfo - PUSH EDX - PUSH 0 - PUSH EAX - CALL ShGetFileInfo - LEA EDX, [ESP].TShFileInfo.szDisplayName - CMP byte ptr [EDX], 0 - JE @@clr_stk - LEA EAX, [ESP+szTShFileInfo+4] - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar -@@clr_stk: - ADD ESP, szTShFileInfo - CALL RemoveStr - POP EDX - PUSH EDX - MOV EAX, EBX - CALL System.@LStrCat - -@@3: CALL RemoveStr - JMP @@loo - -@@fin: CALL RemoveStr - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal function FileFullPath( const FileName: KOLString ) : KOLString; var SFI: TShFileInfo; Src, S: KOLString; @@ -19890,8 +18943,6 @@ begin // in the Explorer: Result := Result + ExtractFileExt( FileName ); end; -{$ENDIF PAS_VERSION} - function FileShortPath( const FileName: KOLString ): KOLString; var Buf: array[ 0..MAX_PATH ] of KOLChar; @@ -19936,12 +18987,9 @@ end; function StrLoadFromFile( const Filename: KOLString ): AnsiString; var F: THandle; begin - - if KOLLowerCase(Filename) = 'con' then + if {KOLLowerCase}(Filename) = 'con' then Result := File2Str(GetStdHandle(STD_INPUT_HANDLE)) - else - - begin + else begin Result := ''; F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite ); if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} @@ -19974,7 +19022,7 @@ var F: THandle; begin //if StrEq( Filename, 'CON' ) then - if KOLLowerCase(Filename) = 'con' then + if {KOLLowerCase}(Filename) = 'con' then Result := File2WStr(GetStdHandle(STD_INPUT_HANDLE)) else @@ -20401,19 +19449,18 @@ end; function ReplaceExt( const Path, NewExt: KOLString ): KOLString; begin - Result := ExtractFilePath( Path ) + ExtractFileNameWOext( Path ) + - NewExt; + Result := ExtractFilePath( Path ) + ExtractFileNameWOext( Path ) + NewExt; end; {$ENDIF} function ForceDirectories(Dir: KOLString): Boolean; begin - Result := Length(Dir) > 0; {Centronix} - If not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Dir := ExcludeTrailingPathDelimiter(Dir); - If (Length(Dir) < 3) or DirectoryExists(Dir) or - (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. {>>>>>>>>>} - Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir); + Result := Length(Dir) > 0; {Centronix} + if not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + Dir := ExcludeTrailingPathDelimiter(Dir); + if (Length(Dir) < 3) or DirectoryExists(Dir) or + (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. {>>>>>>>>>} + Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir); end; function CreateDir(const Dir: KOLString): Boolean; @@ -20425,9 +19472,9 @@ function ChangeFileExt(FileName: KOLString; const Extension: KOLString): KOLStri var FileExt: KOLString; begin - FileExt := ExtractFileExt(FileName); - DeleteTail(FileName, Length(FileExt)); - Result := FileName+ Extension; + FileExt := ExtractFileExt(FileName); + DeleteTail(FileName, Length(FileExt)); + Result := FileName + Extension; end; function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString; @@ -20702,9 +19749,7 @@ begin end; { TDirList } -{$IFDEF SPEED_FASTER} - {$DEFINE DIRLIST_FASTER} -{$ENDIF} + function NewDirList( const DirPath, Filter: KOLString; Attr: DWORD ): PDirList; begin New( Result, Create ); @@ -20733,12 +19778,7 @@ end; function TDirList.Get(Idx: Integer): PFindFileData; begin - {$IFDEF DIRLIST_FASTER} Result := FListPositions.Items[ Idx ]; - {$ELSE} - Result := Pointer( PAnsiChar( fStoreFiles.fMemory ) - + PtrUInt( FListPositions.Items[ Idx ] ) ); - {$ENDIF} end; {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal @@ -20775,113 +19815,6 @@ begin Result := LongBool( Items[ Idx ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY ); end; -{$IFDEF ASM_noVERSION} -function TDirList.SatisfyFilter(FileName: PAnsiChar; FileAttr, FindAttr: DWord): Boolean; -asm - PUSH EBX - PUSH ESI - PUSH EDI - XCHG EBX, EAX // EBX = @ Self - MOV EAX, [FindAttr] - MOV EDI, EDX // EDI = FileName - MOV EDX, EAX - AND EDX, ECX - CMP EDX, EAX - JE @@1 - - TEST AL, FILE_ATTRIBUTE_NORMAL - JZ @@ret_false -@@1: - CMP word ptr [EDI], '.' - JE @@1_1 - CMP word ptr [EDI], '..' - JNE @@1_1 - CMP byte ptr [EDI+2], 0 - JNE @@1_1 -@@1_0: - MOV ECX, [FindAttr] - TEST CL, FILE_ATTRIBUTE_NORMAL - JZ @@1_1 - CMP ECX, FILE_ATTRIBUTE_NORMAL - JE @@1_1 - TEST AL, FILE_ATTRIBUTE_DIRECTORY - JZ @@1_1 - TEST CL, FILE_ATTRIBUTE_DIRECTORY - JNZ @@ret_true - -@@1_1: - MOV ECX, [EBX].fFilters - JECXZ @@ret_false //? - - MOV ESI, [ECX].TStrList.fList - MOV ESI, [ESI].TList.fItems - MOV ECX, [ECX].TStrList.fCount - JECXZ @@ret_false - -@@2: - LODSD - TEST EAX, EAX - JZ @@nx_filter - - PUSHAD - - MOV EDX, [EAX] - CMP DX, $002E - JE @@F_d_dd - AND EDX, $FFFFFF - CMP EDX, $002E2E - JE @@F_d_dd - - MOV EDX, [EDI] - CMP DX, $002E - JE @@4 - AND EDX, $FFFFFF - CMP EDX, $002E2E - JE @@4 - JMP @@chk_anti - -@@F_d_dd: - MOV EDX, EDI - PUSH EAX - CALL StrComp - TEST EAX, EAX - POP EAX - JZ @@popad_ret_true - -@@chk_anti: - XCHG EDX, EAX // EDX = filter[ i ] - MOV EAX, EDI // EAX = FileName - CMP byte ptr [EDX], '^' - JNE @@3 - - INC EDX - CALL _2StrSatisfy - TEST AL, AL - JZ @@4 - POPAD - JMP @@ret_false - -@@3: CALL _2StrSatisfy - TEST AL, AL - JZ @@4 -@@popad_ret_true: - POPAD -@@ret_true: - MOV AL, 1 - JMP @@exit - -@@4: POPAD -@@nx_filter: - LOOP @@2 - -@@ret_false: - XOR EAX, EAX -@@exit: - POP EDI - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal function TDirList.SatisfyFilter(FileName: PKOLChar; FileAttr, FindAttr: DWord): Boolean; var I: Integer; F: PKOLChar; @@ -20919,157 +19852,7 @@ begin Result := HasOnlyNegFilters and not dots; end; -{$ENDIF PAS_VERSION} -{$IFDEF ASM_nononoVERSION} -procedure TDirList.ScanDirectory(const DirPath, Filter: KOLString; Attr: DWord); -const sz_win32finddata = sizeof(TWin32FindData); -asm - PUSH EBX - PUSH EDI - MOV EBX, EAX - - PUSHAD - CALL Clear - CALL NewList - MOV [EBX].fList, EAX - POPAD - - PUSHAD - LEA EAX, [EBX].fPath - CALL System.@LStrAsg - POPAD - - MOV EAX, [EBX].fPath - TEST EAX, EAX - JE @@exit - - PUSHAD - LEA EDX, [EBX].fPath - MOV EAX, [EDX] - CALL IncludeTrailingPathDelimiter - - MOV EAX, [EBX].fFilters - TEST EAX, EAX - JNZ @@1 - CALL NewStrList - MOV [EBX].fFilters, EAX - POPAD - - PUSHAD - PUSH ECX - XCHG EAX, ECX - MOV EDX, offset[@@star_d_star] - CALL StrComp - TEST AL, AL - POP EDX - JNZ @@asg_Filter - MOV EDX, offset[@@star] -@@asg_Filter: - MOV EAX, [EBX].fFilters - CALL TStrList.Add - JMP @@1 - -@@star_d_star: - DB '*.*', 0 // PCHAR - - {$IFDEF _D2009orHigher} - DW 0, 1 - {$ENDIF} - DD -1, 1 -@@star: DB '*', 0 - -@@1: - POPAD - - ADD ESP, -sz_win32finddata - XOR EDX, EDX - PUSH EDX - PUSH EDX - XCHG EAX, ECX - MOV EDX, ESP - CALL FindFilter - - LEA EAX, [ESP+4] - MOV EDX, [EBX].fPath - POP ECX - PUSH ECX - CALL System.@LStrCat3 - CALL RemoveStr - - POP EAX - MOV EDX, ESP - PUSH EAX - PUSH EDX - PUSH EAX - CALL FindFirstFile - MOV EDI, EAX - INC EAX - MOV EAX, ESP - - PUSHFD - CALL System.@LStrClr - POPFD - POP ECX - - JZ @@fin - -@@loop: - MOV ECX, [ESP].TWin32FindData.dwFileAttributes - PUSH [Attr] - LEA EDX, [ESP+4].TWin32FindData.cFileName - MOV EAX, EBX - CALL SatisfyFilter - - TEST AL, AL - JZ @@next - - MOV ECX, [EBX].fOnItem.TMethod.Code - JECXZ @@accept - MOV EAX, [EBX].fOnItem.TMethod.Data - MOV ECX, ESP - PUSH 1 - MOV EDX, ESP - PUSH EDX - MOV EDX, EBX - CALL dword ptr [EBX].fOnItem.TMethod.Code - POP ECX - JECXZ @@next - LOOP @@fin - -@@accept: - MOV EAX, sz_win32finddata - PUSH EAX - CALL System.@GetMem - PUSH EAX - XCHG EDX, EAX - MOV EAX, [EBX].fList - CALL TList.Add - POP EDX - POP ECX - MOV EAX, ESP - CALL System.Move - -@@next: - PUSH ESP - PUSH EDI - CALL FindNextFile - TEST EAX, EAX - JNZ @@loop - - PUSH EDI - CALL FindClose - -@@fin: - ADD ESP, sz_win32finddata -@@exit: - XOR EAX, EAX - XCHG EAX, [EBX].fFilters - CALL TObj.Free - POP EDI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal procedure TDirList.ScanDirectory(const DirPath, Filter: KOLString; Attr: DWord); var FindData : TFindFileData; @@ -21078,11 +19861,9 @@ var FindData : TFindFileData; IsUnicode: KOLString; {$ENDIF} {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - {$IFDEF DIRLIST_OPTIMIZE_ASCII} - P: PKOLChar; - {$ENDIF} - {$ENDIF} + {$IFDEF DIRLIST_OPTIMIZE_ASCII} + P: PKOLChar; + {$ENDIF} {$ENDIF} begin Clear; @@ -21116,37 +19897,25 @@ begin diAccept: begin if fStoreFiles = nil then begin - {$IFDEF DIRLIST_FASTER} fStoreFiles := NewMemBlkStream_WriteOnly( 32 * Sizeof( FindData ) ); - {$ELSE} - fStoreFiles := NewMemoryStream( ); - fStoreFiles.Capacity := 64 * Sizeof( FindData ); - {$ENDIF} end; - {$IFDEF DIRLIST_FASTER}{$ELSE} - FListPositions.Add( Pointer( fStoreFiles.Position ) ); - {$ENDIF} {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - {$IFDEF DIRLIST_OPTIMIZE_ASCII} - FindData.dwReserved0 := 0; - P := @ FindData.cFileName[0]; - while P^ <> #0 do - begin - if PWord( P )^ > 255 then - begin - inc( FindData.dwReserved0 ); - break; - end; - inc( P ); - end; - {$ENDIF} - {$ENDIF} + {$IFDEF DIRLIST_OPTIMIZE_ASCII} + FindData.dwReserved0 := 0; + P := @ FindData.cFileName[0]; + while P^ <> #0 do + begin + if PWord( P )^ > 255 then + begin + inc( FindData.dwReserved0 ); + break; + end; + inc( P ); + end; + {$ENDIF} {$ENDIF} fStoreFiles.Write( FindData, Sizeof( FindData ) ); - {$IFDEF DIRLIST_FASTER} FListPositions.Add( fStoreFiles.fData.fJustWrittenBlkAddress ); - {$ENDIF} end; diCancel: break; END; @@ -21156,14 +19925,7 @@ begin Find_Close( FindData ); end; Free_And_Nil(fFilters); //D[u]fa - {$IFnDEF SPEED_FASTER} - if fStoreFiles <> nil then begin - fStoreFiles.fData.fCapacity := 0; - fStoreFiles.Size := fStoreFiles.Position; - end; - {$ENDIF} end; -{$ENDIF PAS_VERSION} {$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal procedure TDirList.ScanDirectoryEx(const DirPath, Filters: KOLString; Attr: DWord); @@ -21219,7 +19981,6 @@ begin S2 := Item2.cFileName; if not Data.CaseSensitive then begin {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} {$IFDEF DIRLIST_OPTIMIZE_ASCII} if Item1.dwReserved0 or Item2.dwReserved1 = 0 then begin //// ATTANTION: _AnsiCompareStrNoCaseA( '', '' ); must be called before sort! @@ -21235,7 +19996,6 @@ begin Result := _AnsiCompareStr( Item1.cFileName, Item2.cFileName ); end else {$ENDIF} - {$ENDIF} begin W1 := S1; W2 := S2; @@ -21302,93 +20062,10 @@ procedure SwapDirItems( Data : PSortDirData; const e1, e2 : DWORD ); forward; {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} procedure SwapDirItems( Data : PSortDirData; const e1, e2 : DWORD ); begin - Data.Dir.FListPositions.Swap( e1, e2 ); + Data.Dir.FListPositions.Swap( e1, e2 ); end; {$ENDIF PAS_VERSION} -{$IFDEF noASM_VERSION} -procedure TDirList.Sort(Rules: array of TSortDirRules); -const high_DefSortDirRules = High( DefSortDirRules ); -asm - PUSH EBX - PUSH ESI - XOR EBX,EBX - CMP [EAX].FListPositions, EBX - JE @@exit - - PUSH EAX // prepare Dir = @Self - XOR EAX, EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EAX - MOV ESI, ESP - INC ECX // ECX = High(Rules) - JZ @@2 -@@1: MOV AH, [EDX] // AH = Rules[ I ] - INC EDX - CALL @@add_rule - LOOP @@1 -@@2: LEA EDX, [DefSortDirRules] - MOV CL, high_DefSortDirRules + 1 -@@21: MOV AH, [EDX] - INC EDX - CALL @@add_rule - LOOP @@21 - - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - MOV EAX, offset[@@emptyStr] - MOV EDX, EAX - CALL dword ptr [_AnsiCompareStrNoCaseA] - {$ENDIF} - {$ENDIF} - PUSH BX // prepare FoldersFirst(BL), CaseSensitive(BH) - MOV EBX, [ESP].TSortDirData.Dir - MOV EAX, ESP - PUSH BX - PUSH offset[SwapDirItems] - MOV ECX, offset[CompareDirItems] - MOV EDX, [EBX].FListPositions - MOV EDX, [EDX].TList.fCount - CALL SortData - - ADD ESP, 20 - JMP @@exit - - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} -@@emptyStr: - DW 0 - {$ENDIF} - {$ENDIF} -@@add_rule: - PUSH ESI - PUSH ECX - MOV CL, 11 -@@a1: LODSB - TEST AL, AL - JZ @@a2 - CMP AL, AH - JE @@a3 - LOOP @@a1 -@@a2: DEC ESI - MOV [ESI], AH - CMP AH, sdrFoldersFirst - JNE @@a4 - INC BL -@@a4: CMP AH, sdrCaseSensitive - JNE @@a3 - INC BH -@@a3: POP ECX - POP ESI - RET - -@@exit: - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal procedure TDirList.Sort(Rules: array of TSortDirRules); var SortDirData : TSortDirData; I, J : Integer; @@ -21413,9 +20090,7 @@ var SortDirData : TSortDirData; SortDirData.InvertSortOrder := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} end; - {$IFDEF SAFE_CODE} if J > High( SortDirData.Rules ) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} if RulePresent( Rule ) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} SortDirData.Rules[ J ] := Rule; Inc( J ); @@ -21431,15 +20106,12 @@ begin SortDirData.CountRules := J; SortDirData.Dir := @Self; {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - _AnsiCompareStrNoCaseA( '', '' ); - {$ENDIF} + _AnsiCompareStrNoCaseA( '', '' ); {$ENDIF} SortData( Pointer( @SortDirData ), FListPositions.fCount, @CompareDirItems, @SwapDirItems ); end; -{$ENDIF PAS_VERSION} -function TDirList.FileList(const Separator: KOLString; Dirs, - FullPaths: Boolean): KOLString; + +function TDirList.FileList(const Separator: KOLString; Dirs, FullPaths: Boolean): KOLString; var I: Integer; begin Result := ''; @@ -21458,74 +20130,50 @@ end; procedure TDirList.AddItem(FindData: PFindFileData); begin - if fStoreFiles = nil then begin - {$IFDEF DIRLIST_FASTER} - fStoreFiles := NewMemBlkStream_WriteOnly( 32 * Sizeof( FindData ) ); - {$ELSE} - fStoreFiles := NewMemoryStream( ); - fStoreFiles.Capacity := 64 * Sizeof( FindData ); - {$ENDIF} - FListPositions := NewList; + if fStoreFiles = nil then begin + fStoreFiles := NewMemBlkStream_WriteOnly( 32 * Sizeof( FindData ) ); + FListPositions := NewList; + end; + {$IFDEF UNICODE_CTRLS} + {$IFDEF DIRLIST_OPTIMIZE_ASCII} + FindData.dwReserved0 := 0; + P := @ FindData.cFileName[0]; + while P^ <> #0 do + begin + if PWord( P )^ > 255 then begin + inc( FindData.dwReserved0 ); + break; + end; + inc( P ); end; - {$IFDEF DIRLIST_FASTER}{$ELSE} - FListPositions.Add( Pointer( fStoreFiles.Position ) ); - {$ENDIF} - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - {$IFDEF DIRLIST_OPTIMIZE_ASCII} - FindData.dwReserved0 := 0; - P := @ FindData.cFileName[0]; - while P^ <> #0 do - begin - if PWord( P )^ > 255 then begin - inc( FindData.dwReserved0 ); - break; - end; - inc( P ); - end; - {$ENDIF} - {$ENDIF} - {$ENDIF} - fStoreFiles.Write( FindData^, Sizeof( FindData^ ) ); - {$IFDEF DIRLIST_FASTER} - FListPositions.Add( fStoreFiles.fData.fJustWrittenBlkAddress ); {$ENDIF} + {$ENDIF} + fStoreFiles.Write( FindData^, Sizeof( FindData^ ) ); + FListPositions.Add( fStoreFiles.fData.fJustWrittenBlkAddress ); end; procedure TDirList.InsertItem(idx: Integer; FindData: PFindFileData); begin - if fStoreFiles = nil then begin - {$IFDEF DIRLIST_FASTER} - fStoreFiles := NewMemBlkStream_WriteOnly( 32 * Sizeof( FindData ) ); - {$ELSE} - fStoreFiles := NewMemoryStream( ); - fStoreFiles.Capacity := 64 * Sizeof( FindData ); - {$ENDIF} - FListPositions := NewList; + if fStoreFiles = nil then begin + fStoreFiles := NewMemBlkStream_WriteOnly( 32 * Sizeof( FindData ) ); + FListPositions := NewList; + end; + {$IFDEF UNICODE_CTRLS} + {$IFDEF DIRLIST_OPTIMIZE_ASCII} + FindData.dwReserved0 := 0; + P := @ FindData.cFileName[0]; + while P^ <> #0 do + begin + if PWord( P )^ > 255 then begin + inc( FindData.dwReserved0 ); + break; + end; + inc( P ); end; - {$IFDEF DIRLIST_FASTER}{$ELSE} - FListPositions.Insert( idx, Pointer( fStoreFiles.Position ) ); - {$ENDIF} - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - {$IFDEF DIRLIST_OPTIMIZE_ASCII} - FindData.dwReserved0 := 0; - P := @ FindData.cFileName[0]; - while P^ <> #0 do - begin - if PWord( P )^ > 255 then begin - inc( FindData.dwReserved0 ); - break; - end; - inc( P ); - end; - {$ENDIF} - {$ENDIF} - {$ENDIF} - fStoreFiles.Write( FindData^, Sizeof( FindData^ ) ); - {$IFDEF DIRLIST_FASTER} - FListPositions.Insert( idx, fStoreFiles.fData.fJustWrittenBlkAddress ); {$ENDIF} + {$ENDIF} + fStoreFiles.Write( FindData^, Sizeof( FindData^ ) ); + FListPositions.Insert( idx, fStoreFiles.fData.fJustWrittenBlkAddress ); end; //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv @@ -21593,8 +20241,7 @@ begin end; {$ENDIF} function RegKeyGetStrEx( Key: HKey; const ValueName: KOLString - {$IFDEF OPTIONAL_REG_EXPAND_SZ} ; ExpandEnvVars: Boolean {$ENDIF} ): -KOLString; + {$IFDEF OPTIONAL_REG_EXPAND_SZ} ; ExpandEnvVars: Boolean {$ENDIF} ): KOLString; var dwType, dwSize: DWORD; Buffer, Buffer2: PKOLChar; Sz: Integer; @@ -21718,83 +20365,35 @@ begin Result := RegKeySetBinary( Key, ValueName, DateTime, Sizeof( DateTime ) ); end; -{$IFDEF OLD_REGKEYGETSUBKEYS} -//----------------------------------------------- -// functions by Valerian Luft -//----------------------------------------------- -function RegKeyGetSubKeys( const Key: HKEY; List: PKOLStrList) : Boolean; -var - I, Size, NumSubKeys, MaxSubKeyLen : DWORD; - KeyName: KOLString; -begin - Result := False; - List.Clear ; - if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, @MaxSubKeyLen, nil, nil, nil, nil, -nil, nil) = ERROR_SUCCESS then begin - if NumSubKeys > 0 then begin - for I := 0 to NumSubKeys-1 do begin - Size := MaxSubKeyLen+1; - SetLength(KeyName, Size); - RegEnumKeyEx(Key, I, @KeyName[1], Size, nil, nil, nil, nil); - KeyName := Trim(KeyName); // fixed by Jon - List.Add(KeyName); - end; - end; - Result:= True; - end; -end; -{$ELSE} // new (faster) version by Alex Shyshko (Psychedelic) +// new (faster) version by Alex Shyshko (Psychedelic) function RegKeyGetSubKeys(const Key: HKEY; List: PKOLStrList) : Boolean; var i, MaxSubKeyLen, Size: DWORD; Buf: PKOLChar; begin - Result:=false; - List.Clear; + Result:=false; + List.Clear; - if RegQueryInfoKey(Key, nil, nil, nil, nil, @MaxSubKeyLen, nil, nil, nil, nil, - nil, nil) = ERROR_SUCCESS then begin - if MaxSubKeyLen > 0 then begin + if RegQueryInfoKey(Key, nil, nil, nil, nil, @MaxSubKeyLen, nil, nil, nil, nil, + nil, nil) = ERROR_SUCCESS then begin + if MaxSubKeyLen > 0 then begin Size:=MaxSubKeyLen + 1; // GetMem(Buf,Size*Sizeof(KOLChar)); // fixed by Jon i:=0; while RegEnumKeyEx(Key,i,buf,Size,nil,nil,nil,nil) <> ERROR_NO_MORE_ITEMS do begin - List.Add(KOLString(Buf)); - Size:=MaxSubKeyLen + 1; - inc(i); + List.Add(KOLString(Buf)); + Size:=MaxSubKeyLen + 1; + inc(i); end; FreeMem(Buf{,MaxSubKeyLen + 1}); end; // if MaxSubKeyLen - Result:=true; + Result:=true; end; // if RegQueryInfoKey +end; -end; -{$ENDIF} -{$IFDEF OLD_REGKEYGETVALUENAMES} -function RegKeyGetValueNames(const Key: HKEY; List: PKOLStrList): Boolean; -var - I, Size, NumSubKeys, NumValueNames, MaxValueNameLen: DWORD; - ValueName: KOLString; -begin - List.Clear ; - Result:=False; - if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, nil, nil, @NumValueNames, -@MaxValueNameLen, nil, nil, nil) = ERROR_SUCCESS then begin - if NumValueNames > 0 then - for I := 0 to NumValueNames - 1 do begin - Size := MaxValueNameLen + 1; - SetLength(ValueName, Size); - //FillChar(ValueName[1],Size,#0); - RegEnumValue(Key, I, @ValueName[1], Size, nil, nil, nil, nil); - ValueName := Trim(ValueName); - List.Add(ValueName); - end; - Result := True; - end ; -end; -{$ELSE} // new (faster) version by Alex Shyshko (Psychedelic) +// new (faster) version by Alex Shyshko (Psychedelic) function RegKeyGetValueNames(const Key: HKEY; List: PKOLStrList) : Boolean; var i, MaxValueNameLen, Size: DWORD; @@ -21819,9 +20418,8 @@ begin end; // if MaxValueNameLen Result:=true; end; // if RegQueryInfoKey - end; -{$ENDIF} + function RegKeyGetValueTyp (const Key:HKEY; const ValueName: KOLString) : DWORD; begin Result:= Key ; @@ -22042,7 +20640,7 @@ end; {$UNDEF ASM_LOCAL} {$IFDEF ASM_VERSION} {$IFDEF DATE0_0001} - {$DEFINE ASM_LOCAL} +{$DEFINE ASM_LOCAL} {$ENDIF DATE0_0001} {$ENDIF PAS_VERSION} {$IFDEF ASM_LOCAL} @@ -22588,7 +21186,7 @@ var Buff: Array[0..1] of KOLChar; begin if DateSeparator = #0 then begin - if GetLocaleInfo(GetThreadLocale,LOCALE_SDATE,Buff,2) > 0 then + if GetLocaleInfo(GetThreadLocale, LOCALE_SDATE, Buff, 2) > 0 then DateSeparator := Buff[0]; end; if Pos(KOLString(DateSeparator),S) = 0 then @@ -22603,15 +21201,21 @@ end; /////////////////////////////////////////////////////////////////////// { -- Thread -- } -function ThreadFunc(Thread: PThread): integer; stdcall; + +function ThreadFunc(Thread: PThread): Integer; stdcall; begin Result := Thread.Execute; end; +function ThreadFuncPascal(Thread: Pointer): Integer; +begin + Result := PThread(Thread).Execute; +end; + function NewThread: PThread; begin {$IFNDEF FPC105ORBELOW} - IsMultiThread := True; + //dufa: in BeginThread -> IsMultiThread := True; {$ENDIF} New( Result, Create ); {$IFDEF DEBUG_OBJKIND} @@ -22620,12 +21224,19 @@ begin Result.FSuspended := True; {$IFDEF PSEUDO_THREADS} {$ELSE} - Result.FHandle := CreateThread( nil, // no security - 0, // the same stack size - @ThreadFunc, // thread entry point - Result, // parameter to pass to ThreadFunc - CREATE_SUSPENDED, // always SUSPENDED - Result.FThreadID ); // receive thread ID +///dufa: use std BeginThread for catch exception 02.12.2019 beta +// Result.FHandle := CreateThread( nil, // no security +// 0, // the same stack size +// @ThreadFunc, // thread entry point +// Result, // parameter to pass to ThreadFunc +// CREATE_SUSPENDED, // always SUSPENDED +// Result.FThreadID ); // receive thread ID + Result.FHandle := BeginThread(nil, // no security + 0, // the same stack size + ThreadFuncPascal, // thread entry point + Result, // parameter to pass to ThreadFunc + CREATE_SUSPENDED, // always SUSPENDED + Result.FThreadID); // receive thread ID {$ENDIF} end; @@ -22641,9 +21252,7 @@ begin Result := NewThread; Result.OnExecute := Proc; Result.F_AutoFree := TRUE; - {$IFDEF SAFE_CODE} if Assigned( Proc ) then - {$ENDIF} Result.Resume; end; @@ -22725,10 +21334,8 @@ function TThread.Execute: integer; var H: THandle; {$ENDIF} begin - {$IFDEF SAFE_CODE} Result := 0; if Assigned( FOnExecute ) then - {$ENDIF} Result := FOnExecute( @Self ); FResult := Result; FTerminated := TRUE; // fake thread object (to prevent terminating while freeing) @@ -22826,10 +21433,8 @@ end; procedure TThread.SwitchToThread(T: PThread); begin - {$IFDEF SAFE_CODE} if (T <> MainThread) and not Assigned( T.OnExecute ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} if Assigned( MainThread.CurrentThread.OnSuspend ) then begin MainThread.CurrentThread.OnExecute( MainThread.CurrentThread ); end; @@ -22948,9 +21553,7 @@ begin end; if Assigned( MainThread ) then MainThread.NextThread; - {$IFDEF WAIT_SLEEP} Sleep( 10 ); - {$ENDIF} end; end; @@ -23061,9 +21664,7 @@ begin begin M := GetModuleHandle( 'kernel32' ); GPB := GetProcAddress( M, 'GetThreadPriorityBoost' ); - {$IFDEF SAFE_CODE} if Assigned( GPB ) then - {$ENDIF} if GPB( fHandle, B ) then Result := B; end; @@ -23079,9 +21680,7 @@ begin if WinVer >= WvNT then begin M := GetModuleHandle( 'kernel32' ); SPB := GetProcAddress( M, 'SetThreadPriorityBoost' ); - {$IFDEF SAFE_CODE} if Assigned( SPB ) then - {$ENDIF} SPB( fHandle, not Value ); end; end; @@ -23428,8 +22027,7 @@ function ReadFileStreamWithEvent( Strm: PStream; var Buffer; const Count: TStrmS begin Result := FileRead( Strm.fData.fHandle, Buffer, Count ); inc( Strm.fData.fPosition, Result ); - if (Result > 0) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then + if (Result > 0) and Assigned( Strm.OnChangePos ) then Strm.OnChangePos( Strm ); end; @@ -23445,8 +22043,7 @@ function WriteFileStreamWithEvent( Strm: PStream; var Buffer; const Count: TStrm begin Result := FileWrite( Strm.fData.fHandle, Buffer, Count ); inc( Strm.fData.fPosition, Result ); - if (Result > 0) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then + if (Result > 0) and Assigned( Strm.OnChangePos ) then Strm.OnChangePos( Strm ); end; @@ -23464,8 +22061,7 @@ begin Result := WriteFileStream( Strm, Buffer, Count ); inc( Strm.fData.fPosition, Result ); SetEndOfFile( Strm.fData.fHandle ); - if (Result > 0) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then + if (Result > 0) and Assigned( Strm.OnChangePos ) then Strm.OnChangePos( Strm ); end; @@ -23496,8 +22092,7 @@ var OldPos: TStrmSize; begin OldPos := Strm.Position; Result := SeekMemStream( Strm, MoveTo, MoveFrom ); - if (OldPos <> Strm.Position) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then + if (OldPos <> Strm.Position) and Assigned( Strm.OnChangePos ) then Strm.OnChangePos( Strm ); end; @@ -23547,8 +22142,7 @@ end; function ReadMemStreamWithEvent( Strm: PStream; var Buffer; const Count: TStrmSize ): TStrmSize; begin Result := ReadMemStream( Strm, Buffer, Count ); - if (Result > 0) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then + if (Result > 0) and Assigned( Strm.OnChangePos ) then Strm.OnChangePos( Strm ); end; @@ -23566,7 +22160,7 @@ end; function WriteMemStreamWithEvent( Strm: PStream; var Buffer; const Count: TStrmSize ): TStrmSize; begin Result := WriteMemStream( Strm, Buffer, Count ); - if (Result > 0) {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then + if (Result > 0) and Assigned( Strm.OnChangePos ) then Strm.OnChangePos( Strm ); end; @@ -23706,13 +22300,9 @@ begin FreeMem( Strm.fData.fBlocks.fItems[i] ); inc( i, 2 ); end; - {$IFDEF SAFE_CODE} Free_And_Nil( Strm.fData.fBlocks ); Strm.fData.fPosition := 0; Strm.fData.fSize := 0; - {$ELSE} - Strm.fData.fBlocks.Free; - {$ENDIF} end; function SeekConcatStream( Strm: PStream; const MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; @@ -23928,27 +22518,6 @@ begin Result.fData.fHandle := WFileCreate( FileName, ofOpenWrite or ofCreateAlways or ofShareDenyWrite ); end; -{$IFDEF ASM_noVERSION} //dufa -function NewReadWriteFileStream( const FileName: AnsiString ): PStream; -asm - PUSH EBX - XCHG EBX, EAX //EBX=Filename - MOV EAX, offset[BaseFileMethods] - CALL _NewStream //EAX=Result - MOV EDX, [ReadFileStreamProc] - MOV [EAX].TStream.fMethods.fRead, EDX - MOV [EAX].TStream.fMethods.fWrite, offset[WriteFileStream] - MOV [EAX].TStream.fMethods.fSetSiz, offset[SetSizeFileStream] - - XCHG EBX, EAX //EBX=Result, EAX=Filename - MOV EDX, ofOpenReadWrite or ofOpenAlways or ofShareDenyWrite - - CALL FileCreate - MOV [EBX].TStream.fData.fHandle, EAX - XCHG EAX, EBX //EAX=Result - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal function NewReadWriteFileStream( const FileName: KOLString ): PStream; begin Result := _NewStream( BaseFileMethods ); @@ -23957,7 +22526,6 @@ begin Result.fMethods.fSetSiz := SetSizeFileStream; Result.fData.fHandle := FileCreate( FileName, ofOpenReadWrite or ofOpenAlways or ofShareDenyWrite ); //dufa end; -{$ENDIF PAS_VERSION} function NewReadWriteFileStreamW( const FileName: KOLWideString ): PStream; var Creation: DWORD; @@ -24239,60 +22807,57 @@ end; // - by Vyacheslav A. Gavrik : const - IniBufferSize = 32767; - IniBufferStrSize = IniBufferSize+4; /// для махинаций :) + IniBufferSize = 64 * 1024 * 1024;// 32767 = dufa: слишком мало + IniBufferStrSize = IniBufferSize + 4; /// для махинаций :) {$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal procedure TIniFile.GetSectionNames(Names: PKOLStrList); var - i:integer; - Pc:PKOLChar; - PcEnd:PKOLChar; - Buffer:Pointer; + i: Integer; + Pc: PKOLChar; + PcEnd: PKOLChar; + Buffer: Pointer; begin GetMem(Buffer,IniBufferSize * Sizeof( KOLChar )); - Pc:=Buffer; - i := GetPrivateProfileSectionNames(Buffer, IniBufferSize, PKOLChar(fFileName)); - PcEnd:=Pc+i; + Pc := Buffer; + i := GetPrivateProfileSectionNames(Buffer, IniBufferSize, PKOLChar(fFileName)); + PcEnd := Pc + i; repeat Names.Add(Pc); - Pc:=PC+Length(PC)+1; - until PC>=PcEnd; - FreeMem(Buffer); -end; - -procedure TIniFile.SectionData(Names: PKOLStrList); -var - i:integer; - Pc:PKOLChar; - PcEnd:PKOLChar; - Buffer:Pointer; -begin - GetMem(Buffer,IniBufferSize * Sizeof(KOLChar)); - Pc:=Buffer; - if fMode = ifmRead then begin - i:=GetPrivateProfileSection(PKOLChar(fSection), Buffer, IniBufferSize, PKOLChar(fFileName)); - PcEnd:=Pc+i; - while PC < PcEnd do // Chg by ECM from REPEAT-UNTIL: i=0 (empty section) => Names.Count=1 - begin - Names.Add(Pc); - Pc:=PC+Length(PC)+1; - end; - end else begin - for i:= 0 to Names.Count-1 do begin - {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF} - (Pc,Names.ItemPtrs[i]); - Pc:=PC+Length(PC)+1; - end; - Pc[0]:=#0; - ClearSection; - WritePrivateProfileSection(PKOLChar(fSection), Buffer, PKOLChar(fFileName)); - - end; + Pc := Pc + Length(PC) + 1; + until (PC >= PcEnd); FreeMem(Buffer); end; {$ENDIF PAS_VERSION} +procedure TIniFile.SectionData(Names: PKOLStrList); +var + i: Integer; + Pc: PKOLChar; + PcEnd: PKOLChar; + Buffer: Pointer; +begin + GetMem(Buffer, IniBufferSize * Sizeof(KOLChar)); + Pc := Buffer; + if (fMode = ifmRead) then begin + i := GetPrivateProfileSection(PKOLChar(fSection), Buffer, IniBufferSize, PKOLChar(fFileName)); + PcEnd := Pc + i; + while (PC < PcEnd) do begin // Chg by ECM from REPEAT-UNTIL: i=0 (empty section) => Names.Count=1 + Names.Add(Pc); + Pc := PC + Length(PC) + 1; + end; + end else begin + for i := 0 to Names.Count - 1 do begin + {$IFDEF UNICODE_CTRLS}WStrCopy{$ELSE}StrCopy{$ENDIF}(Pc, Names.ItemPtrs[i]); + Pc := PC + Length(PC) + 1; + end; + Pc[0] := #0; + ClearSection; + WritePrivateProfileSection(PKOLChar(fSection), Buffer, PKOLChar(fFileName)); + end; + FreeMem(Buffer); +end; + {$IFNDEF UNICODE_CTRLS} function TIniFile.GetSectionNamesStr: KOLString; //dufa var @@ -24672,9 +23237,7 @@ begin end; AParent.fMenuObj := Result; AParent.AttachProc( WndProcMenu ); - {$IFDEF USE_AUTOFREE4CONTROLS} AParent.Add2AutoFree( Result ); - {$ENDIF} end; end; end; @@ -25010,9 +23573,7 @@ begin end; if N > 0 then begin C.fAccelTable := CreateAcceleratorTable( AccTab[ 0 ], N ); - {$IFDEF USE_AUTOFREE4CONTROLS} C.Add2AutoFreeEx( C.DoDestroyAccelTable ); - {$ENDIF} C := C.ParentForm; if C <> nil then C.SupportMnemonics; @@ -25789,7 +24350,6 @@ begin end; { -- Constructors of controls -- } -{$IFDEF COMMANDACTIONS_OBJ} function NewCommandActionsObj: PCommandActionsObj; begin new( Result, Create ); @@ -25840,7 +24400,7 @@ begin end; end; {$ENDIF PAS_VERSION} -{$ENDIF COMMANDACTIONS_OBJ} + function DumpWindowed( c: PControl ): PControl; var P: PByte; i, j: Integer; @@ -25867,15 +24427,12 @@ end; {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar; Ctl3D: Boolean; ACommandActions: TCommandActionsParam ): PControl; -{$IFDEF COMMANDACTIONS_OBJ} var IdxActions: Integer; -{$ENDIF} begin New( Result, CreateParented( AParent ) ); {$IFDEF DEBUG_OBJKIND} Result.fObjKind := 'TControl'; {$ENDIF} - {$IFDEF COMMANDACTIONS_OBJ} if PtrUInt( ACommandActions ) < 120 then IdxActions := PtrInt( ACommandActions ) else @@ -25902,52 +24459,31 @@ begin {$ENDIF} end; Result.Add2AutoFree( Result.fCommandActions ); - {$ELSE} - if ACommandActions <> nil then - Result.fCommandActions := ACommandActions^ - else - Result.fCommandActions.aClear := ClearText; - {$ENDIF} //Result.fWindowed := TRUE; // is set in TControl.Init Result.fControlClassName := ControlClassName; if AParent <> nil then begin - - //{-2.95}Result.PP.fWndProcResizeFlicks := AParent.PP.fWndProcResizeFlicks; - Result.PP.fGotoControl := AParent.PP.fGotoControl; Result.fCtl3D_child := AParent.fCtl3D_child and 2; - if AParent.fCtl3D_child and 2 <> 0 then - Result.fCtl3D_child := Result.fCtl3D_child or Integer( Ctl3D ) and 1 - {else - Result.fCtl3D := False}; // + if AParent.fCtl3D_child and 2 <> 0 then + Result.fCtl3D_child := Result.fCtl3D_child or Integer( Ctl3D ) and 1; Result.fMargin := AParent.fMargin; Result.fTextColor := AParent.fTextColor; - {$IFDEF SMALLEST_CODE} - {$ELSE} // for now Font is complicated a bit, implement it later Result.fFont := Result.fFont.Assign( AParent.fFont ); if Result.fFont <> nil then begin - {$IFDEF USE_AUTOFREE4CONTROLS} Result.Add2AutoFree( Result.fFont ); - {$ENDIF USE_AUTOFREE4CONTROLS} Result.fFont.fParentGDITool := AParent.fFont; Result.fFont.fOnGTChange := Result.FontChanged; Result.FontChanged( Result.fFont ); end; - - {$ENDIF SMALLEST_CODE} Result.fColor := AParent.fColor; - Result.fBrush := Result.fBrush.Assign( AParent.fBrush ); if Result.fBrush <> nil then begin - {$IFDEF USE_AUTOFREE4CONTROLS} Result.Add2AutoFree( Result.fBrush ); - {$ENDIF USE_AUTOFREE4CONTROLS} Result.fBrush.fParentGDITool := AParent.fBrush; Result.fBrush.fOnGTChange := Result.BrushChanged; Result.BrushChanged( Result.fBrush ); end; - end; {$IFDEF DUMP_WINDOWED} DumpWindowed( Result ); @@ -25969,12 +24505,11 @@ begin Result.AttachProc( WndProcForm ); Result.AttachProc( WndProcDoEraseBkgnd ); Result.Caption := Caption; - {$IFDEF USE_FLAGS} Result.fFlagsG3 := Result.fFlagsG3 + [G3_SizeGrip, G3_IsForm]; + {$IFDEF USE_FLAGS} + Result.fFlagsG3 := Result.fFlagsG3 + [G3_SizeGrip, G3_IsForm]; {$ELSE} - {$IFNDEF SMALLEST_CODE} - Result.fSizeGrip := TRUE; - {$ENDIF} - Result.fIsForm := TRUE; + Result.fSizeGrip := TRUE; + Result.fIsForm := TRUE; {$ENDIF} end; {$ENDIF PAS_VERSION} @@ -26418,11 +24953,9 @@ begin {$ELSE} Result.fIsButton := TRUE; Result.fIgnoreDefault := TRUE; {$ENDIF} - {$IFNDEF SMALLEST_CODE} {$IFNDEF BUTTON_DBLCLICK} Result.AttachProc( WndProcBtnDblClkAsClk ); {$ENDIF} - {$ENDIF} {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} Result.AttachProc( WndProcBtnReturnClick ); {$ENDIF} @@ -26440,11 +24973,7 @@ begin Result := FALSE; if (Msg.message = WM_DRAWITEM) then begin DI := Pointer( Msg.lParam ); - {$IFDEF USE_PROP} - Control := Pointer( GetProp( DI.hwndItem, ID_SELF ) ); - {$ELSE} - Control := Pointer( GetWindowLongPtr( DI.hwndItem, GWLP_USERDATA ) ); - {$ENDIF} + Control := Pointer( GetWindowLongPtr( DI.hwndItem, GWLP_USERDATA ) ); if Assigned(Control) then begin Rslt := Control.Perform( CN_DRAWITEM, Msg.wParam, Msg.lParam ); Result := TRUE; @@ -26532,533 +25061,6 @@ begin Invalidate; end; -{$IFDEF ASM_noVERSION} // remove &-s from view //+ TextShift & if Y < 0 then Y := 0; // + glyph + TextShift if not glyphOver - // timer when RepeatInterval set -function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; -const szBitmapInfo = sizeof(TBitmapInfo); -asm - CMP word ptr [EDX].TMsg.message, WM_LBUTTONDBLCLK - JNZ @@noWM_LBUTTONDBLCLK - PUSH ECX - PUSH [EDX].TMsg.wParam - PUSH [EDX].TMsg.lParam - PUSH WM_LBUTTONDOWN - PUSH EAX - CALL TControl.Perform - POP ECX - MOV [ECX], EAX - MOV AL, 1 - RET -@@noWM_LBUTTONDBLCLK: - PUSH EBX - CMP [EDX].TMsg.message, CN_DRAWITEM - JNZ @@noCN_DRAWITEM - PUSH EDI - PUSH ESI - XCHG EDI, EAX // EDI = @Self - MOV dword ptr [ECX], 1 - MOV ESI, [EDX].TMsg.lParam // ESI = DIS - XOR EBX, EBX // G = 0 - MOV EAX, [ESI].TDrawItemStruct.itemState - TEST byte ptr [EDI].TControl.fBitBtnOptions, 8 //1 shl Ord(bboFixed) - JNZ @@fixed_in_options - TEST AL, ODS_SELECTED - JZ @@not1 - JMP @@1 -@@fixed_in_options: - {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG4, 1 shl G4_Checked - {$ELSE} - TEST byte ptr [EDI].TControl.fChecked, 1 - {$ENDIF} - JZ @@not1 -@@1: INC EBX -@@not1: - TEST AL, ODS_DISABLED - JZ @@not2 - MOV BL, 2 -@@not2: TEST EBX, EBX - JNZ @@not3 - TEST AL, ODS_FOCUS - JZ @@not3 - MOV BL, 3 -@@not3: {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG3, 1 shl G3_MouseInCtl - {$ELSE} - CMP [EDI].TControl.fMouseInControl, BH - {$ENDIF} - JZ @@not4 - TEST EBX, EBX - JZ @@4 - CMP BL, 3 - JNZ @@not4 -@@4: MOV BL, 4 -@@not4: MOV ECX, [EDI].TControl.fOnBitBtnDraw.TMethod.Code - {$IFDEF NIL_EVENTS} - TEST ECX, ECX - JZ @@noOnBitBtnDraw - {$ENDIF} - MOV EAX, [EDI].TControl.fCanvas - PUSH EAX - TEST EAX, EAX - JZ @@noCanvas - MOV EDX, [ESI].TDrawItemStruct.hDC - CALL TCanvas.SetHandle -@@noCanvas: - MOV EAX, [EDI].TControl.fOnBitBtnDraw.TMethod.Data - MOV EDX, EDI - PUSH EBX - XCHG ECX, EBX - CALL EBX - POP EBX - POP ECX // Canvas - PUSH EAX - JECXZ @@noCanvas2 - XCHG EAX, ECX - XOR EDX, EDX - CALL TCanvas.SetHandle -@@noCanvas2: - POP EAX - TEST AL, AL - JNZ @@exit_draw -@@noOnBitBtnDraw: - TEST byte ptr [EDI].TControl.fBitBtnOptions, 2 //1 shl Ord(bboNoBorder) - JNZ @@noborder - TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS - JZ @@noDefaultBorder - PUSH {BLACK_BRUSH} DKGRAY_BRUSH - CALL GetStockObject - LEA EDX, [ESI].TDrawItemStruct.rcItem - OR ECX, -1 - PUSH ECX - PUSH ECX - PUSH EDX - PUSH EAX - PUSH EDX - PUSH [ESI].TDrawItemStruct.hDC - CALL Windows.FrameRect - CALL InflateRect - XOR ECX, ECX - JMP @@noFlat -@@noDefaultBorder: - {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG3, 1 shl G3_Flat - JZ @@noFlat - TEST [EDI].TControl.fFlagsG3, 1 shl G3_MouseInCtl - JZ @@noborder - {$ELSE} - MOVZX ECX, [EDI].TControl.fFlat - JECXZ @@noFlat - AND CL, [EDI].TControl.fMouseInControl - JZ @@noborder - {$ENDIF} -@@noFlat: - TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_SELECTED - MOV CL, {BDR_SUNKENOUTER or} BDR_SUNKENINNER - JNZ @@border_sunken - MOV CL, {BDR_RAISEDOUTER or} BDR_RAISEDINNER -@@border_sunken: - LEA EDX, [ESI].TDrawItemStruct.rcItem - OR EAX, -1 - PUSH EAX - PUSH EAX - PUSH EDX - PUSH BF_ADJUST or BF_RECT - PUSH ECX - PUSH EDX - PUSH [ESI].TDrawItemStruct.hDC - CALL DrawEdge - CALL InflateRect -@@noborder: - PUSH [ESI].TDrawItemStruct.rcItem.Bottom - PUSH [ESI].TDrawItemStruct.rcItem.Right - PUSH [ESI].TDrawItemStruct.rcItem.Top - PUSH [ESI].TDrawItemStruct.rcItem.Left - MOV EAX, [EDI].TControl.fGlyphWidth - MOV EDX, [EDI].TControl.fGlyphHeight - TEST EAX, EAX - JLE @@noglyph - TEST EDX, EDX - JLE @@noglyph - PUSH EBP - MOV EBP, ESP - - PUSH EDX // ImgH -> [EBP-4] - PUSH EAX // ImgW -> [EBP-8] - PUSH EDX // OutH -> [EBP-12] - PUSH EAX // OutW -> [EBP-16] - MOV EAX, [ESI].TDrawItemStruct.rcItem.Left // X = DIS.rcItem.Left - MOV EDX, [ESI].TDrawItemStruct.rcItem.Top // Y = DIS.rcItem.Top - MOV ECX, [ESI].TDrawItemStruct.rcItem.Bottom - SUB ECX, EDX - PUSH ECX // H -> [EBP-20] - MOV ECX, [ESI].TDrawItemStruct.rcItem.Right - SUB ECX, EAX - PUSH ECX // W -> [EBP-24] - MOVZX ECX, [EDI].TControl.fGlyphLayout - PUSH EBX - INC ECX - LOOP @@noGlyphLeft - MOV EBX, EAX // X - ADD EBX, [EBP-16] // +OutW - MOV [EBP+4].TRect.Left, EBX // TxRect.Left = X+OutW - JMP @@centerY -@@noGlyphLeft: - LOOP @@noGlyphTop - MOV EBX, EDX // Y - ADD EBX, [EBP-12] // +OutH - MOV [EBP+4].TRect.Top, EBX // TxRect.Top = Y+OutH - LOOP @@centerX // always JMP, ECX := -1 -@@noGlyphTop: - LOOP @@noGlyphRight - MOV EAX, [ESI].TDrawItemStruct.rcItem.Right - SUB EAX, [EBP-16] // -OutW -> X - MOV [EBP+4].TRect.Right, EAX -@@centerY: - MOV EBX, [EBP-20] // H - SUB EBX, [EBP-12] // -OutH - JLE @@noGlyphRight - SAR EBX, 1 - ADD EDX, EBX // Y = Y + (H-OutH)/2 -@@noGlyphRight: - LOOP @@noGlyphBottom - MOV EDX, [ESI].TDrawItemStruct.rcItem.Bottom - SUB EDX, [EBP-12] // -OutH -> Y - MOV [EBP+4].TRect.Bottom, EDX - LOOP @@centerX // always JMP, ECX := -1 -@@noGlyphBottom: - LOOP @@noGlyphOver -@@centerX: - MOV EBX, [EBP-24] // W - SUB EBX, [EBP-16] // -OutW - SHR EBX, 1 // /2 - ADD EAX, EBX // +EAX, X = X + (W-OutW)/2 - JECXZ @@centerY -@@noGlyphOver: - MOV ECX, [ESI].TDrawItemStruct.rcItem.Left - CMP EAX, ECX - JGE @@ok1 - XCHG EAX, ECX -@@ok1: CMP EDX, [ESI].TDrawItemStruct.rcItem.Top - {$IFDEF USE_CMOV} - CMOVL EDX, [ESI].TDrawItemStruct.rcItem.Top - {$ELSE} - JGE @@ok2 - MOV EDX, [ESI].TDrawItemStruct.rcItem.Top -@@ok2: {$ENDIF} - MOV ECX, [ESI].TDrawItemStruct.rcItem.Right - SUB ECX, EAX - CMP [EBP-16], ECX - JLE @@ok3 - MOV [EBP-16], ECX // OutW := rcItem.Right - X; -@@ok3: MOV ECX, [ESI].TDrawItemStruct.rcItem.Bottom - SUB ECX, EDX - CMP ECX, [EBP-12] - JGE @@ok4 - MOV [EBP-12], ECX // OutH := rcItem.Bottom - Y; -@@ok4: - POP EBX // EBX = G - TEST byte ptr [EDI].TControl.fBitBtnOptions, 1 //1 shl Ord(bboImageList) - JZ @@draw_bitmap - MOVZX ECX, word ptr [EDI].TControl.fGlyphCount - CMP word ptr [EDI].TControl.fGlyphCount + 2, BX - JLE @@no_add_glyphIdx - ADD ECX, EBX -@@no_add_glyphIdx: - XOR EBX, EBX - PUSH ILD_TRANSPARENT // Flags = 1 (ILD_TRANSPARENT) - PUSH EBX // Blend = 0 - PUSH -1 // Bk = CLR_NONE - PUSH EBX // 0 - PUSH EBX // 0 - PUSH EDX - PUSH EAX - PUSH [ESI].TDrawItemStruct.hDC - PUSH ECX - PUSH [EDI].TControl.fGlyphBitmap - CMP [EDI].TControl.fTransparent, BL - JNZ @@imgl_transp - MOV EAX, [EDI].TControl.fColor - CALL Color2RGB - MOV [ESP+32], EAX // Bk = Color2RGB(fColor) - MOV [ESP+40], EBX // Flags = 0 -@@imgl_transp: - INC EBX - CMP word ptr [EDI].TControl.fGlyphCount + 2, BX - JNZ @@draw_imagelist - DEC byte ptr [ESP+36+3] // $FF, CLR_DEFAULT = $FF000000 - TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS - JZ @@draw_imagelist - OR byte ptr [ESP+40], ILD_BLEND25 // Flags != 2 -@@draw_imagelist: - CALL ImageList_DrawEx - JMP @@glyph_drawn - -@@draw_bitmap: - PUSH EAX // PlaceHold for DC - PUSH EAX // PlaceHold for OldBmp - PUSH SRCCOPY - PUSH dword ptr [EBP-4] // ImgH - PUSH dword ptr [EBP-8] // ImgW - PUSH 0 - PUSH EAX // PlaceHold for I - PUSH EAX // PlaceHold for DC - PUSH dword ptr [EBP-12] // OutH - PUSH dword ptr [EBP-16] // OutW - PUSH EDX // Y - PUSH EAX // X - PUSH [ESI].TDrawItemStruct.hDC - - PUSH 0 - CALL CreateCompatibleDC - MOV [ESP+48], EAX // save DC - MOV [ESP+20], EAX // place DC - PUSH [EDI].TControl.fGlyphBitmap - PUSH EAX - CALL SelectObject - MOV [ESP+44], EAX // save OldBitmap - XOR EAX, EAX - CMP [EDI].TControl.fGlyphCount, EBX - JLE @@no_incGlyIdx - MOV EAX, [EBP-8] // ImgW - IMUL EBX -@@no_incGlyIdx: - MOV [ESP+24], EAX // place I - CALL StretchBlt - CALL FinishDC - -@@glyph_drawn: - MOV ESP, EBP - POP EBP - -@@noglyph: - TEST byte ptr[EDI].TControl.fBitBtnOptions, 4 //1 shl Ord(bboNoCaption) - JNZ @@noCaption - - POP EAX - PUSH EAX - MOV EDX, [ESP].TRect.Right - CMP EDX, EAX - JLE @@noCaption - MOV EDX, [ESP].TRect.Bottom - CMP EDX, [ESP].TRect.Top - JLE @@noCaption - - XOR EBX, EBX - PUSH EBX // > CapText - MOV EDX, ESP - MOV EAX, EDI - CALL TControl.GetCaption - PUSH EBX // > Bk - PUSH EBX // > Blend - CMP [EDI].TControl.fTransparent, BL - MOV BL, ETO_CLIPPED - JNZ @@drwTxTransparent - CMP [EDI].TControl.fGlyphLayout, glyphOver - JNZ @@drwTxOpaque -@@drwTxTransparent: - PUSH TRANSPARENT - PUSH [ESI].TDrawItemStruct.hDC - CALL SetBkMode - MOV [ESP+4], EAX // Bk := SetBkMode( DIS.hDC, TRANSPARENT ) - JMP @@drwTx1 -@@drwTxOpaque: - MOV BL, ETO_CLIPPED or ETO_OPAQUE - MOV EAX, [EDI].TControl.fColor - CALL Color2RGB - PUSH EAX - PUSH [ESI].TDrawItemStruct.hDC - CALL SetBkColor - POP ECX - PUSH EAX // Blend := SetBkColor(DIS.hDC,fColor) -@@drwTx1: - PUSH 0 // > OldFont - PUSH 0 // > OldTextColor - - PUSH 0 // push - MOV EDX, [ESP+20] // CapText - CALL EDX2PChar - PUSH dword ptr [EDX-4] // push Length(CapText) - PUSH EDX // push PChar(CapText) - LEA EAX, [ESP+32] - PUSH EAX // push @TxRect - PUSH EBX // push Flags - - MOV EBX, [ESI].TDrawItemStruct.hDC - - MOV ECX, [EDI].TControl.fFont - JECXZ @@drwTx_noFont - XCHG EAX, ECX - CALL TGraphicTool.GetHandle - PUSH EAX - PUSH EBX - CALL SelectObject - MOV [ESP+24], EAX // OldFont := SelectObject... -@@drwTx_noFont: - MOV EAX, [EDI].TControl.fTextColor - CALL Color2RGB - PUSH EAX - PUSH EBX - CALL SetTextColor - MOV [ESP+20], EAX // OldTextColor := SetTextColor... - - PUSH EAX - PUSH EAX - PUSH ESP - MOV ECX, [ESP+48] // ECX = CapText - XOR EAX, EAX - JECXZ @@drwTx0 - MOV EAX, [ECX-4] // EAX = Length(CapText) -@@drwTx0: - PUSH EAX - PUSH ECX - PUSH EBX - CALL GetTextExtentPoint32 - POP ECX // ECX = TextSz.cx - POP EDX // EDX = TextSz.cy - MOV EAX, [ESP+40].TRect.Bottom - SUB EAX, [ESP+40].TRect.Top - SUB EAX, EDX - JGE @@yOk - XOR EAX, EAX -@@yOk: SHR EAX, 1 - ADD EAX, [ESP+40].TRect.Top - PUSH EAX // push Y - MOV EDX, [ESP+44].TRect.Right - MOV EAX, [ESP+44].TRect.Left // EAX = TxRect.Left - SUB EDX, EAX // EDX = W - PUSH EAX - CMP [EDI].TControl.fTextAlign, taRight - JL @@chk_X - JE @@alignR - SUB ECX, EDX - SAR ECX, 1 - JMP @@alignC -@@alignR: - ADD EAX, EDX -@@alignC: - SUB EAX, ECX -@@chk_X:POP EDX - CMP EAX, EDX - JGE @@xOk - XCHG EAX, EDX -@@xOk: PUSH EAX // push X - PUSH EBX // push hDC - CALL ExtTextOut - - PUSH EBX - CALL SetTextColor - POP ECX - JECXZ @@noRestoreFont - PUSH ECX - PUSH EBX - CALL SelectObject -@@noRestoreFont: - POP ECX // Blend - JECXZ @@restoreBk - PUSH ECX - PUSH EBX - CALL SetBkColor - POP ECX - JMP @@delCaption -@@restoreBk: - PUSH EBX - CALL SetBkMode -@@delCaption: - CALL RemoveStr - -@@noCaption: - ADD ESP, 16 - -@@exit_draw: - POP ESI - POP EDI - POP EBX - MOV AL, 1 - RET - -@@noCN_DRAWITEM: - CMP word ptr [EDX].TMsg.message, WM_LBUTTONDOWN - JZ @@doDown - CMP word ptr [EDX].TMsg.message, WM_KEYDOWN - JNZ @@noWM_LBUTTONDOWN - CMP [EDX].TMsg.wParam, 32 - JNZ @@noWM_LBUTTONDOWN -@@doDown: - PUSH EDX - XCHG EBX, EAX - - CALL @@fixed_proc - MOV ECX, [EBX].TControl.fRepeatInterval - JECXZ @@exit_LBUTTONDOWN - POP EDX - PUSH EDX - CMP word ptr [EDX].TMsg.message, WM_KEYDOWN - JZ @@not_SetTimer - PUSH 0 - PUSH [EBX].TControl.fRepeatInterval - PUSH 1 - PUSH [EBX].TControl.fHandle - CALL SetTimer -@@exit_LBUTTONDOWN: -@@not_SetTimer: - POP EDX - JMP @@invalidate - -@@noWM_LBUTTONDOWN: - CMP word ptr [EDX].TMsg.message, WM_LBUTTONUP - JE @@doKill1 - CMP word ptr [EDX].TMsg.message, WM_KEYUP - JNE @@noWM_LBUTTONUP - PUSH 1 - PUSH [EBX].TControl.fHandle - CALL KillTimer - -@@noWM_LBUTTONUP: - CMP word ptr [EDX].TMsg.message, WM_TIMER - JNZ @@noWM_TIMER - - XCHG EBX, EAX - PUSH 0 - PUSH 0 - PUSH BM_GETSTATE - PUSH EBX - CALL TControl.Perform - TEST AL, BST_PUSHED - JNZ @@pushed - PUSH 1 - PUSH [EBX].TControl.fHandle - CALL KillTimer - CALL ReleaseCapture - JMP @@noWM_TIMER -@@fixed_proc: - TEST byte ptr [EBX].TControl.fBitBtnOptions, 8 // bboFixed - JZ @@not_fixed - {$IFDEF USE_FLAGS} - XOR [EBX].TControl.fFlagsG4, 1 shl G4_Checked - {$ELSE} - XOR [EBX].TControl.fChecked, 1 - {$ENDIF} - MOV ECX, [EBX].TControl.fOnChangeCtl.TMethod.Code - {$IFDEF NIL_EVENTS} - JECXZ @@not_fixed - {$ENDIF} - MOV EAX, [EBX].TControl.fOnChangeCtl.TMethod.Data - MOV EDX, EBX - JMP ECX -@@pushed: - CALL @@fixed_proc - MOV EAX, EBX - CALL TControl.DoClick -@@invalidate: - XCHG EAX, EBX - CALL TControl.Invalidate -@@noWM_TIMER: - XOR EAX, EAX - POP EBX -@@not_fixed: -end; -{$ELSE PAS_VERSION} //Pascal function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; var DIS: PDrawItemStruct; IsDown, IsDefault, IsDisabled: Boolean; @@ -27332,9 +25334,9 @@ begin Self_.Invalidate; end; end; -{$ENDIF PAS_VERSION} -function NewBitBtn( AParent: PControl; const Caption: KOLString; Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl; +function NewBitBtn( AParent: PControl; const Caption: KOLString; Options: TBitBtnOptions; + Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl; var B: TBitmapInfo; W, H: Integer; @@ -27714,11 +25716,7 @@ begin case Msg.message of WM_HSCROLL, WM_VSCROLL: if (Msg.lParam <> 0) then begin - {$IFDEF USE_PROP} - Bar := Pointer(GetProp(Msg.lParam, ID_SELF)); - {$ELSE} Bar := Pointer( GetWindowLongPtr( Msg.lParam, GWLP_USERDATA ) ); - {$ENDIF} if (Bar <> nil) then begin ZeroMemory(@SI, SizeOf(SI)); SI.cbSize := SizeOf(SI); @@ -28170,11 +26168,9 @@ begin if I > 0 then Prev := Self_.FParent.fChildren.Items[ I - 1 ]; GetCursorPos( MousePos ); - {$IFDEF SPEED_FASTER} - if (MousePos.X = Self_.DF.fSplitLastPos.X) - and (MousePos.Y = Self_.DF.fSplitLastPos.Y) then Exit; {>>>>>>>>>>>>>} - Self_.DF.fSplitLastPos := MousePos; - {$ENDIF SPEED_FASTER} + if (MousePos.X = Self_.DF.fSplitLastPos.X) + and (MousePos.Y = Self_.DF.fSplitLastPos.Y) then Exit; {>>>>>>>>>>>>>} + Self_.DF.fSplitLastPos := MousePos; if Cancel then MousePos := Self_.DF.fSplitStartPos; M := 1; @@ -28231,11 +26227,7 @@ begin else R.Right := R.Left + NewSize1; end; Prev.BoundsRect := R; - {$IFDEF OLD_ALIGN} - Global_Align( Self_.fParent ); - {$ELSE NEW_ALIGN} Global_Align( Self_ ); - {$ENDIF} end; end; {$ENDIF} @@ -28287,9 +26279,7 @@ begin Self_.DF.fSplitStartPos2 := MakePoint( Self_.DF.fSecondControl.Width, Self_.DF.fSecondControl.Height ); SetCapture( Self_.fHandle ); - {$IFDEF SPEED_FASTER} - Self_.DF.fSplitLastPos := MakePoint( -1, -1 ); - {$ENDIF} + Self_.DF.fSplitLastPos := MakePoint( -1, -1 ); {$IFDEF USE_FLAGS} Include( Self_.fFlagsG6, G6_Dragging ); {$ELSE} Self_.fDragging := True; {$ENDIF} SetTimer( Self_.fHandle, $7B, 100, nil ); @@ -28413,11 +26403,7 @@ end; function CallDefFrameProc( Wnd: HWnd; Msg: Integer; wParam: WPARAM; lParam: LPARAM ): LRESULT; stdcall; var Form, MDIClient: PControl; begin - {$IFDEF USE_PROP} - Form := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} Form := Pointer( GetWindowLongPtr( Wnd, GWLP_USERDATA ) ); - {$ENDIF} //dufa: MDIClient := nil; if Assigned(Form) then begin @@ -28436,12 +26422,8 @@ function WndFuncMDIClient( Wnd: HWnd; Msg, wParam: WPARAM; lParam: LPARAM ): LRE var C: PControl; M: TMsg; begin - {$IFDEF USE_PROP} - C := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} C := Pointer( GetWindowLongPtr( Wnd, GWLP_USERDATA ) ); - {$ENDIF} - if C <> nil then begin + if Assigned(C) then begin M.hwnd := Wnd; M.message := Msg; M.wParam := wParam; @@ -28505,7 +26487,7 @@ begin end; WM_WINDOWPOSCHANGED: begin - Global_Align( {$IFDEF OLD_ALIGN}MDIClient.Parent{$ELSE}MDIClient{$ENDIF} ); + Global_Align(MDIClient); MDIClient.Invalidate; MDIClient.Parent.Invalidate; MDIClient.Perform( WM_SETREDRAW, 1, 0 ); @@ -28568,11 +26550,7 @@ begin Result.fDefWndProc := Pointer( GetWindowLongPtr( Result.fHandle, GWLP_WNDPROC ) ); SetWindowLongPtr( Result.fHandle, GWLP_WNDPROC, PtrInt( @WndFuncMDIClient ) ); Result.PropInt[ MDI_CHLDRN ] := PtrUInt( NewList ); - {$IFDEF USE_PROP} - SetProp( Result.fHandle, ID_SELF, PtrUInt( Result ) ); - {$ELSE} SetWindowLongPtr( Result.fHandle, GWLP_USERDATA, PtrInt( Result ) ); - {$ENDIF} Result.AttachProc( WndProcMDIClient ); Result.GetWindowHandle; @@ -28584,11 +26562,7 @@ function MDIChildFunc( Wnd: HWnd; Msg: DWord; wParam: WPARAM; lParam: LPARAM ): var C: PControl; M: TMsg; begin - {$IFDEF USE_PROP} - C := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} C := Pointer( GetWindowLongPtr( Wnd, GWLP_USERDATA ) ); - {$ENDIF} if C <> nil then begin M.hwnd := Wnd; M.message := Msg; @@ -28907,11 +26881,7 @@ begin Combo := nil; ParentWnd := GetParent( W ); if ParentWnd <> 0 then - {$IFDEF USE_PROP} - Combo := Pointer( GetProp( ParentWnd, ID_SELF ) ); - {$ELSE} Combo := Pointer( GetWindowLongPtr( ParentWnd, GWLP_USERDATA ) ); - {$ENDIF} if (Combo <> nil) then begin MsgStruct.hwnd := Combo.fHandle; MsgStruct.message := Msg; @@ -29264,11 +27234,7 @@ begin Result := False; if (Msg.message = WM_NOTIFY) then begin NMhdr := Pointer( Msg.lParam ); - {$IFDEF USE_PROP} - Child := Pointer( GetProp( NMhdr.hwndFrom, ID_SELF ) ); - {$ELSE} Child := Pointer( GetWindowLongPtr( NMhdr.hwndFrom, GWLP_USERDATA ) ); - {$ENDIF} if Assigned(Child) and (Child <> Self_) //+ by Galkov, Jun-2009 then begin @@ -29539,45 +27505,6 @@ var Hdr: PNMHdr; A: Integer; R: TRect; WasActive: Boolean; -{$IFDEF OLD_ALIGN} - Page: PControl; - I: Integer; -begin - case Msg.message of - WM_NOTIFY: - begin - Hdr := Pointer( Msg.lParam ); - case LongInt(Hdr.code) of - TCN_SELCHANGING: - Self_.fCurIndex := Self_.GetCurIndex; - TCN_SELCHANGE: - begin - A := {Self_.????}Self_.GetCurIndex; - WasActive := Self_.fCurIndex = A; - Self_.fCurIndex := A; - for I := 0 to Self_.Count - 1 do begin - Page := Self_.Pages[ I ]; - Page.Visible := A = I; - if A = I then - Page.BringToFront; - end; - if not WasActive then - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnSelChange ) then - {$ENDIF} - Self_.EV.fOnSelChange( Self_ ); - end; - end; - end; - WM_SIZE: - begin - GetClientRect( Self_.fHandle, R ); - Self_.Perform( TCM_ADJUSTRECT, 0, LPARAM( @R ) ); - for I := 0 to Self_.Count - 1 do begin - Page := Self_.Pages[ I ]; - Page.BoundsRect := R; - end; -{$ELSE NEW_ALIGN} begin case Msg.message of WM_NOTIFY: @@ -29613,7 +27540,6 @@ begin Self_.fClientTop := ShortInt(R.Top); Dec(Self_.fClientRight,ShortInt(R.Right)); Dec(Self_.fClientBottom,ShortInt(R.Bottom)); -{$ENDIF} end; end; Result := False; @@ -29706,7 +27632,6 @@ begin end; {$ENDIF PAS_VERSION} -{$IFNDEF OLD_ALIGN} {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal function NewTabEmpty( AParent: PControl; Options: TTabControlOptions; ImgList: PImageList ): PControl; @@ -29734,7 +27659,6 @@ begin Result.fLookTabKeys := [ tkTab ]; end; {$ENDIF PAS_VERSION} -{$ENDIF} //===================== Tool bar ========================// @@ -30582,27 +28506,6 @@ begin end; end; -{$IFDEF ASM_noVERSION} -function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; -const int_IDC_ARROW = integer( IDC_ARROW ); -asm - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNE @@chk_WM_DESTROY - MOV EDX, [EDX].TMsg.lParam - CMP [EDX].TNMHdr.code, EN_SELCHANGE - JNE @@ret_false - CALL TControl.DoSelChange - JMP @@ret_false -@@chk_WM_DESTROY: - CMP word ptr [EDX].TMsg.message, WM_DESTROY - JNZ @@ret_false - LEA EAX, [EAX].TControl.fREUrl - CALL @LStrClr -@@ret_false: - XOR EAX, EAX - RET -end; -{$ELSE PAS_VERSION} //Pascal function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; var NMhdr: PNMHdr; begin @@ -30625,7 +28528,6 @@ begin Self_.DF.fREURL := nil; end; end; -{$ENDIF PAS_VERSION} const RichEditflags: array [ TEditOption ] of Integer = ( not (es_AutoHScroll or WS_HSCROLL), @@ -30639,120 +28541,6 @@ const RichEditflags: array [ TEditOption ] of Integer = ( 0 {es_UpperCase - not supported}, es_WantReturn, 0, es_Number ); -{$IFDEF noASM_UNICODE} -function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl; -const - RichNamesCount = High( RichEditLibnames ) + 1; -asm - PUSH EDX - - MOV ECX, [FRichEditModule] - INC ECX - LOOP @@loaded - PUSHAD - {$IFNDEF SMALLEST_CODE} - {$IFNDEF SMALLER_CODE} - PUSH SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS - CALL SetErrorMode - PUSH EAX - {$ENDIF} - {$ENDIF} -@@search_richedit: - MOV BX, RichNamesCount + $400 - LEA ESI, [RichEditLibNames] - LEA EDI, [RichEditClasses] - CMP [RichEditIdx], 0 - JZ @@loo - LEA ESI, [ESI+(RichNamesCount-1)*4] - LEA EDI, [EDI+(RichNamesCount-1)*4] - NEG BH -@@loo: - MOV ECX, [EDI] - MOV [RichEditClass], ECX - MOVSX ECX, BH - ADD EDI, ECX - MOV EAX, [ESI] - ADD ESI, ECX - PUSH EAX - CALL LoadLibrary - CMP EAX, HINSTANCE_ERROR - JG @@break - DEC BL - JNZ @@loo - JMP @@fault -@@break: - MOV [FRichEditModule], EAX -@@fault: - {$IFNDEF SMALLEST_CODE} - {$IFNDEF SMALLER_CODE} - CALL SetErrorMode - {$ENDIF} - {$ENDIF} - POPAD -@@loaded: - PUSH EAX - PUSH EDX - MOV EAX, ESP - MOV EDX, offset[RichEditFlags] - XOR ECX, ECX - MOV CL, 10 - CALL MakeFlags - XCHG ECX, EAX - POP EDX - POP EAX - PUSH 1 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [RichEditActions_Packed] - {$ELSE} - PUSH offset[RichEditActions] - {$ENDIF} - MOV EDX, [RichEditClass] - OR ECX, WS_VISIBLE or WS_CHILD or WS_TABSTOP or WS_BORDER or ES_MULTILINE - CALL _NewCommonControl - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG5, 1 shl G5_IgnoreDefault - {$ELSE} - INC [EAX].TControl.fIgnoreDefault - {$ENDIF} - POP EDX - TEST DH, 4 // is eoWantTab in Options ? - SETZ DL - MOV [EAX].TControl.fLookTabKeys, DL - PUSH EBX - MOV EBX, EAX - MOV EDX, offset[WndProcRichEditNotify] - CALL TControl.AttachProc - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG1, (1 shl G1_CanNotDoublebuf) - AND [EBX].TControl.fFlagsG2, not (1 shl G2_DoubleBuffered) - {$ELSE} - INC [EBX].TControl.fCannotDoubleBuf - MOV [EBX].TControl.fDoubleBuffered, 0 - {$ENDIF USE_FLAGS} - ADD [EBX].TControl.fBoundsRect.Right, 100-64 - ADD [EBX].TControl.fBoundsRect.Bottom, 200-64 - PUSH ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or ENM_PROTECTED or $04000000 - PUSH 0 - PUSH EM_SETEVENTMASK - PUSH EBX - CALL TControl.Perform - MOV EAX, clWindow - MOV [EBX].TControl.fColor, EAX - CALL Color2RGB - PUSH EAX - PUSH 0 - PUSH EM_SETBKGNDCOLOR - PUSH EBX - CALL TControl.Perform - {$IFDEF RICHEDIT_XPBORDER} - MOV EDX, offset[WndProc_RichEditXPBorder] - MOV EAX, EBX - CALL TControl.AttachProc - {$ENDIF RICHEDIT_XPBORDER} - XCHG EAX, EBX - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl; var Flags, I, d, Last, SaveErrMode: Integer; label search_richedit; @@ -30844,7 +28632,6 @@ begin END; {$ENDIF INPACKAGE} end; -{$ENDIF PAS_VERSION} {$ENDIF NOT_USE_RICHEDIT} {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal @@ -31028,10 +28815,6 @@ begin ShowWindow( fHandle, SW_HIDE ); Final; - {$IFDEF USE_AUTOFREE4CHILDREN} - {$ELSE} - DestroyChildren; - {$ENDIF} if {$IFDEF USE_FLAGS} not(G2_Destroying in fFlagsG2) {$ELSE} not fDestroying {$ENDIF} then begin {$IFDEF USE_FLAGS} include( fFlagsG2, G2_Destroying ); @@ -31043,32 +28826,10 @@ begin {$ELSE} fCtlClsNameChg := FALSE; {$ENDIF} end; - {$IFDEF USE_AUTOFREE4CONTROLS} - {$ELSE} - fFont.Free; - fFont := nil; - fBrush.Free; - fBrush := nil; - {$ENDIF} fCanvas.Free; fCanvas := nil; if fHandle <> 0 then begin - {$IFNDEF NEW_MENU_ACCELL} - {$IFDEF USE_AUTOFREE4CONTROLS} - {$ELSE} - if fAccelTable <> 0 then begin - DestroyAcceleratorTable( fAccelTable ); - fAccelTable := 0; - end; - {$ENDIF} - {$ENDIF} - {$IFDEF USE_AUTOFREE4CONTROLS} - {$ELSE} - fMenuObj.Free; - while fImageList <> nil do - fImageList.Free; - {$ENDIF} I := fHandle; Ico := DF.fIcon; if (Ico <> 0) and (Ico <> HIcon(-1)) then @@ -31086,16 +28847,7 @@ begin LogFileOutput( GetStartDir + 'es_debug.txt', 'DESTROYING HWND:' + Int2Str( I ) ); {$ENDIF} - (* -- moved to WM_NCDESTROY -- VK + Alexey Kirov, 23.02.2012 - {$IFnDEF SMALLER_CODE} - {$IFDEF USE_PROP} - SetProp( I, ID_SELF, 0 ); - {$ELSE} - SetWindowLongPtr( I, GWLP_USERDATA, 0 ); - {$ENDIF} - {$ENDIF} - *) - DestroyWindow( I ); + DestroyWindow( I ); end; end; fHandle := 0; @@ -31118,20 +28870,12 @@ begin if fParent <> nil then begin fParent.fChildren.Remove( @Self ); - {$IFDEF USE_AUTOFREE4CHILDREN} fParent.RemoveFromAutoFree( @ Self ); - {$ENDIF} if fParent.DF.fCurrentControl = @Self then fParent.DF.fCurrentControl := nil; end; fChildren.Free; - {$IFDEF USE_AUTOFREE4CONTROLS} - {$ELSE} - DF.fTBttCmd.Free; - DF.fTBttTxt.Free; - fTmpFont.Free; - {$ENDIF} fDynHandlers.Free; inherited; end; @@ -31171,13 +28915,10 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF ASM_noVERSION} -{$ELSE PAS_VERSION} //Pascal function TControl.GetParentWindow: HWnd; begin Result := GetParentWnd( TRUE ); end; -{$ENDIF PAS_VERSION} {$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal function TControl.GetWindowHandle: HWnd; @@ -31187,7 +28928,6 @@ begin TRY {$ENDIF INPACKAGE} if fHandle = 0 then begin - {$IFDEF CREATE_HIDDEN} if {$IFDEF USE_FLAGS} not(G4_CreateVisible in fFlagsG4) {$ELSE} not fCreateVisible {$ENDIF} then begin Set_Visible( False ); @@ -31195,7 +28935,6 @@ begin {$IFDEF USE_FLAGS} include( fFlagsG4, G4_CreateHidden ); {$ELSE} fCreateHidden := True; {$ENDIF} end else - {$ENDIF CREATE_HIDDEN} CreateWindow; //virtual!!! end; Result := fHandle; @@ -31263,9 +29002,6 @@ var TempClass: TWndClass; // {$IFDEF UNICODE_CTRLS} // TempOleStr : PWideChar; // {$ENDIF UNICODE_CTRLS} - {$IFNDEF CREATE_HIDDEN} - lock: Boolean; - {$ENDIF} begin {$IFDEF INPACKAGE} Log( '->TControl.CreateWindow' ); @@ -31278,7 +29014,6 @@ begin if (fParent <> nil) then if fParent.GetWindowHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} if fHandle <> 0 then begin - {$IFDEF CREATE_HIDDEN} if {$IFDEF USE_FLAGS} G4_CreateHidden in fFlagsG4 {$ELSE} fCreateHidden {$ENDIF} then begin CreateChildWindows; @@ -31288,20 +29023,6 @@ begin end else begin CreateChildWindows; end; - {$ELSE} - begin - lock := LockedWindow <> 0; - if lock then begin - LockWindowUpdate( fHandle ); - LockedWindow := fHandle; - end; - CreateChildWindows; - if lock then begin - LockWindowUpdate( 0 ); - LockedWindow := 0; - end; - end; - {$ENDIF CREATE_HIDDEN} Result := True; {$IFDEF INPACKAGE} LogOK; @@ -31366,8 +29087,7 @@ begin if fControlClassName <> nil then begin GetClassInfo( hInstance,fControlClassName,Params.WindowClass ); Params.WindowClass.hInstance := Params.Inst; - Params.WindowClass.style := Params.WindowClass.style and - not CS_OFF or CS_ON; + Params.WindowClass.style := Params.WindowClass.style and not CS_OFF or CS_ON; end; if fDefWndProc = nil then fDefWndProc := {$ifdef FPC}@{$endif}Params.WindowClass.lpfnWndProc; @@ -31438,27 +29158,16 @@ begin {$IFDEF INPACKAGE} Log( '/// SendMessage WM_UPDATEUISTATE' ); {$ENDIF INPACKAGE} - SendMessage( fHandle, $0128 {WM_UPDATEUISTATE}, - 2 {UIS_CLEAR} or (1 {UISF_HIDEFOCUS} shl 16),0); - {$IFDEF USE_PROP} - if GetProp(FHandle,ID_SELF) = 0 then begin - CreatingWindow := nil; - SetProp(FHandle, ID_SELF, THandle(@Self)); - end; - {$ELSE} + SendMessage( fHandle, $0128 {WM_UPDATEUISTATE}, 2 {UIS_CLEAR} or (1 {UISF_HIDEFOCUS} shl 16),0); CreatingWindow := nil; SetWindowLongPtr( FHandle, GWLP_USERDATA, PtrInt(@Self) ); - {$ENDIF} //*** {$IFDEF INPACKAGE} Log( '/// Perform WM_SETICON' ); {$ENDIF INPACKAGE} - {$IFDEF SMALLEST_CODE} - {$ELSE} if {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3) {$ELSE} not fIsControl {$ENDIF} then Perform( WM_SETICON, 1 {ICON_BIG}, LPARAM(GetIcon) ); - {$ENDIF} {$IFDEF NIL_EVENTS} if Assigned( PP.FCreateWndExt ) then {$ENDIF} @@ -31856,13 +29565,7 @@ begin WM_NCDESTROY: begin if (fHandle = Msg.hwnd) then begin - {$IFnDEF SMALLER_CODE} - {$IFDEF USE_PROP} - RemoveProp( fHandle, ID_SELF ); //********* Added By M.Gerasimov - {$ELSE} - SetWindowLongPtr( fHandle, GWLP_USERDATA, 0 ); // VK + Alexey Kirov, 23.02.2012 - {$ENDIF} - {$ENDIF} //------------------------------------------- + SetWindowLongPtr( fHandle, GWLP_USERDATA, 0 ); // VK + Alexey Kirov, 23.02.2012 Default; Exit; end; @@ -31883,13 +29586,6 @@ begin WM_SIZE: begin Default; - {$IFDEF OLD_ALIGN} - if {$IFDEF USE_FLAGS} not(G3_IsForm in fFlagsG3) - {$ELSE} not fIsForm {$ENDIF} - then - Global_Align( fParent ); - {$ENDIF} - Global_Align( @Self ); Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} end; @@ -31918,11 +29614,7 @@ begin end; WM_COMMAND: begin - {$IFDEF USE_PROP} - C := Pointer( GetProp( Msg.lParam, ID_SELF ) ); - {$ELSE} - C := Pointer( GetWindowLongPtr( Msg.lParam, GWLP_USERDATA ) ); - {$ENDIF} + C := Pointer( GetWindowLongPtr( Msg.lParam, GWLP_USERDATA ) ); if Assigned(C) then Result := SendMessage( Msg.lParam, CM_COMMAND, Msg.wParam, Msg.lParam ) else @@ -32148,9 +29840,7 @@ procedure TControl.SetMenu( Value: HMenu ); begin if fMenu = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} if fMenuObj <> nil then begin - {$IFDEF USE_AUTOFREE4CONTROLS} RemoveFromAutoFree( fMenuObj ); - {$ENDIF} fMenuObj.Free; end; if fMenu <> 0 then @@ -32241,11 +29931,7 @@ begin Ctl := nil; HI := Pointer( Msg.lParam ); if HI.iContextType = HELPINFO_WINDOW then begin - {$IFDEF USE_PROP} - Ctl := Pointer( GetProp( HI.hItemHandle, ID_SELF ) ); - {$ELSE} Ctl := Pointer( GetWindowLongPtr( HI.hItemHandle, GWLP_USERDATA ) ); - {$ENDIF} while Ctl <> nil do begin Ctx := Ctl.HelpContext; if Ctx <> 0 then break; @@ -32260,11 +29946,7 @@ begin {$IFDEF AUTO_CONTEXT_HELP} else if (Msg.message = WM_CONTEXTMENU) then begin - {$IFDEF USE_PROP} - Ctl := Pointer( GetProp( Msg.wParam, ID_SELF ) ); - {$ELSE} Ctl := Pointer( GetWindowLongPtr( Msg.wParam, GWLP_USERDATA ) ); - {$ENDIF} if (Ctl <> nil) and (Ctl.HelpContext <> 0) then begin Applet.CallHelp( Ctl.HelpContext, Ctl ); Rslt := 1; @@ -32405,37 +30087,7 @@ begin end; procedure TControl.Set_Visible( Value: Boolean ); -{$IFDEF OLD_ALIGN} -var CmdShow: DWORD; -{$ENDIF} begin - {$IFDEF OLD_ALIGN} - //if Get_Visible <> Value then // commented to allow to set up controls visibility - begin // on invisible form (Vladimir Piven) - if Value then begin - {$IFDEF USE_FLAGS} include( fStyle.f3_Style, F3_Visible ); - {$ELSE} fStyle.Value := fStyle.Value or WS_VISIBLE; {$ENDIF} - CmdShow := SW_SHOW; - end else begin - {$IFDEF USE_FLAGS} exclude( fStyle.f3_Style, F3_Visible ); - {$ELSE} fStyle.Value := fStyle.Value and not WS_VISIBLE; {$ENDIF} - CmdShow := SW_HIDE; - end; - {$IFDEF USE_FLAGS}{$ELSE} - fVisible := Value; - {$ENDIF} - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ShowWindow( fHandle, CmdShow ); - Global_Align( fParent ); - if Value then - Global_Align( @Self ); - end; - {$IFDEF CREATE_HIDDEN} - if not Value and (fHandle <> 0) then - {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_CreateHidden ); - {$ELSE} fCreateHidden := FALSE; {$ENDIF} // { +++ } - {$ENDIF CREATE_HIDDEN} -{$ELSE NEW_ALIGN} fStyle.Value := fStyle.Value and not WS_VISIBLE; if Value then fStyle.Value := fStyle.Value or WS_VISIBLE; @@ -32455,7 +30107,6 @@ begin ShowWindow( fHandle, SW_HIDE ); Global_Align( @Self ); end; -{$ENDIF} end; procedure TControl.SetVisible( Value: Boolean ); @@ -32608,24 +30259,20 @@ end; {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal function TControl.GetIcon: HIcon; begin - Result := DF.fIcon; - if Result = THandle( -1 ) then begin - Result := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if Result = 0 then - if (Applet <> nil) and (@Self <> Applet) then begin - Result := Applet.Icon; - if Result <> 0 then - Result := CopyImage( Result, IMAGE_ICON, 0, 0, 0 ); - end else begin - {$IFDEF NUMERIC_APPICON} {$DEFINE CUSTOM_APPICON} {$ENDIF} - Result := LoadIcon( hInstance, - {$IFDEF CUSTOM_APPICON} {$IFDEF NUMERIC_APPICON} PKOLChar( {$ENDIF} // avoid A/W casting - {$I CustomAppIconRsrcName_PAS.inc} // create such file with 'your icon rsrc name' or yourIconID - {$IFDEF NUMERIC_APPICON} ) {$ENDIF} - {$ELSE} 'MAINICON' {$ENDIF} ); - end; - DF.fIcon := Result; + Result := DF.fIcon; + if (Result = THandle( -1 )) then begin + Result := 0; + Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + end; + if (Result = 0) then begin + if Assigned(Applet) and (@Self <> Applet) then begin + Result := Applet.Icon; + if (Result <> 0) then + Result := CopyImage(Result, IMAGE_ICON, 0, 0, 0); + end else + Result := LoadIcon(hInstance, 'MAINICON'); + end; + DF.fIcon := Result; end; {$ENDIF PAS_VERSION} @@ -32852,9 +30499,7 @@ begin fParent := Value; if fParent <> nil then begin fParent.fChildren.Add( @Self ); - {$IFDEF USE_AUTOFREE4CHILDREN} fParent.Add2AutoFree( @ Self ); - {$ENDIF} {$IFNDEF INPACKAGE} //----------------------------------------------------- if FHandle <> 0 then Windows.SetParent( FHandle, Value.GetWindowHandle ); @@ -33250,9 +30895,7 @@ begin Result := Msg.message <> 0; if (Msg.message = WM_QUIT) then begin AppletTerminated := True; - {$IFDEF PROVIDE_EXITCODE} ExitCode := Msg.wParam; - {$ENDIF PROVIDE_EXITCODE} end else begin if not( {$IFDEF NIL_EVENTS} Assigned( PP.fExMsgProc ) and {$ENDIF} @@ -33536,169 +31179,7 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF OLD_TRANSPARENT} -function WndProcTransparent( Sender: PControl; var Msg: TMsg; - var Rslt: LRESULT ): Boolean; -var DC, PDC, BLTDC: HDC; - Save: integer; - OLDp: THANDLE; - L, T: SmallInt; - TP, ParentClient: TPoint; - TR, Margins: TRect; - Wnd: HWND; - tRgn: HRgn; - C: PControl; -begin - Result := FALSE; - {$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED} - if AppletTerminated or not Sender.ToBeVisible then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - case Msg.message of - WM_HSCROLL, WM_VSCROLL: - begin - Sender.Invalidate; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_SETTEXT: - begin - if {$IFDEF USE_FLAGS} not(G1_IsStaticControl in Sender.fFlagsG1) - {$ELSE} Sender.fIsStaticControl = 0 {$ENDIF} then - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Sender.Invalidate; - Rslt := DefWindowProc - ( Sender.fHandle, WM_SETTEXT, Msg.wParam, Msg.lParam ); - Result := TRUE; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_NCPAINT: - begin - if {$IFDEF USE_FLAGS} (G2_Transparent in Sender.fFlagsG2) - {$ELSE} Sender.fTransparent {$ENDIF} then - Result := TRUE; - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - if {$IFDEF USE_FLAGS} (G2_Transparent in Sender.fFlagsG2) - {$ELSE} Sender.fTransparent {$ENDIF} and ( - {$IFDEF USE_FLAGS} not(G2_DoubleBuffered in Sender.FParent.fFlagsG2) - {$ELSE} not Sender.fParent.fDoubleBuffered {$ENDIF} ) then - {$IFDEF USE_FLAGS} exclude( Sender.fFlagsG2, G2_Transparent ); - {$ELSE} Sender.fTransparent := FALSE; {$ENDIF} - if {$IFDEF USE_FLAGS} [G2_DoubleBuffered, G2_Transparent] * Sender.fFlagsG2 = [] - {$ELSE} not (Sender.fTransparent or Sender.fDoubleBuffered) {$ENDIF} then - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Sender.fAnchors and SELF_REQ_PAINT <> 0 then exit; {>>>>>>>>>>>>>>>>>>} - case Msg.message of - WM_ERASEBKGND: - begin - Result := TRUE; - end; - WM_PAINT: - begin - ValidateRect(Sender.fHandle, nil); //???--brandys??? - if {$IFDEF USE_FLAGS} (G2_Transparent in Sender.fFlagsG2) - {$ELSE} Sender.fTransparent {$ENDIF} - and (Sender.fAnchors and PARENT_REQ_PAINT = 0) then begin - InvalidateRect(Sender.fParent.Handle, nil, FALSE); - Result := TRUE; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - GetClientRect(Msg.hwnd, Margins); - OLDp := 0; - if Sender.fAnchors and PARENT_REQ_PAINT = 0 then begin - Sender.fDblExcludeRgn := CreateRectRgn(0, 0, Margins.Right, Margins.Bottom); - DC := GetDC(0); - PDC := CreateCompatibleDC( DC ); - OLDp := SelectObject(PDC, - CreateCompatibleBitmap(DC, Margins.Right, Margins.Bottom) ); - ReleaseDC(0, DC); - Sender.fParentCoordX := 0; - Sender.fParentCoordy := 0; - end else begin - PDC := Msg.wParam; - Sender.fDblExcludeRgn := Sender.fParent.fDblExcludeRgn; - end; - - Sender.fAnchors := Sender.fAnchors or SELF_REQ_PAINT; - Sender.fPaintDC := PDC; - if (Sender.fAnchors and PARENT_REQ_PAINT = 0) or - {$IFDEF USE_FLAGS} (G2_DoubleBuffered in Sender.fFlagsG2) - {$ELSE} Sender.fDoubleBuffered {$ENDIF} then - Sender.Perform(WM_ERASEBKGND, PDC, 0); - Sender.Perform(WM_PAINT, PDC, 0); - - Wnd := GetWindow( Sender.fHandle, GW_CHILD ); - Wnd := GetWindow( Wnd, GW_HWNDLAST); - while Wnd <> 0 do begin - if IsWindowVisible(Wnd) then begin - {$IFDEF USE_PROP} - C := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} - C := Pointer( GetWindowLongPtr( Wnd, GWLP_USERDATA ) ); - {$ENDIF} - with C^ do begin - if (C <> nil) and - {$IFDEF USE_FLAGS} ( [G2_DoubleBuffered, G2_Transparent] - * fFlagsG2 <> [] ) - {$ELSE} (fTransparent or fDoubleBuffered) {$ENDIF} then begin - Save := SaveDC( PDC ); - Include( fAnchors, PARENT_REQ_PAINT ); - L := Sender.fParentCoordX + Left; - T := Sender.fParentCoordY + Top; - SetWindowOrgEx(PDC, -L, -T, nil); - SendMessage(Wnd, WM_PRINT, PDC, PRF_NONCLIENT); - TP.x := 0; TP.Y := 0; - ClientToScreen(fHandle, TP); - GetWindowRect(fHandle, TR); - fParentCoordX := L + TP.X - TR.Left; - fParentCoordY := T + TP.Y - TR.Top; - SetWindowOrgEx(PDC, -fParentCoordX, -fParentCoordY, nil); - GetClientRect(Wnd, TR); - IntersectClipRect(PDC, 0, 0, TR.Right, TR.Bottom); - SendMessage(Wnd, WM_PAINT, PDC, 0); - Exclude( fAnchors, PARENT_REQ_PAINT ); - RestoreDC( PDC, Save ); - end else - begin - GetWindowRect(Wnd, TR); - TP.X := 0; TP.Y := 0; - ClientToScreen(Sender.fHandle, TP); - TP.X := TR.Left - TP.X + Sender.fParentCoordX; - TP.Y := TR.Top - TP.Y + Sender.fParentCoordY; - TR.Left := TR.Right - TR.Left; - TR.Top := TR.Bottom - TR.Top; - - tRgn := CreateRectRgn(TP.X, TP.Y, TP.X+TR.Left, TP.Y+TR.Top); - CombineRgn(Sender.fDblExcludeRgn, Sender.fDblExcludeRgn, tRgn, RGN_DIFF); - DeleteObject(tRgn); - end; - end; - end; - Wnd := GetWindow( Wnd, GW_HWNDPREV ); - end; - Sender.fPaintDC := 0; - Sender.fAnchors := Sender.fAnchors and not SELF_REQ_PAINT; - - if Sender.fAnchors and PARENT_REQ_PAINT = 0 then begin - BLTDC := GetWindowDC(Sender.fHandle); - GetWindowRect( Sender.fHandle, TR ); - ParentClient.x := 0; ParentClient.y := 0; - ClientToScreen( Sender.fHandle, ParentClient ); - SetWindowOrgEx(BLTDC, TR.Left - ParentClient.x, TR.Top - ParentClient.y, nil); - OffsetRgn(Sender.fDblExcludeRgn, ParentClient.x - TR.Left, ParentClient.y - TR.Top); - ExtSelectClipRgn(BLTDC, Sender.fDblExcludeRgn, RGN_AND); - - BitBlt( BLTDC, 0, 0, Margins.Right, Margins.Bottom, PDC, 0, 0, SRCCOPY ); - ReleaseDC(Sender.fHandle, BLTDC); - DeleteObject(SelectObject( PDC, OLDp )); - DeleteObject(Sender.fDblExcludeRgn); - DeleteDC( PDC ); - end; - - //ValidateRect(Sender.fHandle, nil); //???++brandys???// - Result := TRUE; - end; - end; -end; -{$ELSE NEW_TRANSPARENT} // by Alexander Karpinsky a.k.a. homm +// by Alexander Karpinsky a.k.a. homm function WndProcTransparent( Sender: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; @@ -33811,11 +31292,8 @@ begin end; OffsetRgn(ChildRgn, Sender.fParentCoordX, Sender.fParentCoordY); - {$IFDEF USE_PROP} - C := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} C := Pointer( GetWindowLongPtr( Wnd, GWLP_USERDATA ) ); - {$ENDIF} + if CombineRgn(ChildRgn, ChildRgn, Sender.fDblExcludeRgn, RGN_AND) >= SIMPLEREGION then begin with C^ do begin if (C <> nil) and @@ -33865,147 +31343,7 @@ begin end; end; end; -{$ENDIF} -{$IFDEF ASM_noVERSION} -function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; -const szPaintStruct = sizeof(TPaintStruct); -asm - CMP word ptr [EDX].TMsg.message, WM_PRINT - JE @@print - CMP word ptr [EDX].TMsg.message, WM_PAINT - JNE @@ret_false -@@print: - CMP word ptr [EAX].TControl.fOnPaint.TMethod.Code+2, 0 - JE @@ret_false - PUSH EBX - PUSH ESI - XCHG EBX, EAX - MOV ESI, EDX - XOR EAX, EAX - PUSH ECX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EAX - CALL CreateRectRgn - MOV [EBX].TControl.fUpdRgn, EAX - - MOVSX EDX, [EBX].TControl.fEraseUpdRgn - PUSH EDX - PUSH EAX - PUSH [EBX].TControl.fHandle - CALL GetUpdateRgn - - CMP EAX, 1 - JA @@collectUpdRgn - - XOR EAX, EAX - XCHG EAX, [EBX].TControl.fUpdRgn - PUSH EAX - CALL DeleteObject - -@@collectUpdRgn: - MOV ECX, [EBX].TControl.fCollectUpdRgn - JECXZ @@asg_fPaintDC - XCHG EAX, ECX - MOV ECX, [EBX].TControl.fUpdRgn - JECXZ @@asg_fPaintDC - - PUSH RGN_OR - PUSH ECX - PUSH EAX - PUSH EAX - CALL CombineRgn - - DEC EAX - JNZ @@invalidateRgn - - ADD ESP, -16 - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL Windows.GetClientRect - - PUSH [EBX].TControl.fCollectUpdRgn - CALL DeleteObject - CALL CreateRectRgn - MOV [EBX].TControl.fCollectUpdRgn, EAX - -@@invalidateRgn: - MOVSX EDX, [EBX].TControl.fEraseUpdRgn - PUSH EDX - PUSH [EBX].TControl.fCollectUpdRgn - PUSH [EBX].TControl.fHandle - CALL InvalidateRgn - -@@asg_fPaintDC: - MOV ECX, [ESI].TMsg.wParam - INC ECX - LOOP @@storePaintDC - - ADD ESP, -szPaintStruct - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL BeginPaint - XCHG ECX, EAX -@@storePaintDC: - MOV [EBX].TControl.fPaintDC, ECX - XCHG EAX, ECX - - MOV ECX, [EBX].TControl.fCollectUpdRgn - JECXZ @@doOnPaint - - PUSH ECX - PUSH EAX - CALL SelectClipRgn - -@@doOnPaint: - MOV ECX, [EBX].TControl.fPaintDC - MOV EDX, EBX - - MOV EAX, [EBX].TControl.fOnPaint.TMethod.Data - CALL dword ptr [EBX].TControl.fOnPaint.TMethod.Code - - MOV ECX, [EBX].TControl.fCanvas - JECXZ @@e_paint - - XCHG EAX, ECX - XOR EDX, EDX - CALL TCanvas.SetHandle - -@@e_paint: - MOV ECX, [ESI].TMsg.wParam - INC ECX - LOOP @@zero_fPaintDC - - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL EndPaint - ADD ESP, szPaintStruct - -@@zero_fPaintDC: - XOR ECX, ECX - MOV [EBX].TControl.fPaintDC, ECX - - POP EAX - MOV [EAX], ECX - - XCHG ECX, [EBX].TControl.fUpdRgn - JECXZ @@exit_True - - PUSH ECX - CALL DeleteObject - -@@exit_True: - POP ESI - POP EBX - MOV AL, 1 - RET - -@@ret_false: - XOR EAX, EAX -end; -{$ELSE PAS_VERSION} //Pascal function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; var PaintStruct: TPaintStruct; Cplxity: Integer; @@ -34049,7 +31387,6 @@ begin end; Result := FALSE; end; -{$ENDIF PAS_VERSION} procedure TControl.SetOnPaint( const Value: TOnPaint ); begin @@ -34058,7 +31395,6 @@ begin AttachProc( WndProcPaint ); end; - function WndProcEraseBkgnd( Sender: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; var PaintStruct: TPaintStruct; OldPaintDC: HDC; @@ -34636,9 +31972,7 @@ function TControl.GetFont: PGraphicTool; begin if FFont = nil then begin FFont := NewFont; - {$IFDEF USE_AUTOFREE4CONTROLS} Add2AutoFree( FFont ); - {$ENDIF} FFont.fData.Color := fTextColor; FFont.OnChange := FontChanged; end; @@ -34651,9 +31985,7 @@ begin FBrush := NewBrush; FBrush.fData.Color := fColor; FBrush.OnChange := BrushChanged; - {$IFDEF USE_AUTOFREE4CONTROLS} Add2AutoFree( FBrush ); - {$ENDIF} end; Result := FBrush; end; @@ -34824,62 +32156,6 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF ASM_noVERSION} // YS -procedure TControl.SetHasBorder(const Value: Boolean); -const style_mask = WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION - or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU; - exstyle_mask = not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME - or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE); -asm - - PUSH EAX - PUSH EDX - - CALL GetHasBorder - POP ECX - CMP AL, CL - - POP EAX - JZ @@exit - - MOV EDX, [EAX].fStyle - DEC CL - MOVZX ECX, [EAX].fIsControl - JNZ @@1 - - OR EDX, WS_THICKFRAME - INC ECX - LOOP @@set_style - OR EDX, style_mask - JMP @@set_style - -@@1: AND EDX, not style_mask - INC ECX - LOOP @@2 - OR EDX, WS_POPUP - -@@2: PUSH EDX - - MOV EDX, [EAX].fExStyle - AND EDX, exstyle_mask - - PUSH EAX - CALL SetExStyle - POP EAX - - POP EDX -@@set_style: - TEST [EAX].fTabStop, 1 - JZ @@no_tabstop - OR DX, WS_TABSTOP - JMP @@set_style_1 -@@no_tabstop: - AND DX, not WS_TABSTOP -@@set_style_1: - CALL SetStyle -@@exit: -end; -{$ELSE PAS_VERSION} //Pascal procedure TControl.SetHasBorder(const Value: Boolean); var NewStyle: DWORD; begin @@ -34913,7 +32189,6 @@ begin else Style := fStyle.Value {xor} and not WS_TABSTOP; {$ENDIF} end; -{$ENDIF PAS_VERSION} {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal function TControl.GetHasCaption: Boolean; @@ -36257,7 +33532,7 @@ var NewStyle: DWORD; begin fTextAlign := Value; NewStyle := 0; - with fCommandActions{$IFDEF COMMANDACTIONS_OBJ}^{$ENDIF} do + with fCommandActions^ do case Value of taLeft: NewStyle := fStyle.Value and not DWORD(aTextAlignCenter or aTextAlignRight) or aTextAlignLeft; @@ -36288,7 +33563,7 @@ procedure TControl.SetVerticalAlign(const Value: TVerticalAlign); var NewStyle: DWORD; begin fVerticalAlign := Value; - with fCommandActions{$IFDEF COMMANDACTIONS_OBJ}^{$ENDIF} do begin + with fCommandActions^ do begin NewStyle := fStyle.Value and not DWORD((bVertAlignTop or bVertAlignCenter or bVertAlignBottom) shl 8); case Value of @@ -36316,9 +33591,7 @@ end; function TControl.GetCanvas: PCanvas; begin - {$IFDEF SAFE_CODE} CreateWindow; - {$ENDIF} if ( fCanvas = nil ) then begin fCanvas := NewCanvas( 0 ); fCanvas.fOnGetHandle := Dc2Canvas; @@ -36348,17 +33621,18 @@ end; {$IFDEF ASM_VERSION}{$ELSE PASCAL} procedure TControl.SetDoubleBuffered(const Value: Boolean); begin - if {$IFDEF USE_FLAGS} (G1_CanNotDoublebuf in fFlagsG1) - {$ELSE} CannotDoubleBuf {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF USE_FLAGS} - if Value then - include( fFlagsG2, G2_DoubleBuffered ) - else exclude( fFlagsG2, G2_DoubleBuffered ); - {$ELSE} fDoubleBuffered := Value; {$ENDIF} - AttachProc(WndProcTransparent); - {$IFNDEF SMALLEST_CODE} - Global_AttachProcExtension := @TransparentAttachProcExtension; - {$ENDIF} + if {$IFDEF USE_FLAGS} (G1_CanNotDoublebuf in fFlagsG1) + {$ELSE} CannotDoubleBuf {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>} + {$IFDEF USE_FLAGS} + if Value then + include( fFlagsG2, G2_DoubleBuffered ) + else + exclude( fFlagsG2, G2_DoubleBuffered ); + {$ELSE} + fDoubleBuffered := Value; + {$ENDIF} + AttachProc(WndProcTransparent); + Global_AttachProcExtension := @TransparentAttachProcExtension; end; procedure TControl.SetTransparent(const Value: Boolean); @@ -36394,66 +33668,6 @@ end; { TTrayIcon } var FTrayItems: PList; -{$IFDEF ASM_noVERSION} // ASM_TLIST! -function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: LRESULT ) : Boolean; -asm - PUSH ECX - MOV ECX, [EDX].TMsg.message - CMP CX, CM_TRAYICON - JNE @@1 - - MOV ECX, [EDX].TMsg.lParam - CMP CX, WM_MOUSELAST - JA @@no_on - MOV EDX, [EDX].TMsg.wParam - MOV EAX, [EDX].TTrayIcon.fOnMouse.TMethod.Data - CMP word ptr [EDX].TTrayIcon.fOnMouse.TMethod.Code+2, 0 - JE @@no_on - - CALL [EDX].TTrayIcon.fOnMouse.TMethod.Code -@@no_on: - POP ECX - XOR EAX, EAX - MOV [ECX], EAX - INC EAX - RET - -@@1: - SUB ECX, WM_CLOSE - JNE @@exit_0 -@@2: - - POP ECX - PUSH EBX - XCHG EBX, EAX - - MOV EAX, [EBX].TControl.fHandle - CMP EAX, [EDX].TMsg.hwnd - JNE @@otherwin - - MOV EDX, [FTrayItems] - MOV ECX, [EDX].TList.fCount - MOV EDX, [EDX].TList.fItems -@@loop: - MOV EAX, [EDX + ECX*4 - 4] - CMP [EAX].TTray.FNoAutoDeactivate, 0 - JNZ @@3 - CMP [EAX].TTrayIcon.fControl, EBX - JNE @@3 - PUSHAD - XOR EDX, EDX - CALL TTrayIcon.SetActive - POPAD -@@3: LOOP @@loop - -@@otherwin: - POP EBX - PUSH ECX -@@exit_0: - XOR EAX, EAX - POP ECX -end; -{$ELSE PAS_VERSION} //Pascal function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: LRESULT ) : Boolean; var Self_: PTrayIcon; I : Integer; @@ -36482,9 +33696,8 @@ begin end; end; end; -{$ENDIF PAS_VERSION} -function WndProcTrayIconWnd( Wnd: HWnd; Msg: DWORD; wParam: WPARAM; lParam: LPARAM ): LRESULT; - stdcall; + +function WndProcTrayIconWnd( Wnd: HWnd; Msg: DWORD; wParam: WPARAM; lParam: LPARAM ): LRESULT; stdcall; var PrevProc: function ( Wnd: HWnd; Msg: DWORD; wParam: Windows.WPARAM; lParam: Windows.LPARAM ): LRESULT; stdcall; var Tr: PTrayIcon; @@ -36694,60 +33907,6 @@ begin Result := KOLCreateMutex(lpMutexAttributes, Integer(Boolean(bInitialOwner)), lpName); end; -{$IFDEF ASM_noUNICODE} -function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean; -asm - PUSH EBX - PUSH ESI - XOR ESI, ESI - PUSH EDI - XCHG EBX, EAX - - CALL EDX2PChar - PUSH EDX - - PUSH 0 - PUSH 1 - PUSH ESI - MOV EDI, offset[CreateMutex] - CALL EDI - - POP EDX - TEST EAX, EAX - JZ @@exit // - PUSH EAX - PUSH EAX - - PUSH EDX - PUSH ESI - PUSH ESI - CALL EDI - MOV [JustOneMutex], EAX - TEST EAX, EAX - JE @@1 // - - PUSH ESI - PUSH EAX - CALL WaitForSingleObject - SUB EAX, WAIT_TIMEOUT - JE @@1 - - INC ESI -@@1: - XCHG EAX, EBX - MOV EDX, offset[WndProcJustOne] - CALL TControl.AttachProc - - CALL ReleaseMutex - CALL CloseHandle - -@@exit: - XCHG EAX, ESI - POP EDI - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean; var CritSecMutex : THandle; DW : Longint; @@ -36763,7 +33922,6 @@ begin Wnd.AttachProc( WndProcJustOne ); CloseHandle( CritSecMutex ); end; -{$ENDIF PAS_VERSION} { JustOneNotify } var @@ -36829,6 +33987,7 @@ begin inherited; {$ENDIF} fNameDelim := DefaultNameDelimiter; + Options := []; //dufa end; procedure TStrList.AddStrings(Strings: PStrList); @@ -36836,6 +33995,14 @@ begin SetText(Strings.Text, True); end; +procedure TStrList.AddStrings_Fast(src: PStrList); +var + i: Integer; +begin + for i := 0 to Pred(src.Count) do + Add(src.Items[i]); +end; + {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal destructor TStrList.Destroy; begin @@ -36921,26 +34088,28 @@ var i: Integer; P: Pointer; begin - // free mem - for i := Idx to Pred(Idx + Len) do begin - if (i >= fCount) then - Break - else begin - P := fList.Items[i]; - if not (Assigned(fTextBuf) and (P >= fTextBuf) and (P < fTextBuf + fTextSiz)) then - FreeMem(P); + if (Len > 0) then begin + // free mem + for i := Idx to Pred(Idx + Len) do begin + if (i >= fCount) then + Break + else begin + P := fList.Items[i]; + if not (Assigned(fTextBuf) and (P >= fTextBuf) and (P < fTextBuf + fTextSiz)) then + FreeMem(P); + end; end; + // delete range from fList + fList.DeleteRange(Idx, Len); + Dec(fCount, Len); end; - // delete range from fList - fList.DeleteRange(Idx, Len); - Dec(fCount, Len); end; procedure TStrList.Remove(Value: Ansistring); //dufa var I: Integer; begin - I := IndexOf(Value); + I := IndexOf_Fast(Value); // dufa -> to fast ver if (I >= 0) then Delete(I); end; @@ -36949,7 +34118,7 @@ procedure TStrList.RemoveNoCase(Value: Ansistring); //dufa var I: Integer; begin - I := IndexOf_NoCase(Value); + I := IndexOf_Fast_NoCase(Value); // dufa -> to fast ver if (I >= 0) then Delete(I); end; @@ -36963,15 +34132,42 @@ begin Delete(I); end; +procedure TStrList.RemoveByNameNoCase(AName: Ansistring); //dufa +var + I: Integer; +begin + I := IndexOfName_NoCase(AName); + if (I >= 0) then + Delete(I); +end; + procedure TStrList.DeleteLast; begin Delete(Pred(fCount)); end; -function TStrList.AddSorted(const S: Ansistring): Integer; //dufa +function TStrList.AddSorted(const S: AnsiString; const Uniq: Boolean = False): Integer; //dufa begin - Find(S, Result); - Insert(Result, S); + if not Find(S, Result) or not Uniq then + Insert(Result, S); +end; + +function TStrList.AddValue(const AName, AValue: AnsiString): Integer; //dufa +begin + Result := Add(AName + fNameDelim + AValue); +end; + +procedure TStrList.InsertValue(Idx: Integer; const AName, AValue: AnsiString); +begin + Insert(Idx, AName + fNameDelim + AValue); +end; + +procedure TStrList.Shuffle; +var + i: Integer; +begin + for i := 0 to Pred(fCount) do + Swap(i, Random(fCount)); end; {$IFDEF ASM_TLIST} @@ -37131,8 +34327,9 @@ begin for Result := 0 to fCount - 1 do if PAnsiChar( fList.Items[Result] )^ = #0 then Exit; {>>>>>>>>>>} end else begin - if not Upper_initialized then + if not IsUpperInit then Init_Upper; + for Result := 0 to fCount - 1 do begin tmp := fList.Items[Result]; c := Upper[S[1]]; @@ -37144,6 +34341,71 @@ begin Result := -1; end; +function TStrList.IndexOf_New(const S: AnsiString): Integer; +var + i: Integer; + OO: PAnsiChar; + S1: PAnsiChar; + S2: PAnsiChar; + C1: AnsiChar; + C2: AnsiChar; +begin + if not IsUpperInit then + Init_Upper; + + OO := PAnsiChar(S); + for i := 0 to Pred(fCount) do begin +// S2 := {Sender.ItemPtrs[i]; //}PCrackList(PCrackStrList(Sender).fList).{$IFDEF TLIST_FAST}Items{$ELSE}fItems{$ENDIF}[i]; // more speed, but safe? +// if (StrComp(S1, S2) = 0) then begin +// Result := i; +// Exit; +// end; + +// S2 := Sender.ItemPtrs[i]; //}PCrackList(PCrackStrList(Sender).fList).{$IFDEF TLIST_FAST}Items{$ELSE}fItems{$ENDIF}[i]; // more speed, but safe? +// N := S1; +// while (S2^ <> #0) and (N^ <> #0) and (Upper[S2^] = Upper[N^]) do begin +// Inc(S2); +// Inc(N); +// end; +// if (S2^ = #0) and (N^ = #0) then begin +// Result := i; +// Exit; +// end; + + // inline compare (faster) + S1 := OO; + S2 := {ItemPtrs[i]; //}fList.{$IFDEF TLIST_FAST}Items{$ELSE}fItems{$ENDIF}[i]; // more speed, but safe? + repeat + // get chars + C1 := S1^; + C2 := S2^; +// if not CaseMatch then begin +// C1 := Upper[C1]; +// C2 := Upper[C2]; +// end; +// // null +// if (C1 = CS) then +// C1 := #0; +// if (C2 = CS) then +// C2 := #0; + // compare + Result := Byte(C1) - Byte(C2); + // is not eq or end? + if (Result <> 0) or (C1 = #0) or (C2 = #0) then + Break; + // next + Inc(S1); + Inc(S2); + until False; + // ret + if (Result = 0) then begin + Result := i; + Exit; + end; + end; + Result := -1; +end; + function TStrList.IndexOf_Fast(const S: AnsiString): Integer; var i: Integer; @@ -37174,7 +34436,7 @@ var N: PAnsiChar; O: PAnsiChar; begin - if not Upper_Initialized then + if not IsUpperInit then Init_Upper; O := PAnsiChar(S); @@ -37208,55 +34470,97 @@ begin end; end; +procedure TStrList.UpdateCompare; +begin + if (sloAnsi in FOptions) then begin + if (sloCaseSensitive in FOptions) then + FCompare := _AnsiCompareStrA //CompareAnsiCase + else + FCompare := _AnsiCompareStrNoCaseA //CompareAnsiNoCase; + end else begin + if (sloCaseSensitive in FOptions) then + FCompare := StrComp + else + FCompare := StrComp_NoCase; + end; +end; + +procedure TStrList.SetOptions(const Value: TStrListOptions); +begin + FOptions := Value; + UpdateCompare; +end; + function TStrList.Find(const S: AnsiString; var Index: Integer): Boolean; var L, H, C: Integer; K: PAnsiChar; + N: PAnsiChar; begin Result := False; Index := 0; L := 0; H := Pred(FCount); if (H < 0) then - Exit; // === if FCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>} + Exit; - if fAnsiSort then begin - if fCaseSensitiveSort then - fCompareStrListFun := _AnsiCompareStrA //CompareAnsiCase - else - fCompareStrListFun := _AnsiCompareStrNoCaseA //CompareAnsiNoCase; - end else begin - if fCaseSensitiveSort then - fCompareStrListFun := StrComp - else - fCompareStrListFun := StrComp_NoCase; - end; - C := 0; K := PAnsiChar(S); while (L <= H) do begin Index := (L + H) shr 1; - C := fCompareStrListFun(fList.Items[Index], K); - if (C < 0) then + // line or linename //dufa + if (sloNames in FOptions) then + N := PAnsiChar(LineName[Index]) + else + N := fList.{$IFDEF TLIST_FAST}Items{$ELSE}fItems{$ENDIF}[Index]; + + C := FCompare(N, K); + if (C < 0) then L := Succ(Index) else begin if (C = 0) then begin Result := True; {Index := I;} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + Exit; end; H := Pred(Index); end; end; if (C < 0) then - Index := L; // "-L" => "L" (why minus, wtf?) + Index := L; // "-L" => "L" (dufa: why minus, wtf?) +end; + +function TStrList.FindVCL_(const S: string; var Index: Integer): Boolean; +var + L, H, I, C: Integer; + K: PAnsiChar; +begin + Result := False; + L := 0; + H := Pred(fCount); + K := PAnsiChar(S); + while (L <= H) do begin + I := (L + H) shr 1; + C := FCompare(fList.Items[I], K); + if (C < 0) then + L := Succ(I) + else begin + H := Pred(I); + if (C = 0) then begin + Result := True; +// if Duplicates <> dupAccept then + L := I; + end; + end; + end; + Index := L; end; function TStrList.FindFirst(const S: AnsiString; var Index: Integer): Boolean; begin Result := Find(S, Index); if Result then begin - while (Index > 0) and (fCompareStrListFun(PAnsiChar(fList.Items[Pred(Index)]), PAnsiChar(S)) = 0) do + while (Index > 0) and (FCompare(PAnsiChar(fList.Items[Pred(Index)]), PAnsiChar(S)) = 0) do Dec(Index); end; end; @@ -37477,168 +34781,112 @@ begin end; {$IFDEF ASM_TLIST} -function CompareStrListItems_NoCase( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; +function CompareStrListItems(const Sender: Pointer; const e1, e2: DWORD): Integer; // dufa asm - MOV EAX, [EAX].TStrList.fList - MOV EAX, [EAX].TList.fItems - MOV EDX, [EAX+EDX*4] - MOV EAX, [EAX+ECX*4] - XCHG EAX, EDX - JMP StrComp_NoCase -end; + PUSH [EAX].TStrList.FCompare // save comparer -function CompareStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -asm - MOV EAX, [EAX].TStrList.fList - MOV EAX, [EAX].TList.fItems - MOV EDX, [EAX+EDX*4] - MOV EAX, [EAX+ECX*4] - XCHG EAX, EDX - JMP StrComp -end; + MOV EAX, [EAX].TStrList.fList + MOV EAX, [EAX].TList.fItems + MOV EDX, [EAX + e1 * 4] //EDX + MOV EAX, [EAX + e2 * 4] //ECX + XCHG EAX, EDX -function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -asm - MOV EAX, [EAX].TStrList.fList - MOV EAX, [EAX].TList.fItems - MOV EDX, [EAX+EDX*4] - MOV EAX, [EAX+ECX*4] - XCHG EAX, EDX - JMP _AnsiCompareStrNoCase + POP ECX // restore comparer - + CALL ECX // - and call end; - -function CompareAnsiStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -asm - MOV EAX, [EAX].TStrList.fList - MOV EAX, [EAX].TList.fItems - MOV EDX, [EAX+EDX*4] - MOV EAX, [EAX+ECX*4] - XCHG EAX, EDX - JMP _AnsiCompareStr -end; -{$ELSE PAS_VERSION} //Pascal -function CompareStrListItems_NoCase( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var S1, S2 : PAnsiChar; +{$ELSE PAS_VERSION} +function CompareStrListItems(const Sender: Pointer; const e1, e2: DWORD): Integer; // dufa +var + S1: PAnsiChar; + S2: PAnsiChar; + List: PStrList absolute Sender; begin - S1 := PStrList( Sender ).fList.Items[ e1 ]; - S2 := PStrList( Sender ).fList.Items[ e2 ]; - Result := StrComp_NoCase( S1, S2 ); -end; - -function CompareStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var S1, S2 : PAnsiChar; -begin - S1 := PStrList( Sender ).fList.Items[ e1 ]; - S2 := PStrList( Sender ).fList.Items[ e2 ]; - Result := StrComp( S1, S2 ); -end; - -function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var S1, S2 : PAnsiChar; -begin - S1 := PStrList( Sender ).fList.Items[ e1 ]; - S2 := PStrList( Sender ).fList.Items[ e2 ]; - Result := _AnsiCompareStrNoCaseA( S1, S2 ); -end; - -function CompareAnsiStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var S1, S2 : PAnsiChar; -begin - S1 := PStrList( Sender ).fList.Items[ e1 ]; - S2 := PStrList( Sender ).fList.Items[ e2 ]; - Result := _AnsiCompareStrA( S1, S2 ) + S1 := List.ItemPtrs[e1]; + S2 := List.ItemPtrs[e2]; + Result := List.Compare(S1, S2); end; {$ENDIF PAS_VERSION} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TStrList.Sort(CaseSensitive: Boolean); +function CompareStrListNames(const Sender: Pointer; const e1, e2: DWORD): Integer; // dufa +//var +// S1: String; +// S2: String; +// List: PStrList absolute Sender; +//begin +// S1 := List.LineName[e1]; +// S2 := List.LineName[e2]; +// Result := List.Compare(PAnsiChar(S1), PAnsiChar(S2)); +var + S1: PAnsiChar; + S2: PAnsiChar; + C1: AnsiChar; + C2: AnsiChar; + CS: AnsiChar; + CaseMatch: Boolean; begin - fCaseSensitiveSort := CaseSensitive; - fAnsiSort := FALSE; - {$IFDEF SPEED_FASTER} - {$DEFINE SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF TLIST_FAST} - {$UNDEF SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF SORT_STRLIST_ARRAY} - if Count > 1 then - if CaseSensitive then - SortArray( fList.fItems, fCount, @StrComp ) - else - SortArray( fList.fItems, fCount, @StrComp_NoCase ); - {$ELSE} - if CaseSensitive then - SortData( @Self, fCount, @CompareStrListItems_Case, @TStrList.Swap ) - else - SortData( @Self, fCount, @CompareStrListItems_NoCase, @TStrList.Swap ) - {$ENDIF} + if not IsUpperInit then + Init_Upper; + // get full items + S1 := PStrList(Sender).ItemPtrs[e1]; + S2 := PStrList(Sender).ItemPtrs[e2]; + CS := PStrList(Sender).NameDelimiter; + CaseMatch := (sloCaseSensitive in PStrList(Sender).Options); + // inline compare (faster) + repeat + // get chars + C1 := S1^; + C2 := S2^; + if not CaseMatch then begin + C1 := Upper[C1]; + C2 := Upper[C2]; + end; + // null + if (C1 = CS) then + C1 := #0; + if (C2 = CS) then + C2 := #0; + // compare + Result := Byte(C1) - Byte(C2); + // is not eq or end? + if (Result <> 0) or (C1 = #0) or (C2 = #0) then + Break; + // next + Inc(S1); + Inc(S2); + until False; end; -{$ENDIF PAS_VERSION} -{$IFDEF noASM_VERSION} -procedure TStrList.AnsiSort(CaseSensitive: Boolean); -asm - MOV [EAX].fCaseSensitiveSort, DL - MOV [EAX].fAnsiSort, 1 - {$IFDEF SORT_STRLIST_ARRAY} - MOV ECX, Offset[_AnsiCompareStrA] - CMP DL, 0 - JNZ @@01 - MOV ECX, [_AnsiCompareStrNoCaseA] -@@01: - MOV EAX, [EAX].fList - MOV EDX, [EAX].TList.fCount - CMP EDX, 1 - JLE @@02 - MOV EAX, [EAX].TList.fItems - CALL SortArray -@@02: - {$ELSE} - PUSH Offset[TStrList.Swap] - MOV ECX, Offset[CompareAnsiStrListItems] - CMP DL, 0 - JNZ @1 - MOV ECX, Offset[CompareAnsiStrListItems_Case] -@1: MOV EDX, [EAX].fCount - CALL SortData - {$ENDIF} -end; -{$ELSE PAS_VERSION} //Pascal -procedure TStrList.AnsiSort(CaseSensitive: Boolean); +procedure TStrList.Sort(AOptions: TStrListOptions); // dufa begin - fCaseSensitiveSort := CaseSensitive; - fAnsiSort := TRUE; - {$IFDEF SPEED_FASTER} - {$DEFINE SORT_STRLIST_ARRAY} - {$ENDIF} + SetOptions(AOptions); + + {$DEFINE SORT_STRLIST_ARRAY} {$IFDEF TLIST_FAST} - {$UNDEF SORT_STRLIST_ARRAY} + {$UNDEF SORT_STRLIST_ARRAY} {$ENDIF} - if Count > 1 then begin - {$IFDEF SPEED_FASTER} - if CaseSensitive then // to prepare !!! - _AnsiCompareStrA( ItemPtrs[0], ItemPtrs[1] ) - else _AnsiCompareStrNoCaseA( ItemPtrs[0], ItemPtrs[1] ); - {$ENDIF} + + if (Count > 1) then begin + if (sloNames in AOptions) then // SortByName + SortData(@Self, fCount, CompareStrListNames, @TStrList.Swap) + else {$IFDEF SORT_STRLIST_ARRAY} - if CaseSensitive then - SortArray( fList.fItems, fCount, @_AnsiCompareStrA ) - else - SortArray( fList.fItems, fCount, @_AnsiCompareStrNoCaseA ); + SortArray(fList.fItems, fCount, @FCompare); {$ELSE} - if CaseSensitive then - SortData( @Self, fCount, @CompareAnsiStrListItems_Case, @TStrList.Swap ) - else - SortData( @Self, fCount, @CompareAnsiStrListItems, @TStrList.Swap ); + SortData(@Self, fCount, CompareStrListItems, @TStrList.Swap); {$ENDIF} end; end; -{$ENDIF PAS_VERSION} -procedure TStrList.SortEx(const CompareFun: TCompareEvent); +procedure TStrList.SortEx(const CompareFun: TCompareEvent; const SwapProc: TSwapEvent); // dufa begin - SortData(@Self, Count, CompareFun, @TStrList.Swap); + if (Count > 1) then + SortData(@Self, fCount, CompareFun, SwapProc); +end; + +procedure TStrList.SortEx(const CompareFun: TCompareEvent); // dufa +begin + if (Count > 1) then + SortData(@Self, fCount, CompareFun, @TStrList.Swap); end; procedure TStrList.Swap(Idx1, Idx2: Integer); @@ -37654,6 +34902,14 @@ begin Result := Items[Pred(fCount)]; end; +function TStrList.First: AnsiString; +begin + if (fCount = 0) then + Result := '' + else + Result := Items[0]; +end; + function TStrList.IndexOfName(const AName: AnsiString): Integer; //dufa var i: Integer; @@ -37684,7 +34940,7 @@ var N: PAnsiChar; O: PAnsiChar; begin - if not Upper_Initialized then + if not IsUpperInit then Init_Upper; O := PAnsiChar(AName); @@ -37727,6 +34983,21 @@ var begin I := IndexOfName_NoCase(AName); if (I >= 0) then begin + S := Items[i]; + L := Length(AName); + Result := Copy(S, L + 2, Length(S) - L - 1); + //^Result := GetLineValue(I) + end else + Result := ''; +end; + +function TStrList.GetValueSorted(const AName: AnsiString): AnsiString; +var + i: Integer; + L: Integer; + S: AnsiString; +begin + if Find(AName, i) then begin S := Items[i]; L := Length(AName); Result := Copy(S, L + 2, Length(S) - L - 1); @@ -37761,25 +35032,51 @@ begin Items[I] := S; end; -function TStrList.GetLineName(Idx: Integer): AnsiString; -var S: AnsiString; - Q: PAnsiChar; +procedure TStrList.SetValueSorted(const AName, Value: AnsiString); +var + I: Integer; begin - S := ItemPtrs[Idx]; - Q := StrScan(PAnsiChar(S), fNameDelim); - if Assigned(Q) then // by Dufa - Q^ := #0; - Result := PAnsiChar(S); + if Find(AName, I) then + Items[I] := AName + fNameDelim + Value + else + InsertValue(i, AName, Value); +end; + +function TStrList.GetLineName(Idx: Integer): AnsiString; // by Dufa +var + S: PAnsiChar; + Q: PAnsiChar; +begin + if (Idx < 0) or (Idx >= fCount) then + Result := '' + else begin + S := fList.{$IFDEF TLIST_FAST}Items{$ELSE}fItems{$ENDIF}[Idx]; //ItemPtrs[Idx]; + Q := StrScan(S, fNameDelim); + if Assigned(Q) then + SetString(Result, S, Q - S) + else + Result := S; +//KOL_old: +// S := ItemPtrs[Idx]; +// Q := StrScan(PAnsiChar(S), fNameDelim); +// if Assigned(Q) then // by Dufa +// Q^ := #0; +// Result := PAnsiChar(S); + end; end; function TStrList.GetLineValue(Idx: Integer): AnsiString; var Q: PAnsiChar; begin - Q := ItemPtrs[Idx]; - Q := StrScan(Q, fNameDelim); - if Assigned(Q) then - Inc(Q); - Result := Q; + if (Idx < 0) or (Idx >= fCount) then // by Dufa + Result := '' + else begin + Q := ItemPtrs[Idx]; + Q := StrScan(Q, fNameDelim); + if Assigned(Q) then + Inc(Q); + Result := Q; + end; end; procedure TStrList.SetLineName(Idx: Integer; const NV: AnsiString); @@ -37792,27 +35089,38 @@ begin Items[Idx] := LineName[Idx] + fNameDelim + Value; end; -function TStrList.Join( const sep: AnsiString ): AnsiString; +function TStrList.Join(const sep: AnsiString; const AddLastSep: Boolean = True): AnsiString; var - I, Len, Size: integer; - P: PAnsiChar; + I, Len, Size: integer; + P: PAnsiChar; begin - Size := 0; + if (fCount = 0) then begin //dufa + Result := ''; + Exit; + end; - for I := 0 to Count - 1 do - Inc(Size, Integer( StrLen( ItemPtrs[I] ) ) + Length(Sep)); + Size := 0; + for I := 0 to Pred(fCount) do begin + Inc(Size, Integer(StrLen(ItemPtrs[I]))); + // dufa + if AddLastSep or (I < Pred(fCount)) then + Inc(Size, Length(Sep)); + end; SetString(Result, nil, Size); - P := @ Result[ 1 ]; - for I := 0 to Count - 1 do begin - Len := StrLen( ItemPtrs[I] ); + P := @Result[1]; + for I := 0 to Pred(fCount) do begin + Len := StrLen(ItemPtrs[I]); if (Len > 0) then begin - System.Move( ItemPtrs[I]^, P^, Len); + System.Move(ItemPtrs[I]^, P^, Len); Inc(P, Len); end; - P := StrPCopy(P, Sep); - inc( P, Length( Sep ) ); // + by Korneev Ivan + // dufa + if AddLastSep or (I < Pred(fCount)) then begin + P := StrPCopy(P, Sep); + Inc(P, Length(Sep)); // + by Korneev Ivan + end; end; end; @@ -37948,23 +35256,34 @@ end; function TStrList.Count2: Integer; // * by dufa begin - Result := fCount div ColsCount; + if (ColsCount = 0) then + Result := 0 + else + Result := fCount div ColsCount; end; procedure TStrList.Insert2(Idx: Integer; const S: array of AnsiString); // * by dufa var - i: Integer; - L: Integer; - k: AnsiString; + col: Integer; + len: Integer; + buf: AnsiString; begin - L := Length(S); - for i := Pred(ColsCount) downto 0 do begin - if (i < L) then - k := S[i] + len := Length(S); +// for col := Pred(ColsCount) downto 0 do begin +// if (col < len) then +// buf := S[col] +// else +// buf := ''; +// // insert +// Insert(Idx * ColsCount, buf); +// end; + for col := 0 to Pred(ColsCount) do begin + if (col < len) then + buf := S[col] else - k := ''; + buf := ''; // insert - Insert(Idx * ColsCount, k) + Insert(Idx * ColsCount + col, buf); end; end; @@ -37981,7 +35300,10 @@ end; function TStrList.GetRandomItem: AnsiString; begin - Result := Items[Random(fCount)]; + if (fCount = 0) then + Result := '' + else + Result := Items[Random(fCount)]; end; procedure TStrList.Delete2(Idx: integer); @@ -38007,23 +35329,41 @@ begin Swap(Idx1 * ColsCount + Col, Idx2 * ColsCount + Col); end; -function TStrList.IndexOf2(const S2: array of AnsiString): Integer; +function TStrList.IndexOf2(const S: array of AnsiString; const FullMatch: Boolean): Integer; var i: Integer; z: Integer; + C: Integer; found: Boolean; begin - // find - for i := 0 to Pred(Count2) do begin - found := True; - for z := 0 to Pred(ColsCount) do begin - if (Items2[i, z] <> S2[z]) then begin - found := False; - Break; + C := Length(S); + if not FullMatch or (C = ColsCount) then begin + // find + for i := 0 to Pred(Count2) do begin + found := True; + for z := 0 to Pred(Min(ColsCount, C)) do begin + if (Items2[i, z] <> S[z]) then begin + found := False; + Break; + end; + end; + // found + if found then begin + Result := i; + Exit; end; end; - // found - if found then begin + end; + // not found + Result := -1; +end; + +function TStrList.IndexOf2(const S: AnsiString; const Col: Integer): Integer; +var + i: Integer; +begin + for i := 0 to Pred(Count2) do begin + if (Items2[i, Col] = S) then begin Result := i; Exit; end; @@ -38032,6 +35372,44 @@ begin Result := -1; end; +function TStrList.IndexOf2_NoCase(const S: AnsiString; const Col: Integer): Integer; +var + i: Integer; + P: PAnsiChar; + N: PAnsiChar; + O: PAnsiChar; +begin + if not IsUpperInit then + Init_Upper; + + O := PAnsiChar(S); + for i := 0 to Pred(Count2) do begin + P := PAnsiChar(Items2[i, Col]); + N := O; + while (P^ <> #0) and (N^ <> #0) and (Upper[P^] = Upper[N^]) do begin + Inc(P); + Inc(N); + end; + if (P^ = #0) and (N^ = #0) then begin + Result := i; + Exit; + end; + end; + // not found + Result := -1; +end; + +function TStrList.Last2(Col: Integer): AnsiString; +var + z: Integer; +begin + z := Count2; + if (z = 0) then + Result := '' + else + Result := Items2[Pred(z), Col]; +end; + procedure TStrList.ItemFirst; begin FItemIndex := 0; @@ -38070,7 +35448,7 @@ end; var HelpMessageIndex: UINT = 0; -function WndProcFontDialog(Control: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; +function WndProcFontDialog(Control: PControl; var Msg: TMsg; var Rslt: LRESULT): Boolean; var Self: PFontDialog; begin @@ -38269,34 +35647,7 @@ begin end; ////////////////////////////////// EXTENDED STRING LIST OBJECT //////////////// -{$IFDEF PAS_ONLY} -procedure WStrCopy( Dest, Src: PWideChar ); -begin - while Src^ <> #0 do begin - Dest^ := Src^; - inc(Src); - inc(Dest); - end; - Dest^ := #0; //dmiko -end; -{$ELSE} -procedure WStrCopy( Dest, Src: PWideChar ); -asm - PUSH EDI - PUSH ESI - MOV ESI,EAX - MOV EDI,EDX - OR ECX, -1 - XOR EAX, EAX - REPNE SCASW - NOT ECX - MOV EDI,ESI - MOV ESI,EDX - REP MOVSW - POP ESI - POP EDI -end; -{$ENDIF} + procedure WStrLCopy( Dest, Src: PWideChar; MaxLen: Integer ); begin while MaxLen > 0 do begin @@ -38310,39 +35661,6 @@ begin end; end; -{$IFDEF PAS_ONLY} -function WStrCmp( W1, W2: PWideChar ): Integer; -begin - while (W1^ <> #0) and (w2^ <> #0) do begin - Result := Integer(Ord(w1^)) - Integer(Ord(w2^)); - if Result <> 0 then Exit; - inc(w1); - inc(w2); - end; - Result := 0; -end; -{$ELSE} -function WStrCmp( W1, W2: PWideChar ): Integer; -asm - PUSH ESI - PUSH EDI - XCHG ESI, EAX - MOV EDI, EDX - XOR EAX, EAX -@@loop: LODSW - MOVZX EDX, word ptr [EDI] - INC EDI - INC EDI - CMP EAX, EDX - JNE @@exit - TEST EAX, EAX - JNZ @@loop -@@exit: SUB EAX, EDX - POP EDI - POP ESI -end; -{$ENDIF} - function WStrCmp_NoCase( W1, W2: PWideChar ): Integer; begin Result := 0; @@ -38395,39 +35713,31 @@ begin FObjects := NewList; end; -procedure SwapStrListExItems( const Sender: Pointer; const e1, e2: DWORD ); +procedure SwapStrListExItems(const Sender: Pointer; const e1, e2: DWORD); begin - PStrListEx( Sender ).Swap( e1, e2 ); + PStrListEx(Sender).Swap(e1, e2); end; -procedure TStrListEx.AnsiSort(CaseSensitive: Boolean); +procedure TStrListEx.Sort(AOptions: TStrListOptions); // dufa begin - fCaseSensitiveSort := CaseSensitive; - fAnsiSort := TRUE; - if CaseSensitive then - SortData( @Self, fCount, @CompareAnsiStrListItems_Case, @SwapStrListExItems ) + SetOptions(AOptions); + + if (sloNames in AOptions) then // SortByName + SortEx(CompareStrListNames) else - SortData( @Self, fCount, @CompareAnsiStrListItems, @SwapStrListExItems ) + SortEx(CompareStrListItems); end; -procedure TStrListEx.Sort(CaseSensitive: Boolean); +procedure TStrListEx.SortEx(const CompareFun: TCompareEvent); // dufa begin - fCaseSensitiveSort := CaseSensitive; - fAnsiSort := FALSE; - if CaseSensitive then - SortData( @Self, fCount, @CompareStrListItems_Case, @SwapStrListExItems ) - else SortData( @Self, fCount, @CompareStrListItems_NoCase, @SwapStrListExItems ); -end; - -procedure TStrListEx.SortEx(const CompareFun: TCompareEvent); -begin - SortData(@Self, Count, CompareFun, @TStrListEx.Swap); + if (fCount > 1) then + SortData(@Self, fCount, CompareFun, @TStrListEx.Swap); //SwapStrListExItems end; procedure TStrListEx.Move(CurIndex, NewIndex: integer); begin // move string - fList.MoveItem( CurIndex, NewIndex ); + fList.MoveItem(CurIndex, NewIndex); // move object if FObjects.fCount >= Min( CurIndex, NewIndex ) then begin ProvideObjCapacity( max( CurIndex, NewIndex ) + 1 ); @@ -38557,32 +35867,6 @@ begin FreeMem( Buffer ); end; -{$IFNDEF PAS_ONLY} -function WStrLen( W: PWideChar ): Integer; -asm - XCHG EDI, EAX - XCHG EDX, EAX - OR ECX, -1 - XOR EAX, EAX - CMP EAX, EDI - JE @@exit0 - REPNE SCASW - DEC EAX - DEC EAX - SUB EAX, ECX -@@exit0: - MOV EDI, EDX -end; -{$ELSE} -function WStrLen( W: PWideChar ): Integer; -begin - Result := 0; - while W^ <> #0 do begin - Inc(Result); - Inc(W); - end; -end; -{$ENDIF} {------------------------------------------------------------------------------) | | | T W S t r L i s t | @@ -39518,11 +36802,7 @@ end; procedure SortIntegerArray( var A : array of Integer ); begin - {$IFDEF SPEED_FASTER} SortArray( @A[ 0 ], High(A)-Low(A)+1, @Compare2Integers ); - {$ELSE} - SortData( @A[ 0 ], High(A)-Low(A)+1, @CompareIntegers, @SwapIntegers ); - {$ENDIF} end; procedure SwapListItems( const L: Pointer; const e1, e2: DWORD ); @@ -39532,11 +36812,7 @@ end; procedure SortDwordArray( var A : array of DWORD ); begin - {$IFDEF SPEED_FASTER} SortArray( @A[0], High(A)-Low(A)+1, @Compare2DWORDS ); - {$ELSE} - SortData( @A[ 0 ], High(A)-Low(A)+1, @CompareDwords, @SwapIntegers ); - {$ENDIF} end; { -- status bar implementation -- } @@ -39609,61 +36885,6 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF noASM_UNICODE} -function TControl.GetStatusText( Index: Integer ): KOLString; -asm - MOV ECX, [EAX].fStatusCtl - JECXZ @@exit - PUSH EBX - PUSH ESI - XCHG ESI, EAX // ESI = @Self - MOV EBX, EDX // EBX = Index - XOR EAX, EAX - XCHG EAX, [ESI].fStatusTxt - TEST EAX, EAX - JZ @@1 - CALL System.@FreeMem -@@1: - XOR EAX, EAX - CDQ - MOV DL, WM_GETTEXTLENGTH - PUSH WM_GETTEXT - CMP EBX, 255 - JZ @@2 - POP EAX - MOV EAX, EBX - MOV DX, SB_GETTEXTLENGTH - PUSH SB_GETTEXT -@@2: - MOV EBX, EAX - PUSH 0 - PUSH EAX - PUSH EDX - PUSH [ESI].fStatusCtl - CALL Perform - TEST AX, AX - JZ @@get_rslt - PUSH EAX - INC EAX - CALL System.@GetMem - POP EDX - MOV [ESI].fStatusTxt, EAX - MOV byte ptr [EAX+EDX], 0 - POP EDX // Msg - PUSH EAX - PUSH EBX - PUSH EDX - PUSH [ESI].fStatusCtl - CALL Perform - PUSH EDX -@@get_rslt: - POP EDX - MOV ECX, [ESI].fStatusTxt - POP ESI - POP EBX -@@exit: XCHG EAX, ECX -end; -{$ELSE PAS_VERSION} //Pascal function TControl.GetStatusText( Index: Integer ): KOLString; var L, I: Integer; Msg: DWORD; @@ -39685,7 +36906,6 @@ begin fStatusCtl.Perform( Msg, I, LPARAM( @ Result[1] ) ); end; end; -{$ENDIF PAS_VERSION} {$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal procedure TControl.RemoveStatus; @@ -39775,9 +36995,7 @@ begin if AOwner.fImageList <> nil then PImageList( AOwner.fImageList ).fPrev := Result; Result.FControl := AOwner; - {$IFDEF USE_AUTOFREE4CONTROLS} AOwner.Add2AutoFree( Result ); - {$ENDIF} AOwner.fImageList := Result; end; @@ -39927,9 +37145,7 @@ begin if fControl <> nil then begin if PControl( fControl ).fImageList = @Self then PControl( fControl ).fImageList := fNext; - {$IFDEF USE_AUTOFREE4CONTROLS} PControl(fControl).RemoveFromAutoFree( @ Self ); - {$ENDIF} end; inherited; end; @@ -40007,45 +37223,6 @@ begin Result := II.hbmMask; end; -{$IFDEF ASM_noVERSION} -function TImageList.HandleNeeded: Boolean; -const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR, - ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24, - ILC_COLOR32, ILC_COLORDDB ); -asm - MOV ECX, [EAX].FHandle - JECXZ @@make_handle - MOV AL, 1 - RET -@@make_handle: - MOV ECX, [EAX].fImgWidth - JECXZ @@ret_ECX - MOV EDX, ECX - MOV ECX, [EAX].fImgHeight - JECXZ @@ret_ECX - PUSH EBX - XCHG EBX, EAX - - PUSH [EBX].FAllocBy - PUSH 0 - MOVZX EAX, [EBX].FColors - MOVZX EAX, byte ptr [ColorFlags+EAX] - CMP [EBX].FMasked, 0 - JZ @@flags_ready - OR AL, 1 -@@flags_ready: - PUSH EAX - PUSH ECX - PUSH EDX - CALL ImageList_Create - MOV [EBX].FHandle, EAX - XCHG ECX, EAX - POP EBX -@@ret_ECX: - TEST ECX, ECX - SETNZ AL -end; -{$ELSE PAS_VERSION} //Pascal function TImageList.HandleNeeded: Boolean; const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR, ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24, @@ -40065,7 +37242,7 @@ begin SetBkColor( fBkColor ); Result := FHandle <> 0; end; -{$ENDIF PAS_VERSION} + function TImageList.ImgRect(Idx: Integer): TRect; var II : TImageInfo; begin @@ -40075,39 +37252,7 @@ begin Result := II.rcImage; end; -{$IFDEF ASM_noVERSION_UNICODE} -function TImageList.LoadBitmap(ResourceName: PAnsiChar; - TranspColor: TColor): Boolean; -asm - PUSH EBX - XCHG EBX, EAX - XCHG EAX, ECX //TranspColor - PUSH EDX - CMP EAX, clNone - JNE @@2rgb - OR EAX, -1 - JMP @@tranColorReady -@@2rgb: - CALL Color2RGB -@@tranColorReady: - POP EDX - PUSH EAX - PUSH [EBX].fAllocBy - PUSH [EBX].fImgWidth - PUSH EDX - PUSH [hInstance] - CALL ImageList_LoadBitmap - TEST EAX, EAX - JZ @@exit - XCHG EDX, EAX - XCHG EAX, EBX - CALL SetHandle - MOV AL, 1 -@@exit: POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function TImageList.LoadBitmap(ResourceName: PKOLChar; - TranspColor: TColor): Boolean; +function TImageList.LoadBitmap(ResourceName: PKOLChar; TranspColor: TColor): Boolean; var NewHandle : THandle; TranColr: TColor; begin @@ -40122,9 +37267,8 @@ begin Handle := NewHandle; ImageList_GetIconSize( fHandle, FImgWidth, FImgHeight ); end; -{$ENDIF PAS_VERSION} -function TImageList.LoadFromFile(FileName: PKOLChar; TranspColor: TColor; - ImgType: TImageType): Boolean; + +function TImageList.LoadFromFile(FileName: PKOLChar; TranspColor: TColor; ImgType: TImageType): Boolean; const ImgTypes:array[ TImageType ] of DWord = ( IMAGE_BITMAP, IMAGE_ICON, IMAGE_CURSOR ); var NewHandle : THandle; TranspFlag : DWord; @@ -40330,7 +37474,7 @@ begin begin LVDisp := Pointer( Msg.lParam ); Result := True; - if LVDisp.item.pszText = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>} +//dufa wtf? if LVDisp.item.pszText = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>} Rslt := 1; {$IFDEF NIL_EVENTS} if assigned( Self_.EV.fOnEndEditLVItem ) then @@ -41293,69 +38437,7 @@ begin end; { -- Toolbar -- } -{$IFDEF ASM_noVERSION} // width -procedure TControl.TBAddBitmap(Bitmap: HBitmap); -const szBI = sizeof(TBitmapInfo); -asm - TEST EDX, EDX - JZ @@exit - JGE @@1 - CMP EDX, -6 - JL @@1 - NEG EDX - DEC EDX - PUSH EDX - PUSH -1 - XOR EDX, EDX - JMP @@2 -@@1: PUSH EDX // AB.hInst = Bitmap - PUSH 0 // AB.nID = 0 - PUSH EAX // > @Self - ADD ESP, -szBI - PUSH ESP - PUSH szBI - PUSH EDX - CALL GetObject - TEST EAX, EAX - JG @@11 - ADD ESP, szBI - JMP @@exit -@@11: MOV EAX, [ESP].TBitmapInfo.bmiHeader.biWidth - MOV ECX, [ESP].TBitmapInfo.bmiHeader.biHeight - TEST ECX, ECX - JGE @@12 - NEG ECX -@@12: ADD ESP, szBI - CDQ // EDX = 0 - DIV ECX // EAX = N - XCHG EAX, [ESP] // > N - PUSH EAX // > @Self - MOV EDX, ECX - SHL EDX, 16 - OR ECX, EDX - CDQ - PUSH EDX - PUSH EDX - PUSH TB_AUTOSIZE - PUSH EAX - PUSH ECX - PUSH EDX - PUSH TB_SETBITMAPSIZE - PUSH EAX - CALL Perform - CALL Perform - POP EAX - POP EDX -@@2: PUSH ESP - PUSH EDX - PUSH TB_ADDBITMAP - PUSH EAX - CALL Perform - POP ECX - POP ECX -@@exit: -end; -{$ELSE PAS_VERSION} //Pascal + procedure TControl.TBAddBitmap(Bitmap: HBitmap); const NstdBitmaps: array[ 0..5 ] of THandle = ( 15, 15, 0, 0, 13, 13 ); var BI: TBitmapInfo; @@ -41380,7 +38462,6 @@ begin end else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} Perform( TB_ADDBITMAP, N, LPARAM( @AB ) ); end; -{$ENDIF PAS_VERSION} {$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal function TControl.TBAddInsButtons(Idx: Integer; const Buttons: array of PKOLChar; @@ -41690,10 +38771,8 @@ begin if ( DF.fTBttCmd = nil ) then begin DF.fTBttCmd := NewList; DF.fTBttTxt := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF}; - {$IFDEF USE_AUTOFREE4CONTROLS} Add2AutoFree( DF.fTBttCmd ); Add2AutoFree( DF.fTBttTxt ); - {$ENDIF} end; for I:= Low( Tooltips ) to High( Tooltips ) do begin J := DF.fTBttCmd.IndexOf( Pointer(PtrUInt( BtnID1st )) ); @@ -41817,30 +38896,12 @@ begin fCommandActions.aClear( @Self ); end; -{$IFDEF ASM_noVERSION} -function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer; -const szTBButton = sizeof( TTBButton ); -asm - ADD ESP, -szTBButton - PUSH ESP - PUSH EAX - CALL TBItem2Index - POP EDX - PUSH EAX - PUSH TB_GETBUTTON - PUSH EDX - CALL Perform - POP EAX - ADD ESP, szTBButton-4 -end; -{$ELSE PAS_VERSION} //Pascal function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer; var B: TTBButton; begin Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID ) ), LPARAM( @B ) ); Result := B.iBitmap; end; -{$ENDIF PAS_VERSION} procedure TControl.TBSetBtnImgIdx(BtnID: Integer; const Value: Integer); begin @@ -41878,7 +38939,7 @@ begin end; {$ENDIF PAS_VERSION} -procedure TControl.TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer); +procedure TControl.TBSetBtMinMaxWidth(const Idx, Value: Integer); begin case Idx of 0: DF.fTBBtMinWidth := Value; @@ -41948,10 +39009,8 @@ begin Perform( fCommandActions.aDir, Attrs, LPARAM( PKOLChar( Filemask ) ) ); end; {$ENDIF PAS_VERSION} -{$IFDEF ASM_noVERSION} -{$ELSE PAS_VERSION} //Pascal + function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; -//var Accept: Boolean; // {Alexander Pravdin, AP} begin Result := FALSE; if Msg.message = WM_CLOSE then begin @@ -41959,14 +39018,11 @@ begin Self_.DF.fModalResult := -1; Rslt := 0; Result := True; // Do not process ! - end - ; + end; end; -{$ENDIF PAS_VERSION} // by TR"]F -function WndProcFixModal( Self_: PControl; var Msg: TMsg; var Rslt: -LRESULT ): Boolean; +function WndProcFixModal( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; const HTERROR = $FFFE; LBtnDown = $201; LBtnUp = $202; @@ -42009,129 +39065,6 @@ begin {$ENDIF MODAL_ACTIVATE_FIX} end; -{$IFDEF ASM_noVERSION} // ASM_TLIST! -function TControl.ShowModal: Integer; -asm - MOV ECX, [EAX].fParent - JECXZ @@show - MOVZX ECX, [EAX].fIsControl - JECXZ @@show_modal -@@show: - CALL Show - XOR EAX, EAX - RET -@@show_modal: - PUSHAD - MOV EBX, EAX - MOV EDI, [Applet] - XOR EBP, EBP // CurCtl = nil - MOV EAX, [EDI].fCurrentControl - {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG3, (1 shl G3_IsApplet) - {$ELSE} - CMP [EDI].TControl.FIsApplet, 0 - {$ENDIF} - {$IFDEF USE_CMOV} - CMOVZ EAX, EDI - {$ELSE} - JNZ @@curctrl_save - MOV EAX, EDI -@@curctrl_save: - {$ENDIF} - PUSH EAX - MOV EDX, offset[WndProcShowModal] - PUSH EDX - MOV EAX, EBX - CALL TControl.AttachProc - XOR EDX, EDX - MOV [EBX].fModalResult, EDX - CALL NewList - XCHG EAX, EBP - XOR ECX, ECX - INC ECX - MOV ESI, EDI - {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG3, (1 shl G3_IsApplet) - {$ELSE} - CMP [EDI].TControl.FIsApplet, 0 - {$ENDIF} - JZ @@isapplet - MOV EBP, [EDI].fCurrentControl // CurCtl = Applet.fCurrentControl - MOV ESI, [EDI].fChildren - MOV ECX, [ESI].TList.fCount - MOV ESI, [ESI].TList.fItems -@@1loo: LODSD -@@isapplet: - PUSH ECX - CMP EAX, EBX - JE @@1nx - PUSH EAX - CALL GetEnabled - TEST AL, AL - POP EAX - JZ @@1nx - PUSH EAX - MOV DL, 0 - CALL SetEnabled - POP EDX - MOV EAX, EBP - CALL TList.Add -@@1nx: POP ECX - LOOP @@1loo - INC [EBX].fModal - MOV EAX, [Applet] - MOV [EAX].fModalForm, EBX - MOV EAX, EBX - CALL Show -@@msgloo: - MOVZX ECX, [AppletTerminated] - OR ECX, [EBX].fModalResult - JNZ @@e_msgloo - CALL WaitMessage - MOV EAX, EDI - CALL ProcessMessages - {$IFDEF USE_OnIdle} - MOV EAX, EBX - CALL [ProcessIdle] - {$ENDIF} - JMP @@msgloo -@@e_msgloo: - POP EDX - MOV EAX, EBX - CALL TControl.DetachProc - DEC [EBX].fModal - MOV EAX, [Applet] - XOR ECX, ECX - MOV [EAX].fModalForm, ECX - MOV ECX, [EBP].TList.fCount - JECXZ @@2end - MOV ESI, [EBP].TList.fItems -@@2loo: LODSD - PUSH ECX - MOV DL, 1 - CALL TControl.SetEnabled - POP ECX - LOOP @@2loo -@@2end: - MOV EAX, EBP - CALL TObj.Free - POP ECX - JECXZ @@exit - PUSH 0 - PUSH WA_ACTIVE - PUSH WM_ACTIVATE - PUSH [ECX].fHandle - CALL PostMessage - TEST EBP, EBP // CurCtl = nil ? - JZ @@exit - MOV EAX, EBP - MOV DL, 1 - CALL TControl.SetFocused -@@exit: - POPAD - MOV EAX, [EAX].fModalResult -end; -{$ELSE PAS_VERSION} //Pascal {$IFDEF USE_SHOWMODALPARENTED_ALWAYS} function TControl.ShowModal: Integer; begin @@ -42162,10 +39095,8 @@ begin if F.Enabled then begin FL.Add( F ); F.Enabled := FALSE; - {$IFNDEF NOT_FIX_MODAL} Inc( F.DF.fFixingModal ); F.AttachProc(WndProcFixModal); {**************} - {$ENDIF} end; end end else begin @@ -42174,10 +39105,8 @@ begin FL.Add( Applet ); CurCtl := Applet.DF.fCurrentControl; { Alexander Pravdin } Applet.Enabled := FALSE; - {$IFNDEF NOT_FIX_MODAL} Inc( Applet.DF.fFixingModal ); Applet.AttachProc(WndProcFixModal); {**************} - {$ENDIF} end; end; @@ -42201,11 +39130,9 @@ begin DetachProc( WndProcShowModal ); for I := 0 to FL.Count - 1 do begin F := FL.Items[ I ]; - {$IFNDEF NOT_FIX_MODAL} Dec( F.DF.fFixingModal ); if F.DF.fFixingModal <= 0 then F.DetachProc(WndProcFixModal); {**************} - {$ENDIF} F.Enabled := TRUE; end; FL.Free; @@ -42216,7 +39143,7 @@ begin Result := ModalResult; end; {$ENDIF USE_SHOWMODALPARENTED_ALWAYS} -{$ENDIF PAS_VERSION} + {$IFNDEF NEW_MODAL} function TControl.ShowModalParented( const AParent: PControl ): Integer; begin @@ -42251,9 +39178,7 @@ begin {$ELSE} F.fEnabled and F.fVisible {$ENDIF} then begin FL.Add( F ); F.Enabled := FALSE; - {$IFNDEF NOT_FIX_MODAL} F.AttachProc(WndProcFixModal); {**************} - {$ENDIF} end; end; end; @@ -42281,9 +39206,7 @@ begin for I := 0 to FL.Count - 1 do begin F := PControl( FL.Items[ I ] ); F.Enabled := True; - {$IFNDEF NOT_FIX_MODAL} F.DetachProc(WndProcFixModal); {**************} - {$ENDIF} end; FL.Free; Hide; @@ -42719,7 +39642,6 @@ TRYAgain: ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' ); {$ENDIF KOL_ASSERTIONS} BitBlt( DC, X, Y, fWidth, oldHeight, DCfrom, 0, 0, SRCCOPY ); - {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF} SelectObject( DCfrom, oldBmp ); DeleteDC( DCfrom ); end else if Assigned(fDIBBits) then begin @@ -42929,53 +39851,6 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF ASM_noVERSION} -function TBitmap.GetHandle: HBitmap; -asm - PUSH EBX - MOV EBX, EAX - CALL GetEmpty - JZ @@exit - MOV EAX, EBX - CALL [EAX].fDetachCanvas - MOV ECX, [EBX].fHandle - INC ECX - LOOP @@exit - MOV ECX, [EBX].fDIBBits - JECXZ @@exit - PUSH ECX - PUSH 0 - CALL GetDC - PUSH EAX - PUSH 0 - PUSH 0 - LEA EDX, [EBX].fDIBBits - PUSH EDX - PUSH DIB_RGB_COLORS - PUSH [EBX].fDIBHeader - PUSH EAX - CALL CreateDIBSection - MOV [EBX].fHandle, EAX - PUSH 0 - CALL ReleaseDC - POP EAX - PUSH EAX - MOV EDX, [EBX].fDIBBits - MOV ECX, [EBX].fDIBSize - CALL System.Move - POP EAX - CMP [EBX].fDIBAutoFree, 0 - JNZ @@freed - PUSH EAX - CALL GlobalFree -@@freed:MOV [EBX].fDIBAutoFree, 1 - XOR EAX, EAX - MOV [EBX].fGetDIBPixels, EAX - MOV [EBX].fSetDIBPixels, EAX -@@exit: MOV EAX, [EBX].fHandle - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal function TBitmap.GetHandle: HBitmap; var OldBits: Pointer; DC0: HDC; @@ -43015,7 +39890,6 @@ begin end; Result := fHandle; end; -{$ENDIF PAS_VERSION} function TBitmap.GetHandleAllocated: Boolean; begin @@ -43052,184 +39926,6 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF ASM_noVERSION} // error + 16Colors->swap(Gray,Silver) + Core -procedure TBitmap.LoadFromStream(Strm: PStream); -type tBFH = TBitmapFileHeader; - tBIH = TBitmapInfoHeader; -const szBIH = Sizeof( tBIH ); - szBFH = Sizeof( tBFH ); -asm - PUSH EBX - PUSH ESI - MOV EBX, EAX - PUSH EDX - CALL Clear - POP ESI - MOV EAX, ESI - CALL TStream.GetPosition - PUSH EAX // [EBP+4] = Strm.Pos (starting pos) - PUSH EBP - MOV EBP, ESP - ADD ESP, -(szBIH + szBFH) - // reading bitmap - XOR ECX, ECX - MOV [EBX].fHandleType, CL - MOV CL, szBFH - MOV EDX, ESP - PUSH ECX - MOV EAX, ESI - CALL TStream.Read - POP ECX - SUB ECX, EAX - JNZ @@eread1 - CMP [ESP].tBFH.bfType, $4D42 - JE @@1 - MOV EDX, [EBP+4] - MOV EAX, ESI - CALL TStream.Seek - XOR EAX, EAX - XOR EDX, EDX - JMP @@2 -@@1: - MOV EDX, [ESP].tBFH.bfSize - MOV EAX, [ESP].tBFH.bfOffBits -@@2: - PUSH EDX // Push Size - PUSH EAX // Push Off - XOR ECX, ECX - MOV CL, szBIH - LEA EDX, [EBP-szBIH] - MOV EAX, ESI - PUSH ECX - CALL TStream.Read // read BIH - POP ECX -@@eread1: - XOR ECX, EAX - JNZ @@eread - MOVZX EAX, [EBP-szBIH].tBIH.biBitCount - MOVZX EDX, [EBP-szBIH].tBIH.biPlanes - MUL EDX - CALL Bits2PixelFormat - CMP AL, pf15bit - JNZ @@no15bit - CMP [EBP-szBIH].tBIH.biCompression, 0 - JZ @@no15bit - INC AL // AL = pf16bit -@@no15bit: - MOV [EBX].fNewPixelFormat, AL - MOV EAX, szBIH + 1024 - CALL System.@GetMem - MOV [EBX].fDIBHeader, EAX - XCHG EDX, EAX - LEA EAX, [EBP-szBIH] - XOR ECX, ECX - MOV CL, szBIH - CALL System.Move - MOV EAX, [EBP-szBIH].tBIH.biWidth - MOV [EBX].fWidth, EAX - MOV EAX, [EBP-szBIH].tBIH.biHeight - TEST EAX, EAX - JGE @@20 - NEG EAX -@@20: MOV [EBX].fHeight, EAX - MOV EAX, EBX - CALL GetScanLineSize - MOV EDX, [EBX].fHeight - MUL EDX - MOV [EBX].fDIBSize, EAX - PUSH EAX - PUSH GMEM_FIXED or GMEM_ZEROINIT - CALL GlobalAlloc - MOV [EBX].fDIBBits, EAX - MOVZX EAX, [EBP-szBIH].tBIH.biBitCount - CMP AL, 8 - JA @@3 - MOV AL, 4 - MOVZX ECX, [EBP-szBIH].tBIH.biBitCount - SAL EAX, CL - XCHG ECX, EAX -@@3: - CMP [EBX].TBitmap.fNewPixelFormat, pf16bit - JNE @@30 - XOR ECX, ECX - MOV CL, 12 // ColorCount = 12 -@@30: - POP EAX // EAX = off - TEST EAX, EAX - JLE @@4 - SUB EAX, szBFH + szBIH - CMP EAX, ECX - JZ @@4 - XCHG ECX, EAX -@@4: - JECXZ @@5 - PUSH ECX - MOV EDX, [EBX].fDIBHeader - ADD EDX, szBIH - MOV EAX, ESI - CALL TStream.Read - POP ECX - XOR EAX, ECX - JNZ @@eread -@@5: - MOV ECX, [EBX].fDIBSize -@@7: - PUSH ECX - MOV EAX, ESI - CALL TStream.GetPosition - PUSH EAX - MOV EAX, ESI - CALL TStream.GetSize - POP EDX - SUB EAX, EDX - POP ECX // Size = fDIBSize - CMP EAX, ECX // Strm.Size - Strm.Position > Size ? - JL @@8 - XCHG ECX, EAX -@@8: // ++++++++++++++ 26-Oct-2003 VK see comment in Pascal - MOV EAX, [EBX].fDIBSize - CMP ECX, EAX - JGE @@9 - SUB EAX, ECX - PUSH EAX - MOV EAX, ESI - PUSH ECX - CALL TStream.GetPosition - POP ECX - POP EDX - CMP EDX, EAX - JG @@9 - MOV EAX, ESI - NEG EDX - XOR ECX, ECX - INC ECX - CALL TStream.Seek - MOV ECX, [EBX].fDIBSize -@@9: // ++++++++++++++ - PUSH ECX - MOV EDX, [EBX].fDIBBits - MOV EAX, ESI - CALL TStream.Read - POP ECX - XOR EAX, ECX - POP EAX // Strm.Size - Position - POP ECX // fDIBSize - // end of reading bitmap -@@eread: - MOV ESP, EBP - POP EBP - POP EDX - JZ @@exit - // not success: - XCHG EAX, ESI - XOR ECX, ECX // ECX = spBegin - CALL TStream.Seek - XCHG EAX, EBX - CALL Clear -@@exit: POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal procedure TBitmap.LoadFromStream(Strm: PStream); type TColorsArray = array[ 0..15 ] of TColor; @@ -43359,16 +40055,13 @@ begin Clear; end; end; -{$ENDIF PAS_VERSION} + ////////////////// bitmap RLE-decoding and loading - by Vyacheslav A. Gavrik -function MoveTetrades(Mem, From:PByte; Size: Integer;incFrom, - xx: Integer): Integer; forward; -function MoveRLEdata(Mem, From:PByte;Size: Integer;incFrom, - xx: Integer): Integer; forward; +function MoveTetrades(Mem, From:PByte; Size: Integer;incFrom, xx: Integer): Integer; forward; +function MoveRLEdata(Mem, From:PByte;Size: Integer;incFrom, xx: Integer): Integer; forward; {$IFDEF ASM_VERSION} {$ELSE PAS_VERSION} -function MoveTetrades(Mem, From:PByte; Size: Integer;incFrom, - xx: Integer): Integer; +function MoveTetrades(Mem, From:PByte; Size: Integer;incFrom, xx: Integer): Integer; var ff: Integer; Value: Byte; begin @@ -43384,7 +40077,7 @@ begin Value := Value shr 4; end; if Byte(xx) and 1 <> 0 then begin - Mem^ := Mem^ {$IFNDEF SMALLER_CODE} and $F0 {$ENDIF} or Value; + Mem^ := Mem^ and $F0 or Value; inc(Mem); end else begin Mem^ := Value shl 4; @@ -43394,10 +40087,8 @@ begin dec(Size); end; end; -{$ENDIF} -{$IFDEF ASM_VERSION} {$ELSE PASCAL} -function MoveRLEdata(Mem, From:PByte;Size: Integer;incFrom, - xx: Integer): Integer; + +function MoveRLEdata(Mem, From:PByte;Size: Integer;incFrom, xx: Integer): Integer; begin Result := (Size+1) and (not 1); while Size > 0 do begin @@ -43411,7 +40102,7 @@ end; type TMoveData = function (_To, _From: PByte; Size: Integer; incFrom, xx: Integer ): Integer; - + procedure DecodeRLE(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD; MoveDataFun: TMoveData; shr_x: Integer); forward; // by Vyacheslav A. Gavrik *modified: Kladov V. {$IFDEF ASM_VERSION}{$ELSE} @@ -43421,9 +40112,7 @@ var x,y,z,d: Integer; begin pb:=Data; x:=0; y:=0; - {$IFNDEF SMALLER_CODE} if Bmp.fScanLineSize = 0 then - {$ENDIF} Bmp.ScanLineSize; while (y>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} -{$IFNDEF SMALLER_CODE} pf := PixelFormat; -{$ENDIF SMALLER_CODE} HandleType := bmDDB; // Not too good, but provides correct changing of height // preserving previous image fHeight := Value; FormatChanged; -{$IFNDEF SMALLER_CODE} PixelFormat := pf; -{$ENDIF SMALLER_CODE} end; procedure TBitmap.SetPixelFormat(Value: TPixelFormat); @@ -45783,45 +42466,6 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF ASM_noVERSION} -procedure TIcon.SetHandle(const Value: HIcon); -const szII = sizeof( TIconInfo ); - szBIH = sizeof(TBitmapInfoHeader); -asm //cmd //opd - CMP EDX, [EAX].fHandle - JE @@exit - PUSHAD - PUSH EDX - MOV EBX, EAX - CALL Clear - POP ECX - MOV [EBX].fHandle, ECX - JECXZ @@fin - ADD ESP, -szBIH - PUSH ESP - PUSH ECX - CALL GetIconInfo - MOV ESI, [ESP].TIconInfo.hbmMask - MOV EDI, [ESP].TIconInfo.hbmColor - PUSH ESP - PUSH szBIH - PUSH ESI - CALL GetObject - POP EAX - POP [EBX].fSize - ADD ESP, szBIH-8 - TEST ESI, ESI - JZ @@1 - PUSH ESI - CALL DeleteObject -@@1: TEST EDI, EDI - JZ @@fin - PUSH EDI - CALL DeleteObject -@@fin: POPAD -@@exit: -end; -{$ELSE PAS_VERSION} //Pascal procedure TIcon.SetHandle(const Value: HIcon); var II : TIconInfo; B: TagBitmap; @@ -45844,7 +42488,7 @@ begin DeleteObject( II.hbmColor ); end; end; -{$ENDIF PAS_VERSION} + procedure TIcon.SetHandleEx(NewHandle: HIcon); begin if FHandle = NewHandle then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} @@ -46126,87 +42770,6 @@ begin Result := LoadImage( hInstance, RsrcName, IMAGE_ICON, Size, Size, $8000 {LR_SHARED} ); end; -{$IFDEF OLD_ALIGN} -procedure AlignChildrenProc( Sender: PObj ); -type - TAligns = set of TControlAlign; -var P: PControl; - CR: TRect; - procedure DoAlign( Allowed: TAligns ); - var I: Integer; - C: PControl; - R, R1: TRect; - W, H: Integer; - ChgPos, ChgSiz: Boolean; - begin - for I := 0 to P.fChildren.fCount - 1 do begin - C := P.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - if not C.ToBeVisible then continue; - // important: not fVisible, and even not Visible, but ToBeVisible! - if {$IFDEF USE_FLAGS} G4_NotUseAlign in C.fFlagsG4 - {$ELSE} C.fNotUseAlign {$ENDIF} then continue; - if C.FAlign in Allowed then begin - R := C.BoundsRect; - R1 := R; - W := R.Right - R.Left; - H := R.Bottom - R.Top; - case C.FAlign of - caTop: - begin - OffsetRect( R, 0, -R.Top + CR.Top + P.Margin ); - Inc( CR.Top, H + P.Margin ); - R.Left := CR.Left + P.Margin; - R.Right := CR.Right - P.Margin; - end; - caBottom: - begin - OffsetRect( R, 0, -R.Bottom + CR.Bottom - P.Margin ); - Dec( CR.Bottom, H + P.Margin ); - R.Left := CR.Left + P.Margin; - R.Right := CR.Right - P.Margin; - end; - caLeft: - begin - OffsetRect( R, -R.Left + CR.Left + P.Margin, 0 ); - Inc( CR.Left, W + P.Margin ); - R.Top := CR.Top + P.Margin; - R.Bottom := CR.Bottom - P.Margin; - end; - caRight: - begin - OffsetRect( R, -R.Right + CR.Right - P.Margin, 0 ); - Dec( CR.Right, W + P.Margin ); - R.Top := CR.Top + P.Margin; - R.Bottom := CR.Bottom - P.Margin; - end; - caClient: - begin - R := CR; - InflateRect( R, -P.Margin, -P.Margin ); - end; - end; - if R.Right < R.Left then R.Right := R.Left; - if R.Bottom < R.Top then R.Bottom := R.Top; - ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top); - ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H); - if ChgPos or ChgSiz then begin - C.BoundsRect := R; - if ChgSiz then - AlignChildrenProc( C ); - end; - end; - end; - end; -begin - P := Pointer( Sender ); - if P = nil then Exit; // Called for form - ignore. {>>>>>>>>>>>>>>>>>>>>>>>>>} - CR := P.ClientRect; - if CR.Right <= CR.Left then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DoAlign( [ caTop, caBottom ] ); - DoAlign( [ caLeft, caRight ] ); - DoAlign( [ caClient ] ); -end; -{$ELSE NEW_ALIGN} procedure AlignChildrenProc_(P:PControl); type TAligns = set of TControlAlign; var CR: TRect; @@ -46220,10 +42783,8 @@ var CR: TRect; if not (oaAligning in P.fAligning) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>} C := P.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; with C^ do begin - {$IFDEF SAFE_CODE} C.RefInc; TRY - {$ENDIF} if (not( {$IFDEF USE_FLAGS} (F3_Visible in fStyle.f3_Style) {$ELSE} fVisible {$ENDIF} @@ -46285,12 +42846,11 @@ var CR: TRect; end; if ChgPos or ChgSiz then BoundsRect := R; end; - {$IFDEF SAFE_CODE} FINALLY C.RefDec; END; - {$ENDIF SAFE_CODE} - if oaWaitAlign in fAligning then AlignChildrenProc_(C); + if (oaWaitAlign in fAligning) then + AlignChildrenProc_(C); end; end; end; @@ -46588,7 +43148,7 @@ begin AlignChildrenProc_(S); end; {$ENDIF PAS_VERSION} -{$ENDIF OLD_ALIGN} + procedure TControl.Set_Align(const Value: TControlAlign); begin Global_Align := AlignChildrenProc; @@ -46596,11 +43156,7 @@ begin {$ELSE} fNotUseAlign {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} if FAlign = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} FAlign := Value; - {$IFDEF OLD_ALIGN} - AlignChildrenProc( Parent ); - {$ELSE NEW_ALIGN} AlignChildrenProc(@Self); - {$ENDIF} end; function TControl.SetAlign(AAlign: TControlAlign): PControl; @@ -46805,9 +43361,7 @@ begin {$ENDIF} if DF.fTmpFont = nil then begin DF.fTmpFont := NewFont; - {$IFDEF USE_AUTOFREE4CONTROLS} Add2AutoFree( DF.fTmpFont ); - {$ENDIF} end; Result := DF.fTmpFont; Result.OnChange := nil; @@ -47569,7 +44123,6 @@ asm //cmd //opd JS @@e_loo PUSH EDX PUSH EBX -{$IFNDEF SMALLEST_CODE} {$IFNDEF ENUM_DYN_HANDLERS_AFTER_RUN} XOR EAX, EAX CMP [AppletTerminated], AL @@ -47578,7 +44131,6 @@ asm //cmd //opd MOV ECX, [ECX+EDI*8+4] JECXZ @@skip_call {$ENDIF} -{$ENDIF} @@do_call: MOV EAX, [ESI].TList.fItems MOV EAX, [EAX+EDI*8] @@ -47620,12 +44172,10 @@ begin Self_.RefInc; // Prevent destroying Self_ for I := Self_.fDynHandlers.fCount div 2 - 1 downto 0 do begin Proc := Self_.fDynHandlers.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I * 2 ]; -{$IFNDEF SMALLEST_CODE} {$IFNDEF ENUM_DYN_HANDLERS_AFTER_RUN} if not AppletTerminated or ( Self_.fDynHandlers.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} [ I * 2 + 1 ] <> nil) then -{$ENDIF} {$ENDIF} if Proc( Self_, Msg, Rslt ) then begin Result := True; @@ -47670,9 +44220,7 @@ begin fDynHandlers.Add( @Proc ); fDynHandlers.Add( Pointer( PtrUInt( ExecuteAfterAppletTerminated ) ) ); end; - {$IFNDEF SMALLEST_CODE} Global_AttachProcExtension(fDynHandlers); - {$ENDIF} PP.fOnDynHandlers := EnumDynHandlers; end; {$ENDIF PAS_VERSION} @@ -47700,14 +44248,12 @@ begin end; {$ENDIF PAS_VERSION} -{$IFDEF nASM_VERSION}{$ELSE PAS_VERSION} function WndProcAutoPopupMenu( Control: PControl; var Msg: TMsg; var MsgRslt: LRESULT ): Boolean; -var {$IFNDEF SMALLEST_CODE} - R: TRect; - M: Word; - I: Integer; - {$ENDIF SMALLEST_CODE} - P: TPoint; +var + R: TRect; + M: Word; + I: Integer; + P: TPoint; begin if (Msg.message = WM_CONTEXTMENU) and (Control.fAutoPopupMenu <> nil) then begin @@ -47716,7 +44262,7 @@ begin {$ENDIF USE_MENU_CURCTL} P.X := SmallInt( LoWord( Msg.lParam ) ); P.Y := SmallInt( HiWord( Msg.lParam ) ); - {$IFNDEF SMALLEST_CODE} + if (Msg.lParam = -1) then begin I := Control.CurIndex; M := Control.fCommandActions.aItem2XY; @@ -47754,13 +44300,13 @@ begin end; P := Control.Client2Screen( P ); end; - {$ENDIF SMALLEST_CODE} + PMenu( Control.fAutoPopupMenu ).Popup( P.X, P.Y ); Result := TRUE; end else Result := FALSE; end; -{$ENDIF PAS_VERSION} + procedure TControl.SetAutoPopupMenu(PopupMenu: PObj); { new version - by Alexander Pravdin. Allows to attach a submenu (e.g. of the main menu) as a popup menu to a control, to avoid duplicating menu object, @@ -48759,25 +45305,13 @@ begin {$IFDEF DEBUG_OBJKIND} Result.fObjKind := 'TControl:TabPage'; {$ENDIF} - {$IFDEF OLD_ALIGN} - Result.FAlign := caClient; //+ Galkov - {$IFDEF USE_FLAGS} Result.fFlagsG4 := Result.fFlagsG4 + - [G4_VisibleWOParent, G4_NotUseAlign]; - {$ELSE} Result.fVisibleWoParent := TRUE; - Result.fNotUseAlign := True; - {$ENDIF} - {$ELSE NEW_ALIGN} Result.Align := caClient; //+ Galkov - {$ENDIF} Result.Visible := CurIndex<0; TI.mask := TCIF_TEXT or TCIF_IMAGE or TCIF_PARAM; TI.iImage := TabImgIdx; TI.pszText := PKOLChar( TabText ); TI.lParam := PtrInt( Result ); Perform( TCM_INSERTITEM, Idx, LPARAM( @TI ) ); - {$IFDEF OLD_ALIGN} - Result.BoundsRect := TC_DisplayRect;//+ Galkov - {$ENDIF} Perform(WM_SIZE,0,0); //May be changes of margins for TabControl {$IFDEF GRAPHCTL_XPSTYLES} Attach_WM_THEMECHANGED(Result, XP_Themes_For_TabPanel); @@ -48794,7 +45328,6 @@ begin Perform(WM_SIZE,0,0); //May be changes of margins for TabControl end; -{$IFNDEF OLD_ALIGN} procedure TControl.TC_InsertControl( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer; Page: PControl); var TI: TTCItem; @@ -48815,7 +45348,7 @@ begin Perform( TCM_DELETEITEM, Idx, 0 ); Perform(WM_SIZE,0,0); //May be changes of margins for TabControl end; -{$ENDIF} + { -- TreeView -- } function TControl.TVGetItemIdx(const Index: Integer): THandle; begin @@ -49358,13 +45891,8 @@ begin Chg := TRUE; end; end; - if Chg then begin - {$IFDEF OLD_ALIGN} - if PControl( Self_ ).fParent <> nil then - Global_Align( PControl( Self_ ).fParent ); - {$ENDIF} + if Chg then Global_Align( Self_ ); - end; end; function TControl.AutoSize(AutoSzOn: Boolean): PControl; @@ -49395,20 +45923,11 @@ begin if {$IFDEF USE_FLAGS} G3_IsControl in fFlagsG3 {$ELSE} fIsControl {$ENDIF} then if Parent <> nil then begin - {$IFDEF OLD_ALIGN} - if {$IFDEF USE_FLAGS} G4_VisibleWOParent in fFlagsG4 - {$ELSE} fVisibleWoParent {$ENDIF} then - Result := {$IFDEF USE_FLAGS} F3_Visible in fStyle.f3_Style - {$ELSE} fVisible {$ENDIF} - else - {$ENDIF} - begin - if Result then begin - Parent.Visible; // needed to provide correct fVisible for a form! - //todo: check if necessary for USE_FLAGS ??? - Result := Parent.ToBeVisible; - end; - end; + if Result then begin + Parent.Visible; // needed to provide correct fVisible for a form! + //todo: check if necessary for USE_FLAGS ??? + Result := Parent.ToBeVisible; + end; end; end; {$ENDIF PAS_VERSION} @@ -51243,10 +47762,8 @@ end; {$ELSE} var F: PControl; begin - {$IFDEF SAFE_CODE} if {$IFDEF USE_FLAGS} [G3_IsForm, G3_IsApplet] * fFlagsG3 <> [] {$ELSE} fIsForm or fIsApplet {$ENDIF} then - {$ENDIF} begin SetDefaultBtn( 0, TRUE ); F := ParentForm; @@ -51556,10 +48073,8 @@ var StartBounds: TRect; dX, dY: Integer; Delta: Integer; begin - {$IFNDEF SMALLEST_CODE} if {$IFDEF USE_FLAGS} G6_Dragging in fFlagsG6 {$ELSE} fDragging {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} GetCursorPos( MSP ); StartBounds := BoundsRect; dX := StartBounds.Left - MSP.X; @@ -51675,7 +48190,7 @@ begin 3: fClientLeft := Value; 4: fClientRight := Value; end; - {$IFNDEF OLD_ALIGN}include(fAligning,oaFromSelf);{$ENDIF}//??? + include(fAligning,oaFromSelf);//??? Global_Align( @Self ); end; {------------------------------------------------------------------------------} @@ -51838,7 +48353,7 @@ begin if (C.Handle = 0) and {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6) {$ELSE} not C.fWindowed {$ENDIF} - {$IFDEF SAFE_CODE} and Assigned( C.EV.fPaintProc ) {$ENDIF} then begin + and Assigned( C.EV.fPaintProc ) then begin sav := SaveDC( DC ); rgn := CreateRectRgnIndirect( R ); ExtSelectClipRgn( DC, rgn, RGN_AND ); @@ -52117,7 +48632,6 @@ var IdxActions: Integer; begin new( Result, Create ); {$IFDEF DEBUG_OBJKIND} Result.fObjKind := 'TControl:GraphicControl'; {$ENDIF} - {$IFDEF COMMANDACTIONS_OBJ} IdxActions := PtrInt( ACommandActions ); if IdxActions >= 120 then IdxActions := PByte( ACommandActions )^; @@ -52130,17 +48644,10 @@ begin new( Result, Create ); Result.fCommandActions.fObjKind := 'TCommandActionsObj'; {$ENDIF} AllActions_Objs[IdxActions] := Result.fCommandActions; - {$IFDEF SAFE_CODE} if ACommandActions <> nil then - {$ENDIF} Move( ACommandActions^, Result.fCommandActions.aClear, Sizeof( TCommandActions ) ); end; Result.Add2AutoFree( Result.fCommandActions ); - {$ELSE} {$IFDEF SAFE_CODE} - if ACommandActions <> nil then - {$ENDIF} - Result.fCommandActions := ACommandActions^; - {$ENDIF} Result.PP.fDoInvalidate := InvalidateNonWindowed; {$IFDEF USE_FLAGS} include( Result.fFlagsG6, G6_GraphicCtl ); {$ELSE} Result.fWindowed := FALSE; {$ENDIF} @@ -52949,20 +49456,12 @@ var NewW, NewH: Integer; dW, dH: Integer; i: Integer; C: PControl; - {$IFNDEF ANCHORS_WM_SIZE} CR: TRect; - {$ENDIF} begin Result := FALSE; - If (Msg.message = {$IFDEF ANCHORS_WM_SIZE} WM_SIZE {$ELSE} WM_WINDOWPOSCHANGED {$ENDIF} ) - and not IsIconic(Sender.Handle) then begin - {$IFDEF ANCHORS_WM_SIZE} - NewW := LoWord( Msg.lParam ); - NewH := HiWord( Msg.lParam ); - {$ELSE} - CR := Sender.ClientRect; + If (Msg.message = WM_WINDOWPOSCHANGED) and not IsIconic(Sender.Handle) then begin + CR := Sender.ClientRect; NewW := CR.Right; NewH := CR.Bottom; - {$ENDIF} dW := NewW - Sender.fOldWidth; dH := NewH - Sender.fOldHeight; For i := 0 to Sender.ChildCount - 1 do begin @@ -52986,15 +49485,18 @@ begin Result := FALSE; end; function TControl.Anchor(aLeft, aTop, aRight, aBottom: Boolean): PControl; -begin if (not aLeft) and aRight then - AnchorLeft := FALSE - else AnchorLeft := aLeft; - if (not aTop) and aBottom then - AnchorTop := FALSE - else AnchorTop := aTop; - AnchorRight := aRight; - AnchorBottom := aBottom; - Result := @ Self; +begin + if (not aLeft) and aRight then + AnchorLeft := FALSE + else + AnchorLeft := aLeft; + if (not aTop) and aBottom then + AnchorTop := FALSE + else + AnchorTop := aTop; + AnchorRight := aRight; + AnchorBottom := aBottom; + Result := @ Self; end; function TControl.GetLBTopIndex: Integer; @@ -53021,1081 +49523,19 @@ begin Perform(LB_SETTOPINDEX,Value,0); end; -procedure TControl.FormCreateParameters(alphabet: PFormInitFuncArray; params: PAnsiChar ); -begin - DF.FormCurrentParent := @Self; - DF.FormLastCreatedChild := @Self; - DF.FormParams := params; - DF.FormAlphabet := alphabet; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function TControl.FormGetIntParam: PtrInt; -var C: Byte; - Sign, Cont: Boolean; -begin Result := 0; - While TRUE do begin - C := Byte( DF.FormParams^ ); - inc( DF.FormParams ); - Cont := C and 1 <> 0; - C := C shr 1; - If Cont then - Result := (Result shl 7) or C - else begin - Sign := C and 1 <> 0; - C := C shr 1; - Result := (Result shl 6) or C; - if Sign then - Result := -Result; - break; - End; - End; -end; - -function TControl.FormGetColorParam: Integer; -begin Result := FormGetIntParam; - Result := (Result shr 1) or (Result shl 31); -end; - -procedure TControl.FormGetStrParam; -var i: Integer; -begin i := FormGetIntParam; - SetString( FormString, DF.FormParams, i ); - inc( DF.FormParams, i ); -end; - -procedure TControl.FormExecuteCommands(AForm: PControl; ControlPtrOffsets: PSmallIntArray); -var N: Integer; - Ctrl: PPcontrol; -begin while {FormParams <> ''} TRUE do begin - N := FormGetIntParam; - if N = 0 then - break; - if N < 0 then begin - N := -N; - Ctrl := PPControl( Pointer( PAnsiChar(AForm) - + (ControlPtrOffsets[0] shl 2) ) ); - ControlPtrOffsets := Pointer( PtrUInt( ControlPtrOffsets ) + 2 ); - Ctrl^ := DF.FormAlphabet[N-1]( @Self ); - DF.FormLastCreatedChild := Ctrl^; - end else begin - Ctrl := @ DF.FormLastCreatedChild; - PFormInitFuncArray1( DF.FormAlphabet )[N-1]( Ctrl^, 1 ); - end; - end; - FormString := ''; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION} -procedure FormPrepareStrParamCreateCtrl; -asm PUSH EAX - CALL TControl.FormGetStrParam - POP ECX - MOV EAX, [ECX].TControl.DF.FormCurrentParent - MOV EDX, [ECX].TControl.FormString -end; - -procedure FormPrepareIntParamCreateCtrl; -asm PUSH EAX - CALL TControl.FormGetIntParam - XCHG EDX, EAX - POP ECX - MOV EAX, [ECX].TControl.DF.FormCurrentParent -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewLabel( Form: PControl ): PControl; -begin - Form.FormGetStrParam; - Result := NewLabel( Form.DF.FormCurrentParent, Form.FormString ); -end; - -function FormNewWordWrapLabel( Form: PControl ): PControl; -begin - Form.FormGetStrParam; - Result := NewWordWrapLabel( Form.DF.FormCurrentParent, Form.FormString ); -end; - -function FormNewLabelEffect( Form: PControl ): PControl; -var Shd: Integer; -begin - Form.FormGetStrParam; - Shd := Form.FormGetIntParam; - Result := NewLabelEffect( Form.DF.FormCurrentParent, Form.FormString, Shd ); -end; - -function FormNewButton( Form: PControl ): PControl; -begin - Form.FormGetStrParam; - Result := NewButton( Form.DF.FormCurrentParent, Form.FormString ); -end; -{$ENDIF} - -function FormNewBitBtn( Form: PControl ): PControl; -type PBitBtnOptions = ^TBitBtnOptions; -var Cap: KOLString; - i, j, k, bmp: Integer; -begin Form.FormGetStrParam; - Cap := Form.FormString; - i := Form.FormGetIntParam; - j := Form.FormGetIntParam; - Form.FormGetStrParam; - k := Form.FormGetIntParam; - bmp := 0; - if Form.FormString <> '' then - bmp := LoadBmp( hInstance, PKOLChar( KOLString( Form.FormString ) ), Form ); - Result := NewBitBtn( Form.DF.FormCurrentParent, Cap, - PBitBtnOptions( @i )^, - TGlyphLayout( j ), - bmp, k ); -end; - -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewPanel( Form: PControl ): PControl; -begin - Result := NewPanel( Form.DF.FormCurrentParent, TEdgeStyle( Form.FormGetIntParam ) ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// - -function FormNewGradientPanel( Form: PControl ): PControl; -var C1, C2: TColor; -begin C1 := Form.FormGetColorParam; - C2 := Form.FormGetColorParam; - Result := NewGradientPanel( Form.DF.FormCurrentParent, C1, C2 ); -end; -function FormNewGradientPanelEx( Form: PControl ): PControl; -var C1, C2: TColor; - Style, Layout: Integer; -begin C1 := Form.FormGetColorParam; - C2 := Form.FormGetColorParam; - Style := Form.FormGetIntParam; - Layout := Form.FormGetIntParam; - Result := NewGradientPanelEx( Form.DF.FormCurrentParent, C1, C2, - TGradientStyle( Style ), TGradientLayout( Layout ) ); -end; -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -function FormNewGroupbox( Form: PControl ): PControl; -begin Form.FormGetStrParam; - Result := NewGroupbox( Form.DF.FormCurrentParent, - Form.FormString ); -end; -{$ENDIF PAS_VERSION} - -function FormNewPaintbox( Form: PControl ): PControl; -begin - Result := NewPaintbox( Form.DF.FormCurrentParent ); -end; - -function FormNewImageShow( Form: PControl ): PControl; -begin - Result := NewImageShow( Form.DF.FormCurrentParent, nil, 0 ); -end; - -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewEditBox( Form: PControl ): PControl; -type PEditOptions = ^TEditOptions; -var i: Integer; -begin i := Form.FormGetIntParam; - Result := NewEditbox( Form.DF.FormCurrentParent, PEditOptions( @ i )^ ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// - -{$IFDEF ASM_VERSION}{$ELSE} -{$IFDEF USE_RICHEDIT} -function FormNewRichEdit( Form: PControl ): PControl; -type PEditOptions = ^TEditOptions; -var i: Integer; -begin i := Form.FormGetIntParam; - Result := NewRichEdit( Form.DF.FormCurrentParent, - PEditOptions( @ i )^ ); -end; -{$ENDIF USE_RICHEDIT} - -function FormNewComboBox( Form: PControl ): PControl; -type PComboOptions = ^TComboOptions; -var i: Integer; -begin i := Form.FormGetIntParam; - Result := NewCombobox( Form.DF.FormCurrentParent, PComboOptions( @ i )^ ); -end; - -function FormNewCheckbox( Form: PControl ): PControl; -begin Form.FormGetStrParam; - Result := NewCheckbox( Form.DF.FormCurrentParent, Form.FormString ); -end; - -function FormNewRadiobox( Form: PControl ): PControl; -begin Form.FormGetStrParam; - Result := NewRadiobox( Form.DF.FormCurrentParent, Form.FormString ); -end; - -function FormNewListbox( Form: PControl ): PControl; -type PListOptions = ^TListOptions; -var i: Integer; -begin i := Form.FormGetIntParam; - Result := NewListbox( Form.DF.FormCurrentParent, PListOptions( @ i )^ ); -end; -{$ENDIF PAS_VERSION} - -function FormNewSplitter( Form: PControl ): PControl; -var p, n: Integer; -begin - p := Form.FormGetIntParam; - n := Form.FormGetIntParam; - Result := NewSplitter( Form.DF.FormCurrentParent, p, n ); -end; - -function FormNewListView( Form: PControl ): PControl; -type PListViewOptions = ^TListViewOptions; -var lvs: TListViewStyle; - i: Integer; -begin lvs := TListViewStyle( Form.FormGetIntParam ); - i := Form.FormGetIntParam; - Result := NewListView( Form.DF.FormCurrentParent, lvs, PListViewOptions( @i )^, nil, nil, nil ); -end; -function FormNewTreeView( Form: PControl ): PControl; -type PTreeViewOptions = ^TTreeViewOptions; -var i: Integer; -begin - i := Form.FormGetIntParam; - Result := NewTreeView( Form.DF.FormCurrentParent, PTreeViewOptions( @i )^, nil, nil ); -end; - -function FormNewScrollbox( Form: PControl ): PControl; -type PScrollerBars = ^TScrollerBars; -var es: TEdgeStyle; b: Integer; -begin - es := TEdgeStyle( Form.FormGetIntParam ); - b := Form.FormGetIntParam; - Result := NewScrollbox( Form.DF.FormCurrentParent, es, PScrollerBars( @ b )^ ); -end; -function FormNewScrollboxEx( Form: PControl ): PControl; -begin - Result := NewScrollboxEx( Form.DF.FormCurrentParent, TEdgeStyle( Form.FormGetIntParam ) ); -end; -function FormNewScrollBar( Form: PControl ): PControl; -begin - Result := NewScrollbar( Form.DF.FormCurrentParent, TScrollerBar( Form.FormGetIntParam ) ); -end; -function FormNewProgressBar( Form: PControl ): PControl; -begin - Result := NewProgressBar( Form.DF.FormCurrentParent ); -end; -function FormNewProgressBarEx( Form: PControl ): PControl; -type PProgressbarOptions = ^TProgressbarOptions; -begin - Result := NewProgressBarEx( Form.DF.FormCurrentParent, PProgressbarOptions(Form.FormGetIntParam)^ ); -end; -function FormNewDateTimePicker( Form: PControl ): PControl; -type PDateTimePickerOptions = ^TDateTimePickerOptions; -var o: Integer; -begin - o := Form.FormGetIntParam; - Result := NewDateTimePicker( Form.DF.FormCurrentParent, PDateTimePickerOptions( @ o )^ ); -end; - -function FormNewTabControl( Form: PControl ): PControl; -type PTabControlOptions = ^TTabControlOptions; -var N, i, o: Integer; - Tabs1: array of KOLString; - Tabs2: array of PKOLChar; -begin N := Form.FormGetIntParam; - SetLength( Tabs1, N ); - SetLength( Tabs2, N ); - for i := 0 to N-1 do begin - Form.FormGetStrParam; - Tabs1[i] := Form.FormString; - Tabs2[i] := PKOLChar( Tabs1[i] ); - end; - o := Form.FormGetIntParam; - i := Form.FormGetIntParam; - Result := NewTabControl( Form.DF.FormCurrentParent, - Tabs2, - PTabControlOptions(@ o)^, - nil, i ); - SetLength( Tabs1, 0 ); - SetLength( Tabs2, 0 ); -end; - -function ParentForm_PCharParam(Control: PControl): PKOLChar; -var Form: PControl; -begin Form := Control.FormParentForm; - Form.FormGetStrParam; - Result := PKOLChar( KOLString( Form.FormString ) ); -end; -function ParentForm_IntParamPas(Form: PControl): PtrInt; -begin - Result := Form.FormParentForm.FormGetIntParam; -end; -function ParentForm_ColorParamPas(Form: PControl): Integer; -begin - Result := Form.FormParentForm.FormGetColorParam; -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetSize( Form: PControl ); -var W, H: Integer; -begin W := ParentForm_IntParamPas( Form ); - H := ParentForm_IntParamPas( Form ); - Form.SetSize( W, H ); -end; -{$ENDIF} - -procedure FormSetHeight( Form: PControl ); -begin - Form.Height := ParentForm_IntParamPas(Form); -end; - -procedure FormSetWidth( Form: PControl ); -begin - Form.Width := ParentForm_IntParamPas(Form); -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetPosition( Form: PControl ); -var X, Y: Integer; -begin X := ParentForm_IntParamPas(Form); - Y := ParentForm_IntParamPas(Form); - Form.SetPosition( X, Y ); -end; - -procedure FormSetClientSize( Form: PControl ); -var W, H: Integer; -begin W := ParentForm_IntParamPas(Form); - H := ParentForm_IntParamPas(Form); - Form.SetClientSize( W, H ); -end; - -procedure FormSetAlign( Form: PControl ); -begin - Form.SetAlign( TControlAlign( ParentForm_IntParamPas(Form) ) ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// - -{$IFDEF USE_NAMES} -procedure FormSetName( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - Form.FormGetStrParam; - C.SetName( Form, Form.FormString ); -end; -{$ENDIF USE_NAMES} - -procedure FormSetTag( Form: PControl ); -var tag: DWORD; -begin - tag := ParentForm_IntParamPas(Form); - Form.Tag := tag; -end; - -{$IFDEF UNICODE_CTRLS} -procedure FormSetUnicode( Form: PControl ); -begin - Form.SetUnicode( TRUE ); -end; -{$ENDIF UNICODE_CTRLS}////////////////////////////////////////////////////////// - -procedure FormAssignHelpContext( Form: PControl ); -begin - Form.AssignHelpContext( ParentForm_IntParamPas( Form ) ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetCanResizeFalse( Form: PControl ); -begin - Form.CanResize := FALSE; -end; - -procedure FormInitMenu( Form: PControl ); -begin - Form.Perform( WM_INITMENU, 0, 0 ); -end; -{$ENDIF PAS_VERSION} - -procedure FormSizeGripFalse( Form: PControl ); -begin - Form.SizeGrip := FALSE; -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetExStyle( Form: PControl ); -begin - Form.ExStyle := Form.ExStyle or DWORD( ParentForm_IntParamPas(Form) ); -end; - -procedure FormSetVisibleFalse( Form: PControl ); -begin - Form.Visible := FALSE; -end; - -procedure FormSetEnabledFalse( Form: PControl ); -begin - Form.Enabled := FALSE; -end; - -procedure FormResetStyles( Form: PControl ); -begin - Form.Style := Form.Style and not ParentForm_IntParamPas(Form); -end; - -procedure FormSetStyle( Form: PControl ); -begin - Form.Style := Form.Style or DWORD( ParentForm_IntParamPas(Form)); -end; - -procedure FormSetAlphaBlend( Form: PControl ); -begin - Form.AlphaBlend := ParentForm_IntParamPas( Form ); -end; - -procedure FormSetHasBorderFalse( Form: PControl ); -begin - Form.HasBorder := FALSE; -end; - -procedure FormSetHasCaptionFalse( Form: PControl ); -begin - Form.HasCaption := FALSE; -end; - -procedure FormResetCtl3D( Form: PControl ); -begin - Form.Ctl3D := FALSE; -end; - -procedure FormIconLoad_hInstance( Form: PControl ); -begin - Form.IconLoad( hInstance, MAKEINTRESOURCE( ParentForm_IntParamPas(Form) ) ); -end; - -procedure FormIconLoadCursor_0( Form: PControl ); -begin - Form.IconLoadCursor( 0, MakeIntResource( ParentForm_IntParamPas(Form) ) ); -end; - -procedure FormSetIconNeg1( Form: PControl ); -begin - Form.Icon := THandle( -1 ); -end; -{$ENDIF PAS_VERSION} - -procedure FormIconLoad_hInstance_str( Form: PControl ); -begin - Form.FormGetStrParam; - Form.IconLoad( hInstance, PKOLChar( KOLString( Form.FormString ) ) ); -end; - -procedure FormCursorLoad_hInstance( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - Form.FormGetStrParam; - C.CursorLoad( 0, PKOLChar( KOLString( Form.FormString ) ) ); -end; -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetWindowState( Form: PControl ); -begin - Form.WindowState := TWindowState( ParentForm_IntParamPas(Form) ); -end; - -procedure FormCursorLoad_0( Form: PControl ); -begin - Form.CursorLoad( 0, MAKEINTRESOURCE( ParentForm_IntParamPas(Form) ) ); -end; - -procedure FormSetColor( Form: PControl ); -begin - Form.Color := ParentForm_ColorParamPas(Form); -end; - -procedure FormSetBrushStyle( Form: PControl ); -begin - Form.Brush.BrushStyle := TBrushStyle( ParentForm_IntParamPas(Form) ); -end; - -procedure FormSetBrushBitmap( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - {$IFDEF UNICODE_CTRLS} - Form.FormGetStrParam; - {$ENDIF} - C.Brush.BrushBitmap := - LoadBmp( hInstance, - {$IFDEF UNICODE_CTRLS} PKOLChar( KOLString( Form.FormString ) ) - {$ELSE} ParentForm_PCharParam(Form) - {$ENDIF} , Form ); -end; - -procedure FormSetFontColor( Form: PControl ); -begin - Form.Font.Color := ParentForm_ColorParamPas(Form); -end; - -procedure FormSetFontStyles( Form: PControl ); -type PFontStyle = ^TFontStyle; -var fs: Byte; -begin fs := ParentForm_IntParamPas(Form); - Form.Font.FontStyle := PFontStyle( @ fs )^; -end; - -procedure FormSetFontHeight( Form: PControl ); -begin - Form.Font.FontHeight := ParentForm_IntParamPas(Form); -end; - -procedure FormSetFontWidth( Form: PControl ); -begin - Form.Font.FontWidth := ParentForm_IntParamPas(Form); -end; -{$ENDIF PAS_VERSION} - -procedure ParentForm_StrParam( Form: PControl ); -begin Form := Form.FormParentForm; - Form.FormGetStrParam; -end; - -procedure FormSetFontName( Form: PControl ); -begin ParentForm_StrParam(Form); - Form.Font.FontName := Form.FormParentForm.FormString; -end; - -procedure FormSetEraseBkgndTrue( Form: PControl ); -begin -Form.EraseBackground := TRUE; -end; - -{$IFDEF noASM_VERSION} -procedure FormSetRepeatInterval( Form: PControl ); -asm CALL ParentForm_IntParamAsm - MOV [EAX].TControl.fRepeatInterval, EDX -end; -{$ELSE PAS_VERSION} -procedure FormSetRepeatInterval( Form: PControl ); -begin Form.RepeatInterval := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// - -procedure FormSetKeyPreviewTrue( Form: PControl ); -begin -{$IFDEF KEY_PREVIEW} - Form.KeyPreview := TRUE; -{$ENDIF} -end; - -procedure FormSetTabStopFalse( Form: PControl ); -begin Form.TabStop := FALSE; -end; - -procedure FormSetHintText( Form: PControl ); -begin {$IFDEF USE_MHTOOLTIP} - ParentForm_StrParam(Form); - Form.Hint.Text := Form.FormParentForm.FormString; - {$ENDIF USE_MHTOOLTIP} -end; -procedure FormSetAnchor( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - Form.AnchorLeft := I and 1 <> 0; - Form.AnchorTop := I and 2 <> 0; - Form.AnchorRight := I and 4 <> 0; - Form.AnchorBottom := I and 8 <> 0; -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetFontOrientation( Form: PControl ); -begin -Form.Font.FontOrientation := ParentForm_IntParamPas(Form); -end; - -procedure FormSetFontCharset( Form: PControl ); -begin -Form.Font.FontCharset := ParentForm_IntParamPas(Form); -end; - -procedure FormSetFontPitch( Form: PControl ); -begin -Form.Font.FontPitch := TFontPitch( ParentForm_IntParamPas(Form) ); -end; - -procedure FormSetBorder( Form: PControl ); -begin -Form.Border := ParentForm_IntParamPas(Form); -end; - -procedure FormSetMarginTop( Form: PControl ); -begin -Form.MarginTop := ParentForm_IntParamPas(Form); -end; - -procedure FormSetMarginBottom( Form: PControl ); -begin -Form.MarginBottom := ParentForm_IntParamPas(Form); -end; - -procedure FormSetMarginLeft( Form: PControl ); -begin -Form.MarginLeft := ParentForm_IntParamPas(Form); -end; - -procedure FormSetMarginRight( Form: PControl ); -begin -Form.MarginRight := ParentForm_IntParamPas(Form); -end; - -procedure FormSetSimpleStatusText( Form: PControl ); -begin -Form.SimpleStatusText := ParentForm_PCharParam(Form); -end; - -procedure FormSetStatusText( Form: PControl ); -var I: Integer; -begin I := ParentForm_IntParamPas(Form); - Form.StatusText[I] := ParentForm_PCharParam(Form); -end; - -procedure FormRemoveCloseIcon( Form: PControl ); -begin DeleteMenu( GetSystemMenu( Form.GetWindowHandle, False ), - SC_CLOSE, MF_BYCOMMAND ); -end; - -procedure FormSetMinWidth( Form: PControl ); -begin -Form.MinWidth := ParentForm_IntParamPas(Form); -end; - -procedure FormSetMaxWidth( Form: PControl ); -begin -Form.MaxWidth := ParentForm_IntParamPas(Form); -end; - -procedure FormSetMinHeight( Form: PControl ); -begin -Form.MinHeight := ParentForm_IntParamPas(Form); -end; - -procedure FormSetMaxHeight( Form: PControl ); -begin -Form.MaxHeight := ParentForm_IntParamPas(Form); -end; - -procedure FormSetTextShiftX( Form: PControl ); -begin -Form.TextShiftX := ParentForm_IntParamPas(Form); -end; - -procedure FormSetTextShiftY( Form: PControl ); -begin -Form.TextShiftY := ParentForm_IntParamPas(Form); -end; - -procedure FormSetColor2( Form: PControl ); -begin -Form.Color2 := ParentForm_ColorParamPas( Form ); -end; - -procedure FormSetTextAlign( Form: PControl ); -begin -Form.TextAlign := TTextAlign( ParentForm_IntParamPas(Form) ); -end; - -procedure FormSetTextVAlign( Form: PControl ); -begin -Form.VerticalAlign := TVerticalAlign( ParentForm_IntParamPas(Form) ); -end; - -procedure FormSetIgnoreDefault( Form: PControl ); -begin - Form.IgnoreDefault := Boolean( ParentForm_IntParamPas(Form) ); -end; - -procedure FormSetCaption( Form: PControl ); -var Ctl: PControl; -begin Ctl := Form; - Form := Form.FormParentForm; - Form.FormGetStrParam; - Ctl.Caption := Form.FormString; -end; - -procedure FormSetGradienStyle( Form: PControl ); -begin -Form.GradientStyle := TGradientStyle( ParentForm_IntParamPas(Form) ); -end; -{$ENDIF PAS_VERSION} - -procedure FormOverrideScrollbars( Form: PControl ); -begin -OverrideScrollbars( Form ); -end; - -{$IFDEF USE_RICHEDIT} -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetRE_AutoFontFalse( Form: PControl ); -begin - Form.RE_AutoFont := FALSE; -end; - -procedure FormSetRE_AutoFontSizeAdjustFalse( Form: PControl ); -begin - Form.RE_AutoFontSizeAdjust := FALSE; -end; - -procedure FormSetRE_DualFontTrue( Form: PControl ); -begin - Form.RE_DualFont := TRUE; -end; - -procedure FormSetRE_UIFontsTrue( Form: PControl ); -begin - Form.RE_UIFonts := TRUE; -end; - -procedure FormSetRE_IMECancelCompleteTrue( Form: PControl ); -begin - Form.RE_IMECancelComplete := TRUE; -end; - -procedure FormSetRE_IMEAlwaysSendNotifyTrue( Form: PControl ); -begin -Form.RE_IMEAlwaysSendNotify := TRUE; -end; - -procedure FormSetMaxTextSize( Form: PControl ); -begin -Form.MaxTextSize := DWORD( ParentForm_IntParamPas(Form) ); -end; - -procedure FormSetRE_AutoKeyboardTrue( Form: PControl ); -begin -Form.RE_AutoKeyboard := TRUE; -end; - -procedure FormSetRE_Zoom( Form: PControl ); -var zoom: TSmallPoint; -begin zoom.X := ParentForm_IntParamPas(Form); - zoom.Y := ParentForm_IntParamPas(Form); - Form.RE_Zoom := zoom; -end; -{$ENDIF PAS_VERSION} - -procedure FormSetRE_DisableOverwriteChangeTrue( Form: PControl ); -begin -Form.RE_DisableOverwriteChange := TRUE; -end; -{$ENDIF USE_RICHEDIT} - -procedure FormSetListItems( Form: PControl ); -var N, i: Integer; -begin N := ParentForm_IntParamPas(Form); - for i := 0 to N-1 do BEGIN - ParentForm_StrParam(Form); - Form.Items[i] := Form.FormParentForm.FormString; - END; -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetCount( Form: PControl ); -begin -Form.Count := ParentForm_IntParamPas(Form); -end; - -procedure FormSetDroppedWidth( Form: PControl ); -begin - Form.DroppedWidth := ParentForm_IntParamPas(Form); -end; -{$ENDIF PAS_VERSION} - -procedure FormSetButtonIcon( Form: PControl ); -begin - Form.SetButtonIcon( LoadImage( hInstance, - ParentForm_PCharParam(Form), - IMAGE_ICON, 0, 0, $8000 {LR_SHARED} ) ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetButtonImage( Form: PControl ); -var w, h: Integer; -begin w := ParentForm_IntParamPas(Form); - h := ParentForm_IntParamPas(Form); - Form.SetButtonIcon( LoadImage( hInstance, - ParentForm_PCharParam(Form), - IMAGE_ICON, w, h, $8000 {LR_SHARED} ) ); -end; - -procedure FormSetButtonBitmap( Form: PControl ); -begin Form.SetButtonBitmap( LoadBitmap( hInstance, - ParentForm_PCharParam(Form) ) ); -end; -{$ENDIF PAS_VERSION} - -procedure FormSetDefaultBtn( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - Form.SetDefaultBtn( i, TRUE ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMaxProgress( Form: PControl ); -begin -Form.MaxProgress := ParentForm_IntParamPas(Form); -end; - -procedure FormSetProgress( Form: PControl ); -begin Form.Progress := ParentForm_IntParamPas(Form); -end; - -procedure FormLVColumsAdd( Form: PControl ); -var N, i, w: Integer; -begin N := ParentForm_IntParamPas(Form); - for i := 0 to N-1 do BEGIN - w := ParentForm_IntParamPas(Form); - ParentForm_StrParam(Form); - Form.LVColAdd( Form.FormParentForm.FormString, taLeft, w ); - END; -end; - -procedure FormSetLVColOrder( Form: PControl ); -var N, i: Integer; -begin N := ParentForm_IntParamPas(Form); - i := ParentForm_IntParamPas(Form); - Form.LVColOrder[N] := i; -end; - -procedure FormSetLVColImage( Form: PControl ); -var N, i: Integer; -begin N := ParentForm_IntParamPas(Form); - i := ParentForm_IntParamPas(Form); - Form.LVColImage[N] := i; -end; - -procedure FormSetTVIndent( Form: PControl ); -begin Form.TVIndent := ParentForm_IntParamPas(Form); -end; -{$ENDIF PAS_VERSION} - -procedure FormSetTBBtnImgWidth( Form: PControl ); -begin Form.TBBtnImgWidth := ParentForm_IntParamPas( Form ); -end; -procedure FormTBAddBitmap( Form: PControl ); -var map: array[ 0..1 ] of TColor; - b: Integer; - C: PControl; -begin C := Form; - Form := Form.FormParentForm; - b := Form.FormGetIntParam; - if b >= 0 then begin - Form.FormGetStrParam; - if b <> 0 then begin - map[0] := Form.FormGetColorParam; - map[1] := Color2RGB( clBtnFace ); - b := LoadMappedBitmapEx( Form, hInstance, PKOLChar( KOLString( Form.FormString )), map ); - end else - b := LoadBmp( hInstance, PKOLChar(KOLString(Form.FormString)), Form ); - end; - C.TBAddBitmap( b ); -end; - -procedure FormSetTBButtonSize( Form: PControl ); -begin - Form.Perform( TB_SETBUTTONSIZE, 0, ParentForm_IntParamPas(Form) or $10000 {or (HiWord(HW) shl 16)} ); -end; - -procedure FormTBSetTooltips( Form: PControl ); -var A1: array of KOLString; - A2: array of PKOLChar; - N, i: Integer; - C: PControl; -begin C := Form; - Form := Form.FormParentForm; - N := Form.FormGetIntParam; - SetLength( A1, N ); - SetLength( A2, N ); - for i := 0 to N-1 do begin - Form.FormGetStrParam; - A1[i] := Form.FormString; - A2[i] := PKOLChar( A1[i] ); - end; - C.TBSetTooltips( 0, A2 ); - SetLength( A1, 0 ); - SetLength( A2, 0 ); -end; - -procedure FormSetTBButtonsMinWidth( Form: PControl ); -begin - Form.TBButtonsMinWidth := ParentForm_IntParamPas(Form); -end; - -procedure FormSetTBButtonsMaxWidth( Form: PControl ); -begin - Form.TBButtonsMaxWidth := ParentForm_IntParamPas(Form); -end; - -procedure FormHideToolbarButton( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - {$IFDEF USE_GRUSH} - ShowHideToolbarButton( Form, i, FALSE ); - {$ELSE} Form.TBButtonVisible[ i ] := FALSE; {$ENDIF} -end; - -procedure FormDisableToolbarButton( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - {$IFDEF USE_GRUSH} - EnableToolbarButton( Form, i, FALSE ); - {$ELSE} Form.TBButtonEnabled[ i ] := FALSE; {$ENDIF} -end; - -procedure FormFixFlatXPToolbar( Form: PControl ); -begin - Form.OnTBCustomDraw := nil; -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetDateTimeFormat( Form: PControl ); -begin ParentForm_StrParam(Form); - Form.DateTimeFormat := Form.FormParentForm.FormString; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// - -procedure FormSetDateTimeColor( Form: PControl ); -var i: Integer; - C: TColor; -begin C := ParentForm_ColorParamPas( Form ); - i := ParentForm_IntParamPas( Form ); - Form.DateTimePickerColors[TDateTimePickerColor(i)] := C; -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetCurrentTab( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - Form.CurIndex := i; - Form.Pages[i].BringToFront; -end; - -procedure FormSetCurIdx( Form: PControl ); -begin - Form.CurIndex := ParentForm_IntParamPas(Form); -end; - -procedure FormSetSBMin( Form: PControl ); -begin - Form.SBMin := ParentForm_IntParamPas(Form); -end; - -procedure FormSetSBMax( Form: PControl ); -begin - Form.SBMax := ParentForm_IntParamPas(Form); -end; - -procedure FormSetSBPosition( Form: PControl ); -begin - Form.SBPosition := ParentForm_IntParamPas(Form); -end; - -procedure FormSetSBPageSize( Form: PControl ); -begin - Form.SBPageSize := ParentForm_IntParamPas(Form); -end; - -procedure FormLastCreatedChildAsNewCurrentParent( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - Form.DF.FormCurrentParent := C; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// - -procedure FormSetUpperParent( Form: PControl ); -begin Form := Form.FormParentForm; - Form.DF.FormCurrentParent := Form.DF.FormCurrentParent.Parent; -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetTabpageAsParent( Form: PControl ); -var i: Integer; - C: PControl; -begin C := Form; - Form := Form.FormParentForm; - i := Form.FormGetIntParam; - Form.DF.FormCurrentParent := C.Pages[i]; - Form.DF.FormLastCreatedChild := Form.DF.FormCurrentParent; -end; - -procedure FormSetCurCtl( Form: PControl ); -var i: Integer; - C: PControl; -begin Form := Form.FormParentForm; - i := Form.FormGetIntParam; - C := PPControl(PAnsiChar( Form.DF.FormAddress ) + i * SizeOf(Pointer))^; - if C = nil then C := Form; - Form.DF.FormLastCreatedChild := C; -end; -{$ENDIF PAS_VERSION} - -procedure FormSetParent( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - Form.DF.FormCurrentParent := C; -end; - -{$IFDEF ASM_VERSION}{$ELSE}///////////////////////////////////////////////////// -procedure FormSetEvent( Form: PControl ); -type TSetEventProc = procedure( TargetCtl: PControl; const event: TOnEvent ); -var C: PControl; - idx_handler, idx_setter: Integer; - handler, setter: Pointer; - event: TOnEvent; - set_proc: TSetEventProc; -begin C := Form; - Form := Form.FormParentForm; - idx_handler := Form.FormGetIntParam; - idx_setter := Form.FormGetIntParam; - handler := @Form.DF.FormAlphabet[idx_handler]; - setter := @Form.DF.FormAlphabet[idx_setter]; - set_proc := TSetEventProc( setter ); - Pointer( TMethod( event ).Code ) := handler; - TMethod( event ).Data := Form.DF.FormObj; - set_proc( PControl( C ), event ); -end; - -procedure FormSetIndexedEvent( Form: PControl ); -type TSetIndexedEventProc = procedure( TargetCtl: PControl; Index: Integer; const event: TOnEvent ); -var C: PControl; - idx_handler, idx_setter, idx: Integer; - handler, setter: Pointer; - event: TOnEvent; - set_proc: TSetIndexedEventProc; -begin C := Form; - Form := Form.FormParentForm; - idx_handler := Form.FormGetIntParam; - idx := Form.FormGetIntParam; - idx_setter := Form.FormGetIntParam; - handler := @Form.DF.FormAlphabet[idx_handler]; - setter := @Form.DF.FormAlphabet[idx_setter]; - set_proc := TSetIndexedEventProc( setter ); - Pointer( TMethod( event ).Code ) := handler; - TMethod( event ).Data := Form.DF.FormObj; - set_proc( PControl( C ), idx, event ); -end; -{$ENDIF} - procedure DummyOverrideScrollbars(Sender: PControl); begin end; {$IFnDEF PAS_VERSION} - {$I KOL_ASM.inc.pas} //<<<<<<<<< KOL_ASM.inc + {$I KOL_ASM.inc} {$IFnDEF UNICODE_CTRLS} - {$I KOL_ASM_NOUNICODE.inc} //<<<<<<<<< KOL_ASM_NOUNICODE.inc + {$I KOL_ASM_NOUNICODE.inc} {$ENDIF noUNICODE} {$ENDIF PAS_VERSION} {$IFDEF USE_CUSTOMEXTENSIONS} - {$I CUSTOM_CODE_EXTENSION.inc} // See comments in TControl + {$I CUSTOM_CODE_EXTENSION.inc} // See comments in TControl {$ENDIF USE_CUSTOMEXTENSIONS} {$IFDEF EVENTS_DYNAMIC}//------------------------------------------------------- @@ -54315,43 +49755,38 @@ procedure TControl.ResetEvent(idx: Integer); begin TMethod( EV.MethodEvents[idx] ).Code := DummyProcTable[ InitEventsTable[ idx ] and $F ]; TMethod( EV.MethodEvents[idx] ).Data := nil; end; -{$IFDEF COMMANDACTIONS_OBJ} + { TCommandActionsObj } -{$IFDEF ASM_VERSION}//////////////////////////////////////////////////////////// + +{$IFDEF ASM_VERSION} destructor TCommandActionsObj.Destroy; -asm MOV EDX, [EAX].fIndexInActions - MOV dword ptr [EDX*4+AllActions_Objs], 0 - CALL TObj.Destroy -end; {$ELSE}//////////////////////////////////////////////////////////////////// +asm + MOV EDX, [EAX].fIndexInActions + MOV dword ptr [EDX*4+AllActions_Objs], 0 + CALL TObj.Destroy +end; +{$ELSE} destructor TCommandActionsObj.Destroy; -begin AllActions_Objs[fIndexInActions] := nil; - inherited; -end; {$ENDIF}/////////////////////////////////////////////////////////////////// +begin + AllActions_Objs[fIndexInActions] := nil; + inherited; +end; {$ENDIF} + {$IFDEF GRAPHCTL_XPSTYLES}{$DEFINE INIT_FINIT}{$ENDIF} {$IFDEF USE_NAMES}{$DEFINE INIT_FINIT}{$ENDIF} -{$IFNDEF NOT_UNLOAD_RICHEDITLIB}{$IFDEF UNLOAD_RICHEDITLIB} - {$DEFINE INIT_FINIT} -{$ENDIF}{$ENDIF} -{$IFDEF INIT_FINIT}//----------------------------------------------------------- -//****************************************************************************** -initialization //............................................................... -{$IFDEF GRAPHCTL_XPSTYLES} - CheckThemes; - if AppTheming then - InitThemes; -{$ENDIF} -finalization //................................................................. -{$IFDEF GRAPHCTL_XPSTYLES} - if AppTheming then - DeinitThemes; -{$ENDIF} -{$IFNDEF NOT_UNLOAD_RICHEDITLIB} -{$IFDEF UNLOAD_RICHEDITLIB} - if FRichEditModule <> 0 then - FreeLibrary( FRichEditModule ); -{$ENDIF UNLOAD_RICHEDITLIB} -{$ENDIF} -{$ENDIF INIT_FINIT}//----------------------------------------------------------- +{$IFDEF INIT_FINIT} +initialization + {$IFDEF GRAPHCTL_XPSTYLES} + CheckThemes; + if AppTheming then + InitThemes; + {$ENDIF} +finalization + {$IFDEF GRAPHCTL_XPSTYLES} + if AppTheming then + DeinitThemes; + {$ENDIF} +{$ENDIF INIT_FINIT} end. diff --git a/KOLDEF.inc b/KOLDEF.inc index b29d271..bfeb360 100644 --- a/KOLDEF.inc +++ b/KOLDEF.inc @@ -3,19 +3,20 @@ {$ENDIF} {$IFDEF VER140} // Delphi 6 - {$DEFINE _D6} {$DEFINE _D6orHigher} + {$DEFINE _D6} {$ENDIF} {$IFDEF VER150} // Delphi 7 {$DEFINE _D6orHigher} - {$DEFINE _D7} {$DEFINE _D7orHigher} + {$DEFINE _D7} + {$WARN UNIT_DEPRECATED OFF} {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} {$ENDIF} {$IFDEF VER160} // Delphi 8 @@ -25,61 +26,59 @@ {$IFDEF VER170} // Delphi 2005 {$DEFINE _D6orHigher} {$DEFINE _D7orHigher} - {$DEFINE _D8} - {$DEFINE _D8orHigher} - {$DEFINE _D2005} {$DEFINE _D2005orHigher} + {$DEFINE _D2005} + {$WARN UNIT_DEPRECATED OFF} {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} {$ENDIF} -{$IFDEF VER180} // Delphi 2006 - {$DEFINE _D6orHigher} - {$DEFINE _D7orHigher} - {$DEFINE _D8orHigher} - {$DEFINE _D2005} - {$DEFINE _D2005orHigher} - {$DEFINE _D2006orHigher} - {$WARN UNIT_DEPRECATED OFF} - {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} -{$ENDIF} - -{$IFDEF _D2005orHigher} // by Thaddy de Koning: - {$IFDEF VER185} // Delphi 2007 ( and Highlander ) +{$IFDEF VER180} // Delphi 2006 or Turbo {$DEFINE _D6orHigher} {$DEFINE _D7orHigher} {$DEFINE _D2005orHigher} {$DEFINE _D2006orHigher} + {$DEFINE _D2006} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} +{$ENDIF} + +{$IFDEF VER185} // Delphi 2007 + {$DEFINE _D6orHigher} + {$DEFINE _D7orHigher} + {$DEFINE _D2005orHigher} + {$DEFINE _D2006orHigher} + {$DEFINE _D2007orHigher} {$DEFINE _D2007} - {$DEFINE _D2007orHigher} - {$WARN UNIT_DEPRECATED OFF} - {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} - {$ENDIF} - {$INLINE OFF} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} {$ENDIF} -{$IFDEF VER200} // Delphi 2009 +{$IFDEF VER200} // Delphi 2009 (first unicode version) {$DEFINE _D6orHigher} {$DEFINE _D7orHigher} {$DEFINE _D2005orHigher} {$DEFINE _D2006orHigher} {$DEFINE _D2007orHigher} - {$DEFINE _D2009} {$DEFINE _D2009orHigher} + {$DEFINE _D2009} + {$WARN UNIT_DEPRECATED OFF} {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} {$ENDIF} {$IFDEF VER210} // Delphi 2010 @@ -89,13 +88,14 @@ {$DEFINE _D2006orHigher} {$DEFINE _D2007orHigher} {$DEFINE _D2009orHigher} - {$DEFINE _D2010} {$DEFINE _D2010orHigher} + {$DEFINE _D2010} + {$WARN UNIT_DEPRECATED OFF} {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} {$ENDIF} {$IFDEF VER220} // Delphi XE @@ -106,13 +106,14 @@ {$DEFINE _D2007orHigher} {$DEFINE _D2009orHigher} {$DEFINE _D2010orHigher} - {$DEFINE _DXE} {$DEFINE _DXEorHigher} - {$WARN UNIT_DEPRECATED OFF} + {$DEFINE _DXE} + + {$WARN UNIT_DEPRECATED OFF} {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} {$ENDIF} {$IFDEF VER230} // Delphi XE2 @@ -124,18 +125,18 @@ {$DEFINE _D2009orHigher} {$DEFINE _D2010orHigher} {$DEFINE _DXEorHigher} + {$DEFINE _DXE2orHigher} {$DEFINE _DXE2} - {$DEFINE _DXE2orHigher} - {$IFDEF WIN64} - {$DEFINE PAS_VERSION} - {$DEFINE PAS_ONLY} - {.$DEFINE UNICODE_CTRLS} - {$ENDIF} - {$WARN UNIT_DEPRECATED OFF} - {.$WARN SYMBOL_PLATFORM OFF} - {.$WARN UNSAFE_TYPE OFF} - {.$WARN UNSAFE_CAST OFF} - {.$WARN UNSAFE_CODE OFF} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} {$ENDIF} {$IFDEF VER240} // Delphi XE3 @@ -147,19 +148,19 @@ {$DEFINE _D2009orHigher} {$DEFINE _D2010orHigher} {$DEFINE _DXEorHigher} - {$DEFINE _DXE2orHigher} + {$DEFINE _DXE2orHigher} + {$DEFINE _DXE3orHigher} {$DEFINE _DXE3} - {$DEFINE _DXE3orHigher} - {$IFDEF WIN64} - {$DEFINE PAS_VERSION} - {$DEFINE PAS_ONLY} - {.$DEFINE UNICODE_CTRLS} - {$ENDIF} - {$WARN UNIT_DEPRECATED OFF} - {.$WARN SYMBOL_PLATFORM OFF} - {.$WARN UNSAFE_TYPE OFF} - {.$WARN UNSAFE_CAST OFF} - {.$WARN UNSAFE_CODE OFF} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} {$ENDIF} {$IFDEF VER250} // Delphi XE4 @@ -171,21 +172,22 @@ {$DEFINE _D2009orHigher} {$DEFINE _D2010orHigher} {$DEFINE _DXEorHigher} - {$DEFINE _DXE2orHigher} - {$DEFINE _DXE3orHigher} + {$DEFINE _DXE2orHigher} + {$DEFINE _DXE3orHigher} + {$DEFINE _DXE4orHigher} {$DEFINE _DXE4} - {$DEFINE _DXE4orHigher} - {$IFDEF WIN64} - {$DEFINE PAS_VERSION} - {$DEFINE PAS_ONLY} - {.$DEFINE UNICODE_CTRLS} - {$ENDIF} - {$WARN UNIT_DEPRECATED OFF} - {.$WARN SYMBOL_PLATFORM OFF} - {.$WARN UNSAFE_TYPE OFF} - {.$WARN UNSAFE_CAST OFF} - {.$WARN UNSAFE_CODE OFF} - {$DEFINE TMSG_WINDOWS} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} + + {$DEFINE TMSG_WINDOWS} {$ENDIF} {$IFDEF VER260} // Delphi XE5 @@ -197,22 +199,23 @@ {$DEFINE _D2009orHigher} {$DEFINE _D2010orHigher} {$DEFINE _DXEorHigher} - {$DEFINE _DXE2orHigher} - {$DEFINE _DXE3orHigher} - {$DEFINE _DXE4orHigher} + {$DEFINE _DXE2orHigher} + {$DEFINE _DXE3orHigher} + {$DEFINE _DXE4orHigher} + {$DEFINE _DXE5orHigher} {$DEFINE _DXE5} - {$DEFINE _DXE5orHigher} - {$IFDEF WIN64} - {$DEFINE PAS_VERSION} - {$DEFINE PAS_ONLY} - {.$DEFINE UNICODE_CTRLS} - {$ENDIF} - {$WARN UNIT_DEPRECATED OFF} - {.$WARN SYMBOL_PLATFORM OFF} - {.$WARN UNSAFE_TYPE OFF} - {.$WARN UNSAFE_CAST OFF} - {.$WARN UNSAFE_CODE OFF} - {$DEFINE TMSG_WINDOWS} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} + + {$DEFINE TMSG_WINDOWS} {$ENDIF} {$IFDEF VER270} // Delphi XE6 @@ -224,23 +227,24 @@ {$DEFINE _D2009orHigher} {$DEFINE _D2010orHigher} {$DEFINE _DXEorHigher} - {$DEFINE _DXE2orHigher} - {$DEFINE _DXE3orHigher} - {$DEFINE _DXE4orHigher} - {$DEFINE _DXE5orHigher} - {$DEFINE _DXE6} - {$DEFINE _DXE6orHigher} - {$IFDEF WIN64} - {$DEFINE PAS_VERSION} - {$DEFINE PAS_ONLY} - {.$DEFINE UNICODE_CTRLS} - {$ENDIF} - {$WARN UNIT_DEPRECATED OFF} - {.$WARN SYMBOL_PLATFORM OFF} - {.$WARN UNSAFE_TYPE OFF} - {.$WARN UNSAFE_CAST OFF} - {.$WARN UNSAFE_CODE OFF} - {$DEFINE TMSG_WINDOWS} + {$DEFINE _DXE2orHigher} + {$DEFINE _DXE3orHigher} + {$DEFINE _DXE4orHigher} + {$DEFINE _DXE5orHigher} + {$DEFINE _DXE6orHigher} + {$DEFINE _DXE6} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} + + {$DEFINE TMSG_WINDOWS} {$ENDIF} {$IFDEF VER280} // Delphi XE7 @@ -252,23 +256,120 @@ {$DEFINE _D2009orHigher} {$DEFINE _D2010orHigher} {$DEFINE _DXEorHigher} - {$DEFINE _DXE2orHigher} - {$DEFINE _DXE3orHigher} - {$DEFINE _DXE4orHigher} - {$DEFINE _DXE5orHigher} - {$DEFINE _DXE6orHigher} - {$DEFINE _DXE7} - {$DEFINE _DXE7orHigher} - {$IFDEF WIN64} - {$DEFINE PAS_VERSION} - {$DEFINE PAS_ONLY} - {.$DEFINE UNICODE_CTRLS} - {$ENDIF} - {$WARN UNIT_DEPRECATED OFF} - {.$WARN SYMBOL_PLATFORM OFF} - {.$WARN UNSAFE_TYPE OFF} - {.$WARN UNSAFE_CAST OFF} - {.$WARN UNSAFE_CODE OFF} + {$DEFINE _DXE2orHigher} + {$DEFINE _DXE3orHigher} + {$DEFINE _DXE4orHigher} + {$DEFINE _DXE5orHigher} + {$DEFINE _DXE6orHigher} + {$DEFINE _DXE7orHigher} + {$DEFINE _DXE7} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} + + {$DEFINE TMSG_WINDOWS} +{$ENDIF} + +{$IFDEF VER290} // Delphi XE8 + {$DEFINE _D6orHigher} + {$DEFINE _D7orHigher} + {$DEFINE _D2005orHigher} + {$DEFINE _D2006orHigher} + {$DEFINE _D2007orHigher} + {$DEFINE _D2009orHigher} + {$DEFINE _D2010orHigher} + {$DEFINE _DXEorHigher} + {$DEFINE _DXE2orHigher} + {$DEFINE _DXE3orHigher} + {$DEFINE _DXE4orHigher} + {$DEFINE _DXE5orHigher} + {$DEFINE _DXE6orHigher} + {$DEFINE _DXE7orHigher} + {$DEFINE _DXE8orHigher} + {$DEFINE _DXE8} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} + + {$DEFINE TMSG_WINDOWS} +{$ENDIF} + +{$IFDEF VER300} // Delphi 10 Seattle + {$DEFINE _D6orHigher} + {$DEFINE _D7orHigher} + {$DEFINE _D2005orHigher} + {$DEFINE _D2006orHigher} + {$DEFINE _D2007orHigher} + {$DEFINE _D2009orHigher} + {$DEFINE _D2010orHigher} + {$DEFINE _DXEorHigher} + {$DEFINE _DXE2orHigher} + {$DEFINE _DXE3orHigher} + {$DEFINE _DXE4orHigher} + {$DEFINE _DXE5orHigher} + {$DEFINE _DXE6orHigher} + {$DEFINE _DXE7orHigher} + {$DEFINE _DXE8orHigher} + {$DEFINE _D10orHigher} + {$DEFINE _D10} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} + + {$DEFINE TMSG_WINDOWS} +{$ENDIF} + +{$IFDEF VER310} // Delphi 10.1 Berlin + {$DEFINE _D6orHigher} + {$DEFINE _D7orHigher} + {$DEFINE _D2005orHigher} + {$DEFINE _D2006orHigher} + {$DEFINE _D2007orHigher} + {$DEFINE _D2009orHigher} + {$DEFINE _D2010orHigher} + {$DEFINE _DXEorHigher} + {$DEFINE _DXE2orHigher} + {$DEFINE _DXE3orHigher} + {$DEFINE _DXE4orHigher} + {$DEFINE _DXE5orHigher} + {$DEFINE _DXE6orHigher} + {$DEFINE _DXE7orHigher} + {$DEFINE _DXE8orHigher} + {$DEFINE _D10orHigher} + {$DEFINE _D10_1orHigher} + {$DEFINE _D10_1} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} + {$DEFINE TMSG_WINDOWS} {$ENDIF} @@ -286,31 +387,59 @@ {$DEFINE _DXE4orHigher} {$DEFINE _DXE5orHigher} {$DEFINE _DXE6orHigher} - {$DEFINE _DXE7} {$DEFINE _DXE7orHigher} - {$DEFINE _D10_2} + {$DEFINE _DXE8orHigher} + {$DEFINE _D10orHigher} + {$DEFINE _D10_1orHigher} {$DEFINE _D10_2orHigher} - {$IFDEF WIN64} - {$DEFINE PAS_VERSION} - {$DEFINE PAS_ONLY} - {.$DEFINE UNICODE_CTRLS} - {$ENDIF} + {$DEFINE _D10_2} + {$WARN UNIT_DEPRECATED OFF} - {.$WARN SYMBOL_PLATFORM OFF} - {.$WARN UNSAFE_TYPE OFF} - {.$WARN UNSAFE_CAST OFF} - {.$WARN UNSAFE_CODE OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} + {$DEFINE TMSG_WINDOWS} {$ENDIF} -// TODO: check DLL project -{$IFNDEF NO_STRIP_RELOC} - // by Thaddy de Koning: - {$IFDEF _D2006orHigher} - // strips relocs, like stripreloc.exe does - {$SetPEFlags 1} - //{$SETPEFlAGS IMAGE_FILE_RELOCS_STRIPPED or IMAGE_FILE_DEBUG_STRIPPED or IMAGE_FILE_LINE_NUMS_STRIPPED or IMAGE_FILE_LOCAL_SYMS_STRIPPED or IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP or IMAGE_FILE_NET_RUN_FROM_SWAP} - {$ENDIF} +{$IFDEF VER330} // Delphi 10.3 Rio + {$DEFINE _D6orHigher} + {$DEFINE _D7orHigher} + {$DEFINE _D2005orHigher} + {$DEFINE _D2006orHigher} + {$DEFINE _D2007orHigher} + {$DEFINE _D2009orHigher} + {$DEFINE _D2010orHigher} + {$DEFINE _DXEorHigher} + {$DEFINE _DXE2orHigher} + {$DEFINE _DXE3orHigher} + {$DEFINE _DXE4orHigher} + {$DEFINE _DXE5orHigher} + {$DEFINE _DXE6orHigher} + {$DEFINE _DXE7orHigher} + {$DEFINE _DXE8orHigher} + {$DEFINE _D10orHigher} + {$DEFINE _D10_1orHigher} + {$DEFINE _D10_2orHigher} + {$DEFINE _D10_3orHigher} + {$DEFINE _D10_3} + + {$WARN UNIT_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} +// {$WARN UNSAFE_TYPE OFF} +// {$WARN UNSAFE_CAST OFF} +// {$WARN UNSAFE_CODE OFF} + +// {$IFDEF WIN64} +// {$DEFINE UNICODE_CTRLS} +// {$ENDIF} + + {$DEFINE TMSG_WINDOWS} {$ENDIF} {$IFDEF FPC} @@ -327,14 +456,14 @@ ------------------------------------} {$DEFINE PAS_VERSION} {$IFDEF VER2} - {$DEFINE _D6orHigher} + {$DEFINE _D6orHigher} {$DEFINE _D7} {$DEFINE _D7orHigher} {$ENDIF} {$IFDEF VER3} // I should clean this up later. {$DEFINE VER2} - {$DEFINE _D6orHigher} + {$DEFINE _D6orHigher} {$DEFINE _D7} {$DEFINE _D7orHigher} {$DEFINE _D2005orHigher} @@ -347,21 +476,13 @@ {$DEFINE _KOLCtrlWrapper_} {$ENDIF} -{$IFNDEF _NOT_KOLCtrlWrapper_} - {$DEFINE _KOLCtrlWrapper_} -{$ENDIF} - //// from delphidef.inc //// -//{$DEFINE _FPC} -{$DEFINE ASM_VERSION} // Comment this line to produce Pascal code. - // Or, just add PAS_VERSION to conditionals of your project (must be rebuilt). - +{$DEFINE ASM_VERSION} // Comment this line to produce Pascal code. Or, just add PAS_VERSION to conditionals of your project (must be rebuilt). {$IFDEF ASM_VERSION} {$IFDEF PAS_VERSION} {$UNDEF ASM_VERSION} - // To compile a project with ASM_VERSION option turned off, - // define a symbol PAS_VERSION in project options. + // To compile a project with ASM_VERSION option turned off, define a symbol PAS_VERSION in project options. {$ENDIF} {$ENDIF} @@ -374,13 +495,6 @@ // directive there. (Search the word: USE_CUSTOMEXTENSIONS). // Please note, that this option is not fully supported now. -//{$IFNDEF NOT_UNLOAD_RICHEDITLIB} -// {$DEFINE UNLOAD_RICHEDITLIB} -//{$ENDIF} -// You can freely comment this directive. 1st, if the application does not -// use richedit control. 2nd, even if it does, freeing the library handle actually is not needed. -// Another way to turn this option off is to define symbol NOT_UNLOAD_RICHEDITLIB in your project options. - {$IFNDEF USE_OLD_FLAGS} {$DEFINE USE_FLAGS} {$ELSE} @@ -391,12 +505,50 @@ {$DEFINE EVENTS_DYNAMIC} {$ENDIF} -{$IFnDEF CMDACTIONS_RECORD} - {$DEFINE COMMANDACTIONS_OBJ} - {$DEFINE PACK_COMMANDACTIONS} - {$IFDEF NOT_PACK_COMMANDACTIONS} - {$UNDEF PACK_COMMANDACTIONS} +{$DEFINE PACK_COMMANDACTIONS} +{$IFDEF NOT_PACK_COMMANDACTIONS} + {$UNDEF PACK_COMMANDACTIONS} +{$ENDIF} + +{$IFDEF WIN64} + {$DEFINE PAS_VERSION} + {$DEFINE PAS_ONLY} + {$ALIGN ON} + {$Z1} // MinEnumSize +{$ELSE} + {$A-} // align off, otherwise code is not good + {$Q-} // no overflow check: this option makes code wrong + {$R-} // no range checking: this option makes code wrong + {$Z-} +{$ENDIF} + +{$T-} // not typed @-operator + +{$IFDEF PAS_ONLY} + {$DEFINE PAS_VERSION} +{$ENDIF PAS_ONLY} + +{$IFDEF PUREPASCAL} + {$DEFINE PAS_VERSION} + {$DEFINE PAS_ONLY} +{$ENDIF} + +{$IFDEF INPACKAGE} // use this symbol in packages requiring kol.pas + {$WARNINGS OFF} + {$DEFINE PAS_VERSION} + {$UNDEF ASM_VERSION} + {$UNDEF ASM_UNICODE} + +{$ENDIF} + +{$IFDEF _D2009orHigher} + {$DEFINE UNICODE_CTRLS} +{$ENDIF} + +{$IFDEF UNICODE_CTRLS} + {$IFDEF _D2009orHigher} + {$DEFINE UStr_} // use functions @UStrXXXX instead of @WStrXXXX {$ENDIF} {$ENDIF} -{$DEFINE KOL3XX} \ No newline at end of file +{$DEFINE KOL3XX} diff --git a/KOLDirDlgEx.pas b/KOLDirDlgEx.pas index 6638050..772bcfe 100644 --- a/KOLDirDlgEx.pas +++ b/KOLDirDlgEx.pas @@ -98,9 +98,8 @@ type procedure DoCancel( Sender: PObj ); procedure DoNotClose( Sender: PObj; var Accept: Boolean ); procedure DoShow( Sender: PObj ); - function DoMsg( var Msg: TMsg; var Rslt: Integer ): Boolean; - function DoExpanding( Sender: PControl; Item: THandle; Expand: Boolean ) - : Boolean; + function DoMsg( var Msg: TMsg; var Rslt: LRESULT ): Boolean; + function DoExpanding( Sender: PControl; Item: THandle; Expand: Boolean ): Boolean; function DoFilterAttrs( Attrs: DWORD; const APath: KOLString ): Boolean; procedure Rescantree; procedure RescanNode( node: Integer ); @@ -687,7 +686,7 @@ begin end; end; -function TOpenDirDialogEx.DoMsg(var Msg: TMsg; var Rslt: Integer): Boolean; +function TOpenDirDialogEx.DoMsg(var Msg: TMsg; var Rslt: LRESULT): Boolean; var NMHdr: PNMHdr; NMCustomDraw: PNMCustomDraw; i: Integer; @@ -1073,7 +1072,7 @@ begin SL.Add( Find32W.cFileName ); if not FFindNextFileW( F, @Find32W ) then break; end; - SL.Sort( FALSE ); + SL.Sort( [] ); //LogFileOutput( 'C:\sort_test.txt', '--------------------------'#13#10#13#10 + // SL.Text ); FINALLY diff --git a/KOLMCK2006.res b/KOLMCK2006.res new file mode 100644 index 0000000..d57cb2e Binary files /dev/null and b/KOLMCK2006.res differ diff --git a/KOLMCK2007.res b/KOLMCK2007.res new file mode 100644 index 0000000..d57cb2e Binary files /dev/null and b/KOLMCK2007.res differ diff --git a/KOLMCK2009.res b/KOLMCK2009.res new file mode 100644 index 0000000..d57cb2e Binary files /dev/null and b/KOLMCK2009.res differ diff --git a/KOLMCK2010.res b/KOLMCK2010.res new file mode 100644 index 0000000..d57cb2e Binary files /dev/null and b/KOLMCK2010.res differ diff --git a/KOLMCK3.dpk b/KOLMCK3.dpk deleted file mode 100644 index fe42184..0000000 --- a/KOLMCK3.dpk +++ /dev/null @@ -1,47 +0,0 @@ -package KOLMCK3; - -{$R *.res} -{$ALIGN ON} -{$ASSERTIONS ON} -{$BOOLEVAL OFF} -{$DEBUGINFO ON} -{$EXTENDEDSYNTAX ON} -{$IMPORTEDDATA ON} -{$IOCHECKS ON} -{$LOCALSYMBOLS ON} -{$LONGSTRINGS ON} -{$OPENSTRINGS ON} -{$OPTIMIZATION OFF} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} -{$REFERENCEINFO ON} -{$SAFEDIVIDE OFF} -{$STACKFRAMES ON} -{$TYPEDADDRESS OFF} -{$VARSTRINGCHECKS ON} -{$WRITEABLECONST ON} -{$MINENUMSIZE 1} -{$IMAGEBASE $00400000} -{$DESCRIPTION '_KOL_ mirror controls for Delphi 3'} -{$DESIGNONLY} -{$IMPLICITBUILD ON} - -requires - vcl30, - vclx30; - -contains - mirror, - KOL, - mckCtrls, - mckObjs, - mckCtrlDraw, - mckActionListEditor, - mckLVColumnsEditor, - mckToolbarEditor, - mckAccEditor, - mckMenuEditor, - mckFileFilterEditor, - KOLadd in 'KOLadd.pas'; - -end. diff --git a/KOLMCK5.dpk b/KOLMCK5.dpk deleted file mode 100644 index c6c1127..0000000 --- a/KOLMCK5.dpk +++ /dev/null @@ -1,49 +0,0 @@ -package KOLMCK5; - -{$R *.res} -{$ALIGN ON} -{$ASSERTIONS OFF} -{$BOOLEVAL OFF} -{$DEBUGINFO ON} -{$EXTENDEDSYNTAX ON} -{$IMPORTEDDATA ON} -{$IOCHECKS ON} -{$LOCALSYMBOLS ON} -{$LONGSTRINGS ON} -{$OPENSTRINGS ON} -{$OPTIMIZATION ON} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} -{$REFERENCEINFO ON} -{$SAFEDIVIDE OFF} -{$STACKFRAMES OFF} -{$TYPEDADDRESS OFF} -{$VARSTRINGCHECKS ON} -{$WRITEABLECONST ON} -{$MINENUMSIZE 1} -{$IMAGEBASE $400000} -{$DESCRIPTION '_KOL_ mirror controls for Delphi 5'} -{$DESIGNONLY} -{$IMPLICITBUILD ON} -{$DEFINE INPACKAGE} -{$DEFINE _NOT_KOLCtrlWrapper} - -requires - vcl50, - Vclx50; - -contains - mirror in 'mirror.pas', - KOL in 'KOL.pas', - mckCtrls in 'mckCtrls.pas', - mckObjs in 'mckObjs.pas', - mckAccEditor in 'mckAccEditor.pas' {KOLAccEdit}, - mckMenuEditor in 'mckMenuEditor.pas', - mckFileFilterEditor in 'mckFileFilterEditor.pas' {fmFileFilterEditor}, - mckToolbarEditor in 'mckToolbarEditor.pas' {fmToolbarEditor}, - mckLVColumnsEditor in 'mckLVColumnsEditor.pas' {fmLVColumnsEditor}, - mckCtrlDraw in 'mckCtrlDraw.pas', - mckActionListEditor in 'mckActionListEditor.pas', - KOLadd in 'KOLadd.pas'; - -end. diff --git a/KOLMCK6.dpk b/KOLMCK6.dpk deleted file mode 100644 index 4a444d5..0000000 --- a/KOLMCK6.dpk +++ /dev/null @@ -1,52 +0,0 @@ -package KOLMCK6; - -{$R *.res} -{$ALIGN 8} -{$ASSERTIONS ON} -{$BOOLEVAL OFF} -{$DEBUGINFO ON} -{$EXTENDEDSYNTAX ON} -{$IMPORTEDDATA ON} -{$IOCHECKS ON} -{$LOCALSYMBOLS ON} -{$LONGSTRINGS ON} -{$OPENSTRINGS ON} -{$OPTIMIZATION OFF} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} -{$REFERENCEINFO ON} -{$SAFEDIVIDE OFF} -{$STACKFRAMES ON} -{$TYPEDADDRESS OFF} -{$VARSTRINGCHECKS ON} -{$WRITEABLECONST ON} -{$MINENUMSIZE 1} -{$IMAGEBASE $400000} -{$DESCRIPTION '_KOL_ mirror controls for Delphi 6'} -{$DESIGNONLY} -{$IMPLICITBUILD ON} -{$DEFINE INPACKAGE} -{$DEFINE PAS_VERSION} -{$DEFINE noMCKLOG} -{$DEFINE noNOT_USE_KOLCtrlWrapper} - -requires - vcl, - vclx, - designide; - -contains - KOL in 'KOL.pas', - KOLadd in 'KOLadd.pas', - mirror in 'mirror.pas', - mckCtrls in 'mckCtrls.pas', - mckObjs in 'mckObjs.pas', - mckAccEditor in 'mckAccEditor.pas' {KOLAccEdit}, - mckMenuEditor in 'mckMenuEditor.pas', - mckFileFilterEditor in 'mckFileFilterEditor.pas' {fmFileFilterEditor}, - mckToolbarEditor in 'mckToolbarEditor.pas' {fmToolbarEditor}, - mckLVColumnsEditor in 'mckLVColumnsEditor.pas', - mckCtrlDraw in 'mckCtrlDraw.pas', - mckActionListEditor in 'mckActionListEditor.pas'; - -end. diff --git a/KOLMCK7.res b/KOLMCK7.res new file mode 100644 index 0000000..d57cb2e Binary files /dev/null and b/KOLMCK7.res differ diff --git a/KOLMCK4.dpk b/KOLMCKXE10_2.dpk similarity index 61% rename from KOLMCK4.dpk rename to KOLMCKXE10_2.dpk index af1e24f..d6f432a 100644 --- a/KOLMCK4.dpk +++ b/KOLMCKXE10_2.dpk @@ -1,7 +1,8 @@ -package KOLMCK4; +package KOLMCKXE10_2; {$R *.res} -{$ALIGN ON} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} {$DEBUGINFO ON} @@ -11,40 +12,46 @@ package KOLMCK4; {$LOCALSYMBOLS ON} {$LONGSTRINGS ON} {$OPENSTRINGS ON} -{$OPTIMIZATION OFF} +{$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {$REFERENCEINFO ON} {$SAFEDIVIDE OFF} -{$STACKFRAMES ON} +{$STACKFRAMES OFF} {$TYPEDADDRESS OFF} {$VARSTRINGCHECKS ON} -{$WRITEABLECONST ON} +{$WRITEABLECONST OFF} {$MINENUMSIZE 1} -{$IMAGEBASE $00400000} -{$DESCRIPTION '_KOL_ mirror controls for Delphi 4'} +{$IMAGEBASE $13400000} +{$DESCRIPTION 'KOLMCKXE10_2'} +{$DEFINE UNICODE_CTRLS} +{$DEFINE PAS_ONLY} +{$DEFINE PAS_VERSION} +{$ENDIF IMPLICITBUILDING} {$DESIGNONLY} -{$IMPLICITBUILD ON} +{$IMPLICITBUILD OFF} {$DEFINE INPACKAGE} -{$DEFINE _NOT_Use_KOLCtrlWrapper} requires - vcl40, - Vclx40; + rtl, + vcl, + designide, + xmlrtl, + vclx; contains + KOL in 'KOL.pas', + KOLadd in 'KOLadd.pas', mirror in 'mirror.pas', mckObjs in 'mckObjs.pas', mckCtrls in 'mckCtrls.pas', - KOL in 'KOL.pas', - mckAccEditorD4 in 'mckAccEditorD4.pas', mckCtrlDraw in 'mckCtrlDraw.pas', - mckActionListEditor in 'mckActionListEditor.pas', mckMenuEditor in 'mckMenuEditor.pas', - mckAccEditor in 'mckAccEditor.pas', mckToolbarEditor in 'mckToolbarEditor.pas', - mckLVColumnsEditor in 'mckLVColumnsEditor.pas', + mckAccEditor in 'mckAccEditor.pas', + mckActionListEditor in 'mckActionListEditor.pas', mckFileFilterEditor in 'mckFileFilterEditor.pas', - KOLadd in 'KOLadd.pas'; + mckLVColumnsEditor in 'mckLVColumnsEditor.pas', + MCKAppExpert200x in 'MCKAppExpert200x.pas'; end. diff --git a/KOLMCKXE10_2.res b/KOLMCKXE10_2.res new file mode 100644 index 0000000..d57cb2e Binary files /dev/null and b/KOLMCKXE10_2.res differ diff --git a/KOLMCKXE7.res b/KOLMCKXE7.res new file mode 100644 index 0000000..d57cb2e Binary files /dev/null and b/KOLMCKXE7.res differ diff --git a/KOL_API.inc.pas b/KOL_API.inc similarity index 100% rename from KOL_API.inc.pas rename to KOL_API.inc diff --git a/KOL_ASM.inc.pas b/KOL_ASM.inc similarity index 81% rename from KOL_ASM.inc.pas rename to KOL_ASM.inc index 9c7f7ee..504aec4 100644 --- a/KOL_ASM.inc.pas +++ b/KOL_ASM.inc @@ -9,9 +9,7 @@ asm MOV ECX, [Applet] XOR EAX, EAX - {$IFDEF SAFE_CODE} JECXZ @@1 - {$ENDIF} {$IFDEF SNAPMOUSE2DFLTBTN} PUSHAD XCHG EAX, ECX @@ -41,9 +39,7 @@ asm {$ENDIF} {$IFDEF SNAPMOUSE2DFLTBTN} MOV ECX, [Applet] - {$IFDEF SAFE_CODE} JECXZ @@2 - {$ENDIF} PUSH EAX XCHG EAX, ECX MOV EDX, offset[WndProcSnapMouse2DfltBtn] @@ -191,48 +187,18 @@ asm @@exit: end; -{$IFDEF OLD_REFCOUNT} -procedure TObj.DoDestroy; -asm - MOV EDX, [EAX].fRefCount - SAR EDX, 1 - JZ @@1 - JC @@exit - DEC [EAX].fRefCount - STC - -@@1: JC @@exit - MOV EDX, [EAX] - CALL dword ptr [EDX + 4] -@@exit: -end; -{$ENDIF OLD_REFCOUNT} - function TObj.RefDec: Integer; asm TEST EAX, EAX JZ @@exit - SUB [EAX].fRefCount, 2 - JGE @@exit - {$IFDEF OLD_REFCOUNT} - TEST [EAX].fRefCount, 1 - JZ @@exit - MOV EDX, [EAX] - {$ENDIF} - MOV EDX, [EAX] - PUSH dword ptr [EDX+4] + SUB [EAX].fRefCount, 2 + JGE @@exit + MOV EDX, [EAX] + PUSH dword ptr [EDX+4] @@exit: end; -{$IFDEF OLD_FREE} -procedure TObj.Free; -asm - //TEST EAX,EAX - JMP RefDec -end; -{$ENDIF OLD_FREE} - {$IFNDEF CRASH_DEBUG} destructor TObj.Destroy; asm @@ -357,12 +323,7 @@ asm @@old: {$ENDIF} CMP EDX, [EAX].fCount - {$IFDEF USE_CMOV} CMOVL EDX, [EAX].fCount - {$ELSE} - JGE @@1 - MOV EDX, [EAX].fCount -@@1: {$ENDIF} CMP EDX, [EAX].fCapacity JE @@exit @@ -410,118 +371,6 @@ asm CALL System.@FreeMem end; -{$IFDEF ASM_NO_VERSION} -procedure TList.Add( Value: Pointer ); -asm - PUSH EDX - {$IFDEF TLIST_FAST} - //if fUseBlocks and ((fCount >= 256) or Assigned( fBlockList )) then - CMP [EAX].fUseBlocks, 0 - JZ @@old - MOV ECX, [EAX].fBlockList - CMP [EAX].fCount, 256 - JGE @@1 - JECXZ @@old -@@1: - PUSH EBX - PUSH ESI - XCHG EBX, EAX // EBX == @Self - MOV ESI, ECX - //if fBlockList = nil then - INC ECX - LOOP @@2 - CALL NewList - XCHG ESI, EAX // ESI == fBlockList - MOV [EBX].fBlockList, ESI //fBlockList := NewList; - MOV [ESI].fUseBlocks, 0 //fBlockList.fUseBlocks := FALSE; - XOR EDX, EDX - XCHG EDX, [EBX].fItems //fItems := nil; - MOV EAX, ESI - CALL TList.Add //fBlockList.Add( fItems ); - MOV EDX, [EBX].fCount - MOV EAX, ESI - CALL TList.Add //fBlockList.Add( Pointer( fCount ) ); -@@2: - //if fBlockList.fCount = 0 then - MOV ECX, [ESI].fCount - JECXZ @@2A - //LastBlockCount := Integer( fBlockList.fItems[ fBlockList.fCount-1 ] ); - MOV EDX, [ESI].fItems - MOV EAX, [EDX+ECX*4-4] - //if LastBlockCount >= 256 then - CMP EAX, 256 - JL @@3 -@@2A: - MOV EAX, ESI - XOR EDX, EDX - CALL TList.Add //fBlockList.Add( nil ); - MOV EAX, ESI - XOR EDX, EDX - CALL TList.Add //fBlockList.Add( nil ); - XOR EAX, EAX //LastBlockCount := 0; -@@3: - PUSH EAX - //LastBlockStart := fBlockList.Items[ fBlockList.fCount-2 ]; - MOV ECX, [ESI].fCount - MOV EDX, [ESI].fItems - LEA EDX, [EDX+ECX*4-8] - MOV EAX, [EDX] - //if LastBlockStart = nil then - TEST EAX, EAX - JNZ @@4 - //GetMem( LastBlockStart, 256 * Sizeof( Pointer ) ); - PUSH EDX - //MOV EAX, 1024 - XOR EAX, EAX - MOV AH, 4 - CALL System.@GetMem - POP EDX - //fBlockList.Items[ fBlockList.fCount-2 ] := LastBlockStart; - MOV [EDX], EAX -@@4: - //fBlockList.Items[ fBlockList.fCount-1 ] := Pointer( LastBlockCount+1 ); - INC dword ptr[EDX+4] - POP ECX // ECX == LastBlockCount - - //inc( fCount ); - INC [EBX].fCount - //PDWORD( Integer(LastBlockStart) + Sizeof(Pointer)*LastBlockCount )^ := - // DWORD( Value ); - - POP ESI - POP EBX - POP EDX // EDX == Value - MOV [EAX+ECX*4], EDX - RET -@@old: - {$ENDIF TLIST_FAST} - LEA ECX, [EAX].fCount - MOV EDX, [ECX] - INC dword ptr [ECX] - PUSH EDX - CMP EDX, [EAX].fCapacity - PUSH EAX - JL @@ok - - MOV ECX, [EAX].fAddBy - TEST ECX, ECX - JNZ @@add - MOV ECX, EDX - SHR ECX, 2 - INC ECX - @@add: - ADD EDX, ECX - CALL TList.SetCapacity -@@ok: - POP ECX // ECX = Self - POP EAX // EAX = fCount -> Result (for TList.Insert) - POP EDX // EDX = Value - - MOV ECX, [ECX].fItems - MOV [ECX + EAX*4], EDX -end; -{$ENDIF} - {$IFDEF MoveItem_ASM} procedure TList.MoveItem(OldIdx, NewIdx: Integer); asm @@ -749,10 +598,6 @@ end; function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush; asm // // - {$IFDEF SMALLEST_CODE} - PUSH COLOR_BTNFACE - CALL GetSysColorBrush - {$ELSE} @@1: MOV ECX, [EAX].TControl.fParent JECXZ @@2 MOV EDX, [EAX].TControl.fColor @@ -797,7 +642,6 @@ asm // // MOV [ECX].TControl.fTmpBrush, EAX @@ret_EAX: {$ENDIF not STORE_fTmpBrushColorRGB} - {$ENDIF not SMALLEST_CODE} end; function NormalGetCtlBrushHandle( Sender: PControl ): HBrush; @@ -896,13 +740,7 @@ const SzfData = sizeof( fData ); asm // // TEST EDX, EDX JNZ @@1 - {$IFDEF OLD_REFCOUNT} - TEST EAX, EAX - JZ @@0 - CALL TObj.DoDestroy - {$ELSE} CALL TObj.RefDec - {$ENDIF} XOR EAX, EAX @@0: RET @@1: PUSH EDI @@ -2592,7 +2430,7 @@ asm POP ESI end; -function _AnsiCompareStrA_Fast2(const S1, S2: PAnsiChar): Integer; +function _AnsiCompareStrA_Fast(const S1, S2: PAnsiChar): Integer; asm CALL EAX2PChar CALL EDX2PChar @@ -2613,7 +2451,7 @@ asm POP ESI end; -function _AnsiCompareStrNoCaseA_Fast2(const S1, S2: PAnsiChar): Integer; +function _AnsiCompareStrNoCaseA_Fast(const S1, S2: PAnsiChar): Integer; asm CALL EAX2PChar CALL EDX2PChar @@ -2717,40 +2555,6 @@ asm @@ret_0:XOR EAX, EAX end; -{$IFDEF ASM_no} -procedure NormalizeUnixText( var S: AnsiString ); -asm //cmd //opd - CMP dword ptr [EAX], 0 - JZ @@exit - PUSH EBX - PUSH EDI - MOV EBX, EAX - CALL UniqueString - MOV EDI, [EBX] -@@1: MOV EAX, EDI - CALL System.@LStrLen - XCHG ECX, EAX - MOV AX, $0D0A - - CMP byte ptr [EDI], AL - JNE @@loo - MOV byte ptr [EDI], AH -@@loo: - TEST ECX, ECX - JZ @@fin -@@loo1: - REPNZ SCASB - JNZ @@fin - CMP byte ptr [EDI-2], AH - JE @@loo - MOV byte ptr [EDI-1], AH - JNE @@loo1 -@@fin: POP EDI - POP EBX -@@exit: -end; -{$ENDIF} - function FileCreate( const FileName: KOLString; OpenFlags: DWord): THandle; asm XOR ECX, ECX @@ -2800,67 +2604,6 @@ asm POP EBP end; -{$IFDEF fixed_asm} -function File2Str( Handle: THandle): AnsiString; -asm - PUSH EDX - TEST EAX, EAX - JZ @@exit // return '' - - PUSH EBX - MOV EBX, EAX // EBX = Handle - XOR EDX, EDX - XOR ECX, ECX - INC ECX - CALL FileSeek - PUSH EAX // Pos - PUSH 0 - PUSH EBX - CALL GetFileSize - POP EDX - SUB EAX, EDX // EAX = Size - Pos - JZ @@exitEBX - - PUSH EAX - CALL System.@GetMem - XCHG EAX, EBX - MOV EDX, EBX - POP ECX - PUSH ECX - CALL FileRead - POP ECX - MOV EDX, EBX - POP EBX - POP EAX - PUSH EDX - {$IFDEF _D2009orHigher} - PUSH ECX // TODO: check to remove - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPCharLen - {$IFDEF _D2009orHigher} - POP ECX - {$ENDIF} - JMP @@freebuf -@@exitEBX: - POP EBX -@@exit: - XCHG EDX, EAX - POP EAX // @Result - PUSH EDX - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: confirm not need push - {$ENDIF} - CALL System.@LStrFromPChar -@@freebuf: - POP EAX - TEST EAX, EAX - JZ @@fin - CALL System.@FreeMem -@@fin: -end; -{$ENDIF} - function FileWrite( Handle: THandle; const Buffer; Count: DWord): DWord; asm PUSH EBP @@ -3033,16 +2776,7 @@ procedure SwapDirItems( Data : PSortDirData; const e1, e2 : DWORD ); asm MOV EAX, [EAX].TSortDirData.Dir MOV EAX, [EAX].TDirList.FListPositions - {$IFDEF xxSPEED_FASTER} //||||||||||||||||||||||||||||||||||||||||||||| - MOV EAX, [EAX].TList.fItems - LEA EDX, [EAX+EDX*4] - LEA ECX, [EAX+ECX*4] - MOV EAX, [EDX] - XCHG EAX, [ECX] - MOV [EDX], EAX - {$ELSE} CALL TList.Swap - {$ENDIF} end; destructor TThread.Destroy; @@ -3222,7 +2956,6 @@ asm POP [EBX].TControl.fControlClassName //INC [EBX].TControl.fWindowed // set in TControl.Init - {$IFDEF COMMANDACTIONS_OBJ} MOV EAX, EDI CMP EAX, 120 JB @@IdxActions_Loaded @@ -3268,20 +3001,6 @@ asm MOV EAX, EBX CALL TControl.Add2AutoFree - {$ELSE} - TEST EDI, EDI - JZ @@no_actions2 - PUSH ESI - MOV ESI, EDI - LEA EDI, [EBX].TControl.fCommandActions - XOR ECX, ECX - MOV CL, Sz_TCommandActions - REP MOVSB - POP ESI - JMP @@actions_created -@@no_actions2: - MOV [EBX].TControl.fCommandActions.TCommandActions.aClear, offset[ClearText] - {$ENDIF} @@actions_created: TEST ESI, ESI @@ -3295,69 +3014,45 @@ asm MOVSD // fTextColor MOVSD // fColor - {$IFDEF SMALLEST_CODE} - {$IFDEF SMALLEST_CODE_PARENTFONT} - LODSD - XCHG EDX, EAX - XOR EAX, EAX - CALL TGraphicTool.Assign - STOSD // fFont - {$ELSE} - LODSD - XOR EAX, EAX - STOSD // fFont = nil - {$ENDIF} - {$ELSE} - LODSD - XCHG EDX, EAX - XOR EAX, EAX - PUSH EDX - CALL TGraphicTool.Assign - STOSD // fFont - POP EDX - XCHG ECX, EAX - JECXZ @@no_font - MOV [ECX].TGraphicTool.fParentGDITool, EDX - MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Code, offset[TControl.FontChanged] - MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Data, EBX - MOV EAX, EBX - MOV EDX, ECX - CALL TControl.FontChanged - {$IFDEF USE_AUTOFREE4CONTROLS} - MOV EAX, EBX - MOV EDX, [EBX].TControl.fFont - CALL TControl.Add2AutoFree - {$ENDIF} + LODSD + XCHG EDX, EAX + XOR EAX, EAX + PUSH EDX + CALL TGraphicTool.Assign + STOSD // fFont + POP EDX + XCHG ECX, EAX + JECXZ @@no_font + MOV [ECX].TGraphicTool.fParentGDITool, EDX + MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Code, offset[TControl.FontChanged] + MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Data, EBX + MOV EAX, EBX + MOV EDX, ECX + CALL TControl.FontChanged + MOV EAX, EBX + MOV EDX, [EBX].TControl.fFont + CALL TControl.Add2AutoFree @@no_font: - {$ENDIF} - {$IFDEF SMALLEST_CODE} - LODSD - XOR EAX, EAX - STOSD - {$ELSE} - LODSD - XCHG EDX, EAX - XOR EAX, EAX - PUSH EDX - CALL TGraphicTool.Assign - STOSD // fBrush - POP EDX - XCHG ECX, EAX - JECXZ @@no_brush - MOV [ECX].TGraphicTool.fParentGDITool, EDX - MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Code, offset[TControl.BrushChanged] - MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Data, EBX - MOV EAX, EBX - MOV EDX, ECX - CALL TControl.BrushChanged - {$IFDEF USE_AUTOFREE4CONTROLS} - MOV EAX, EBX - MOV EDX, [EBX].TControl.fBrush - CALL TControl.Add2AutoFree - {$ENDIF} + LODSD + XCHG EDX, EAX + XOR EAX, EAX + PUSH EDX + CALL TGraphicTool.Assign + STOSD // fBrush + POP EDX + XCHG ECX, EAX + JECXZ @@no_brush + MOV [ECX].TGraphicTool.fParentGDITool, EDX + MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Code, offset[TControl.BrushChanged] + MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Data, EBX + MOV EAX, EBX + MOV EDX, ECX + CALL TControl.BrushChanged + MOV EAX, EBX + MOV EDX, [EBX].TControl.fBrush + CALL TControl.Add2AutoFree @@no_brush: - {$ENDIF} MOVSB // fMargin LODSD // skip fClientXXXXX @@ -3390,11 +3085,7 @@ asm PUSH EDX MOV EDX, offset[FormClass] MOV CL, 1 - {$IFDEF COMMANDACTIONS_OBJ} PUSH OTHER_ACTIONS - {$ELSE} - PUSH 0 - {$ENDIF} CALL _NewWindowed MOV EBX, EAX OR byte ptr [EBX].TControl.fClsStyle, CS_DBLCLKS @@ -3448,13 +3139,11 @@ asm POP EDX MOV EAX, EBX CALL TControl.SetCaption - {$IFNDEF SMALLEST_CODE} {$IFNDEF BUTTON_DBLCLICK} MOV EAX, EBX MOV EDX, offset[WndProcBtnDblClkAsClk] CALL TControl.AttachProc {$ENDIF} - {$ENDIF SMALLEST_CODE} {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} MOV EAX, EBX MOV EDX, offset[WndProcBtnReturnClick] @@ -3480,15 +3169,9 @@ asm //cmd //opd MOV ECX, [EAX].TDrawItemStruct.hwndItem JECXZ @@ret_false PUSH EDX - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] - PUSH ECX - CALL GetProp - {$ELSE} PUSH GWL_USERDATA PUSH ECX CALL GetWindowLongPtr - {$ENDIF} POP EDX TEST EAX, EAX JZ @@ret_false @@ -3503,185 +3186,6 @@ asm //cmd //opd XOR EAX, EAX end; -{$IFDEF BITBTN_ASM} -function NewBitBtn( AParent: PControl; const Caption: KOLString; - Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl; -const szBitmapInfo = sizeof(TBitmapInfo); -asm - PUSH EBX - PUSH EDX - PUSH ECX - - PUSH 0 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [ButtonActions_Packed] - {$ELSE} - PUSH offset[ButtonActions] - {$ENDIF} - MOV EDX, offset[ButtonClass] - MOV ECX, WS_VISIBLE or WS_CHILD or WS_TABSTOP or BS_OWNERDRAW or BS_NOTIFY - CALL _NewControl - XCHG EBX, EAX - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG5, (1 shl G5_IgnoreDefault)or(1 shl G5_IsButton)or(1 shl G5_IsBitBtn) - {$ELSE} - INC [EBX].TControl.fIgnoreDefault - INC [EBX].TControl.fIsButton - INC [EBX].TControl.fIsBitBtn - {$ENDIF} - //MOV byte ptr [EBX].TControl.fCommandActions.aAutoSzX, 8 - //MOV byte ptr [EBX].TControl.fCommandActions.aAutoSzY, 8 - MOV word ptr [EBX].TControl.fCommandActions.aAutoSzY, $808 - POP EAX - MOV [EBX].TControl.fBitBtnOptions, AL - MOVZX EDX, Layout - MOV [EBX].TControl.fGlyphLayout, DL - MOV ECX, GlyphBitmap - MOV [EBX].TControl.fGlyphBitmap, ECX - MOV EDX, [EBX].TControl.fBoundsRect.Top - ADD EDX, 22 - MOV [EBX].TControl.fBoundsRect.Bottom, EDX - TEST ECX, ECX - JZ @@noGlyphWH - TEST AL, bboImageList - JZ @@getBmpWH - PUSH EAX - MOV EAX, ESP - PUSH EAX - MOV EDX, ESP - PUSH EAX - PUSH EDX - PUSH ECX - CALL ImageList_GetIconSize - POP EAX - POP EDX - MOV ECX, GlyphCount - JMP @@WHready -@@getBmpWH: - ADD ESP, -szBitmapInfo - PUSH ESP - PUSH szBitmapInfo - PUSH ECX - CALL GetObject - XCHG ECX, EAX - POP EAX - POP EAX - POP EDX - ADD ESP, szBitmapInfo-12 - TEST ECX, ECX - JZ @@noGlyphWH - MOV ECX, GlyphCount - INC ECX - LOOP @@GlyphCountOK - PUSH EAX - PUSH EDX - XCHG EDX, ECX - DIV ECX - XCHG ECX, EAX - POP EDX - POP EAX -@@GlyphCountOK: - CMP ECX, 1 - JLE @@WHReady - PUSH EDX - CDQ - IDIV ECX - POP EDX -@@WHReady: - MOV [EBX].TControl.fGlyphWidth, EAX - MOV [EBX].TControl.fGlyphHeight, EDX - MOV [EBX].TControl.fGlyphCount, ECX - POP ECX // ECX = @ Caption[ 1 ] - PUSH ECX - PUSH EDX - PUSH EAX - TEST EAX, EAX - JLE @@noWidthResize - JECXZ @@addWLeft - CMP [Layout], glyphOver - JE @@addWLeft - MOVZX ECX, byte ptr[ECX] - JECXZ @@addWLeft - // else - CMP [Layout], glyphLeft - JZ @@addWRight - CMP [Layout], glyphRight - JNZ @@noWidthResize -@@addWRight: - ADD [EBX].TControl.fBoundsRect.Right, EAX - ADD byte ptr [EBX].TControl.aAutoSzX, AL - JMP @@noWidthResize -@@addWLeft: - // then - ADD EAX, [EBX].TControl.fBoundsRect.Left - MOV [EBX].TControl.fBoundsRect.Right, EAX - MOV byte ptr [EBX].TControl.aAutoSzX, 0 -@@noWidthResize: - TEST EDX, EDX - JLE @@noHeightResize - CMP [Layout], glyphTop - JE @@addHBottom - CMP [Layout], glyphBottom - JNE @@addHTop -@@addHBottom: - ADD [EBX].TControl.fBoundsRect.Bottom, EDX - ADD byte ptr [EBX].TControl.aAutoSzY, DL - JMP @@noHeightResize -@@addHTop: - ADD EDX, [EBX].TControl.fBoundsRect.Top - MOV [EBX].TControl.fBoundsRect.Bottom, EDX - MOV byte ptr [EBX].TControl.aAutoSzY, 0 -@@noHeightResize: - POP ECX - POP EAX - CDQ - MOV DL, 4 - TEST [EBX].TControl.fBitBtnOptions, 2 //1 shl bboNoBorder - JNZ @@noBorderResize - JECXZ @@noBorderWinc - ADD [EBX].TControl.fBoundsRect.Right, EDX - CMP [EBX].TControl.aAutoSzX, 0 - JZ @@noBorderWinc - ADD [EBX].TControl.aAutoSzX, DL -@@noBorderWinc: - TEST EAX, EAX - JLE @@noBorderResize - ADD [EBX].TControl.fBoundsRect.Bottom, EDX - CMP [EBX].TControl.aAutoSzY, 0 - JZ @@noBorderResize - ADD [EBX].TControl.aAutoSzY, DL -@@noBorderResize: -@@noGlyphWH: - MOV ECX, [EBX].TControl.fParent - JECXZ @@notAttach2Parent - XCHG EAX, ECX - MOV EDX, offset[WndProc_DrawItem] - CALL TControl.AttachProc -@@notAttach2Parent: - MOV EAX, EBX - MOV EDX, offset[WndProcBitBtn] - CALL TControl.AttachProc - MOV EAX, EBX - POP EDX - CALL TControl.SetCaption - MOV [EBX].TControl.fTextAlign, taCenter - {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} - MOV EAX, EBX - MOV EDX, offset[WndProcBtnReturnClick] - CALL TControl.AttachProc - {$ENDIF} - XCHG EAX, EBX - POP EBX - -{$IFDEF GRAPHCTL_XPSTYLES} - PUSH EAX - MOV EDX, offset[XP_Themes_For_BitBtn] - CALL Attach_WM_THEMECHANGED - POP EAX - {$ENDIF} -end; -{$ENDIF BITBTN_ASM} - function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl; asm CALL NewButton @@ -3865,8 +3369,6 @@ asm // // MOV EBX, EAX MOV EDI, [EDX].TMsg.wParam - {$IFDEF SMALLEST_CODE} - {$ELSE} CALL TControl.CreateChildWindows {$IFDEF USE_FLAGS} TEST [EBX].TControl.fFlagsG2, (1 shl G2_Transparent) @@ -3874,10 +3376,7 @@ asm // // CMP [EBX].TControl.fTransparent, 0 {$ENDIF USE_FLAGS} JNE @@exit - {$ENDIF} - {$IFDEF SMALLEST_CODE} - {$ELSE} PUSH OPAQUE PUSH EDI CALL SetBkMode @@ -3892,7 +3391,7 @@ asm // // PUSH EAX PUSH EDI CALL SetBrushOrgEx - {$ENDIF} + SUB ESP, 16 PUSH ESP PUSH [EBX].TControl.fHandle @@ -4124,11 +3623,7 @@ asm MOV EDX, ESP CALL TControl.SetBoundsRect ADD ESP, 16 - {$IFDEF OLD_ALIGN} - MOV EAX, [EBX].TControl.fParent - {$ELSE NEW_ALIGN} MOV EAX, EBX - {$ENDIF} CALL dword ptr[Global_Align] @@e_DoDrag: @@ -4573,11 +4068,7 @@ end; function NewProgressbar( AParent: PControl ): PControl; asm PUSH 1 - {$IFDEF COMMANDACTIONS_OBJ} PUSH PROGRESS_ACTIONS - {$ELSE} - PUSH 0 - {$ENDIF} MOV EDX, offset[Progress_class] MOV ECX, WS_CHILD or WS_VISIBLE CALL _NewCommonControl @@ -4591,12 +4082,9 @@ asm XOR EDX, EDX MOV [EAX].TControl.fMenu, EDX MOV [EAX].TControl.fTextColor, clHighlight - {$IFDEF COMMANDACTIONS_OBJ} //todo: should be used separate Actions record + //todo: should be used separate Actions record MOV ECX, [EAX].TControl.fCommandActions MOV [ECX].TCommandActionsObj.aSetBkColor, PBM_SETBKCOLOR - {$ELSE} - MOV [EAX].TControl.fCommandActions.aSetBkColor, PBM_SETBKCOLOR - {$ENDIF} end; function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl; @@ -4625,15 +4113,9 @@ asm PUSH EDX push eax MOV ECX, [EDX].TMsg.lParam - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] - PUSH [ECX].TNMHdr.hwndFrom - CALL GetProp - {$ELSE} PUSH GWL_USERDATA PUSH [ECX].TNMHdr.hwndFrom CALL GetWindowLongPtr - {$ENDIF} pop ecx POP EDX TEST EAX, EAX @@ -4760,12 +4242,10 @@ procedure ApplyImageLists2Control( Sender: PControl ); asm PUSHAD XCHG ESI, EAX - {$IFDEF COMMANDACTIONS_OBJ} + MOV ECX, [ESI].TControl.fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aSetImgList - {$ELSE} - MOVZX ECX, [ESI].TControl.fCommandActions.aSetImgList - {$ENDIF} + JECXZ @@fin MOV EBP, ECX XOR EBX, EBX @@ -4950,104 +4430,6 @@ end; function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; asm //cmd //opd -{$IFDEF OLD_ALIGN} - PUSH EBP - PUSH EBX - PUSH ESI - PUSH EDI - MOV EBX, EAX - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNZ @@chk_WM_SIZE - MOV EDX, [EDX].TMsg.lParam -//!!! - CMP word ptr [EDX].TNMHdr.code, TCN_SELCHANGING - JNZ @@chk_TCN_SELCHANGE - CALL TControl.GetCurIndex - MOV [EBX].TControl.fCurIndex, EAX - JMP @@ret_false -@@chk_TCN_SELCHANGE: - CMP word ptr [EDX].TNMHdr.code, TCN_SELCHANGE - JNZ @@ret_false - - CALL TControl.GetCurIndex - XCHG EDI, EAX - CMP EDI, [EBX].TControl.fCurIndex - PUSHFD // WasActive = ZF - - MOV [EBX].TControl.FCurIndex, EDI - - MOV EAX, EBX - CALL TControl.GetItemsCount - XCHG ESI, EAX // ESI := Self_.Count - -@@loo: DEC ESI - JS @@e_loo - MOV EDX, ESI - MOV EAX, EBX - CALL TControl.GetPages - - CMP ESI, EDI - PUSH EAX - SETZ DL - CALL TControl.SetVisible - POP EAX - CMP ESI, EDI - JNE @@nx_loo - CALL TControl.BringToFront -@@nx_loo: - JMP @@loo -@@e_loo: - POPFD - JZ @@ret_false - - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - MOV ECX, [EAX].TEvents.fOnSelChange.TMethod.Code - {$ELSE} - MOV ECX, [EBX].TControl.EV.fOnSelChange.TMethod.Code - {$ENDIF} - JECXZ @@ret_false - MOV EDX, EBX - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnSelChange.TMethod.Data - {$ELSE} - MOV EAX, [EBX].TControl.EV.fOnSelChange.TMethod.Data - {$ENDIF} - CALL ECX - JMP @@ret_false -@@chk_WM_SIZE: - CMP word ptr [EDX].TMsg.message, WM_SIZE - JNE @@ret_false - ADD ESP, -16 - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL Windows.GetClientRect - PUSH ESP - PUSH 0 - PUSH TCM_ADJUSTRECT - PUSH EBX - CALL TControl.Perform - MOV EAX, EBX - CALL TControl.GetItemsCount - XCHG ESI, EAX -@@loo2: - DEC ESI - JS @@e_loo2 - MOV EDX, ESI - MOV EAX, EBX - CALL TControl.GetPages - MOV EDX, ESP - CALL TControl.SetBoundsRect - JMP @@loo2 -@@e_loo2: - ADD ESP, 16 -@@ret_false: - XOR EAX, EAX - POP EDI - POP ESI - POP EBX - POP EBP -{$ELSE NEW_ALIGN} PUSH EBX MOV EBX, EAX CMP word ptr [EDX].TMsg.message, WM_NOTIFY @@ -5128,12 +4510,9 @@ asm //cmd //opd @@ret_false: XOR EAX, EAX POP EBX -{$ENDIF} end; -{$IFNDEF OLD_ALIGN} -function NewTabEmpty( AParent: PControl; Options: TTabControlOptions; - ImgList: PImageList ): PControl; +function NewTabEmpty( AParent: PControl; Options: TTabControlOptions; ImgList: PImageList ): PControl; const lenf=high(TabControlFlags); //+++ asm //cmd //opd PUSH EBX @@ -5183,7 +4562,6 @@ asm //cmd //opd XCHG EAX, EBX POP EBX end; -{$ENDIF} {$IFNDEF NOT_USE_RICHEDIT} @@ -5205,102 +4583,6 @@ asm @@new1: CALL NewRichEdit1 end; -(* -function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNE @@ret_false - MOV EDX, [EDX].TMsg.lParam - CMP [EDX].TNMHdr.code, EN_LINK - JNE @@ret_false - PUSH EBX - PUSH EDX - XCHG EBX, EAX - XOR EAX, EAX - MOV [ECX], EAX - {$IFDEF UNICODE_CTRLS} - ADD ESP, -2040 - {$ELSE} - ADD ESP, -1020 - {$ENDIF} - PUSH EAX - PUSH ESP - PUSH [EDX].TENLink.chrg.cpMax - PUSH [EDX].TENLink.chrg.cpMin - PUSH ESP - PUSH 0 - PUSH EM_GETTEXTRANGE - PUSH EBX - CALL TControl.Perform - LEA EAX, [EBX].TControl.fREUrl - - POP EDX - POP ECX - DEC EDX - CMP ECX, EDX - POP ECX - MOV EDX, ESP - JLE @@1 - CMP byte ptr [EDX+1], 0 - JNZ @@1 - // система вернула текст как unicode - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrFromPWChar // TODO: not need ecx - {$ELSE not UNICODE_CTRLS} - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: fixme - {$ENDIF} - CALL System.@LStrFromPWChar - {$ENDIF UNICODE_CTRLS} - JMP @@2 -@@1: - // система вернула текст как обычную строку - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrFromPChar - {$ELSE not UNICODE_CTRLS} - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: fixme - {$ENDIF} - CALL System.@LStrFromPChar - {$ENDIF UNICODE_CTRLS} -@@2: - {$IFDEF UNICODE_CTRLS} - ADD ESP, 2044 - {$ELSE not UNICODE_CTRLS} - ADD ESP, 1024 - {$ENDIF UNICODE_CTRLS} - POP EDX - MOV ECX, [EDX].TENLink.msg - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - LEA EAX, [EAX].TEvents.fOnREOverURL - {$ELSE} - LEA EAX, [EBX].TControl.EV.fOnREOverURL - {$ENDIF} - CMP ECX, WM_MOUSEMOVE - JE @@Url_event - //LEA EAX, [EBX].TControl.EV.fOnREUrlClick - ADD EAX, 8 - CMP ECX, WM_LBUTTONDOWN - JE @@Url_Event - CMP ECX, WM_RBUTTONDOWN - JNE @@after_Url_event -@@Url_event: - MOV ECX, [EAX].TMethod.Code - {$IFDEF NIL_EVENTS} - JECXZ @@after_Url_event - {$ENDIF} - MOV EDX, EBX - MOV EAX, [EAX].TMethod.Data - CALL ECX -@@after_Url_event: - POP EBX - MOV AL, 1 - RET -@@ret_false: - XOR EAX, EAX -end; -*) {$ENDIF NOT_USE_RICHEDIT} function OleInit: Boolean; @@ -5399,12 +4681,6 @@ asm //cmd //opd {$ENDIF} {$ENDIF NEW_EVENTS_MODEL} - {$IFDEF COMMANDACTIONS_OBJ} //--- moved to _NewWindowed - //---- MOV EDX, [EBX].fCommandActions - //---- MOV [EDX].TCommandActionsObj.aClear, offset[ClearText] - {$ELSE} - //---- MOV [EBX].fCommandActions.aClear, offset[ClearText] - {$ENDIF} {$IFDEF USE_FLAGS} {$ELSE} INC [EBX].fWindowed @@ -5419,10 +4695,8 @@ asm //cmd //opd MOV byte ptr [EBX].fMargin, 2 OR dword ptr [EBX].fCtl3D_child, 3 - {$IFDEF SMALLEST_CODE} - {$ELSE} DEC byte ptr [EBX].fAlphaBlend // has no effect until AlphaBlend changed - {$ENDIF} + MOV byte ptr[EBX].fClsStyle, CS_OWNDC MOV [EBX].fStyle, IniStyle INC dword ptr[EBX].fExStyle+2 @@ -5496,11 +4770,6 @@ asm MOV EAX, EBX CALL Final - {$IFDEF USE_AUTOFREE4CHILDREN} - {$ELSE} - MOV EAX, EBX - CALL DestroyChildren - {$ENDIF} {$IFDEF USE_FLAGS} BTS DWORD PTR [EBX].fFlagsG2, G2_Destroying @@ -5512,24 +4781,9 @@ asm INC [EBX].fDestroying {$ENDIF USE_FLAGS} - {$IFDEF USE_AUTOFREE4CONTROLS} XOR EAX, EAX XCHG EAX, [EBX].fCanvas CALL TObj.RefDec - {$ELSE} - PUSH EBX - LEA ESI, [EBX].fFont - MOV BL, 3 -@@free_font_brush_canvas: - XOR ECX, ECX - XCHG ECX, [ESI] - LODSD - XCHG EAX, ECX - CALL TObj.RefDec - DEC BL - JNZ @@free_font_brush_canvas - POP EBX - {$ENDIF} MOV EAX, [EBX].fCustomObj CALL TObj.RefDec @@ -5538,27 +4792,6 @@ asm TEST EAX, EAX JZ @@free_fields - {$IFNDEF USE_AUTOFREE4CONTROLS} - {$IFNDEF NEW_MENU_ACCELL} - XOR ECX, ECX - XCHG ECX, [EBX].fAccelTable - JECXZ @@accelTable_destroyed - PUSH ECX - CALL DestroyAcceleratorTable -@@accelTable_destroyed: - {$ENDIF} - MOV EAX, [EBX].fMenuObj - CALL TObj.RefDec -@@destroy_img_list: - XOR EAX, EAX - XCHG EAX, [EBX].fImageList - TEST EAX, EAX - JZ @@img_list_destroyed - CALL TObj.RefDec - JMP @@destroy_img_list -@@img_list_destroyed: - {$ENDIF} - MOV ECX, [EBX].DF.fIcon JECXZ @@icoremoved INC ECX @@ -5579,18 +4812,6 @@ asm CALL IsWindow TEST EAX, EAX JZ @@destroy2 - (* -- moved to WM_NCDESTROY handler - VK + Alexey Kirov - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] //* Remarked By M.Gerasimov - PUSH [EBX].fHandle //* unremarked to prevent problems with progress bar - CALL RemoveProp - {$ELSE} - PUSH 0 - PUSH GWL_USERDATA - PUSH [EBX].fHandle - CALL SetWindowLong - {$ENDIF} - *) {$IFDEF USE_fNCDestroyed} CMP [EBX].fNCDestroyed, 0 JNZ @@destroy2 @@ -5638,36 +4859,20 @@ asm XOR EAX, EAX MOV [ECX].DF.fCurrentControl, EAX @@removefromParent: - {$IFDEF USE_AUTOFREE4CHILDREN} PUSH ECX - {$ENDIF} MOV EAX, [ECX].fChildren MOV EDX, EBX CALL TList.Remove - {$IFDEF USE_AUTOFREE4CHILDREN} POP EAX MOV EDX, EBX CALL TControl.RemoveFromAutoFree - {$ENDIF} @@removed_from_parent: - {$IFDEF USE_AUTOFREE4CONTROLS} LEA ESI, [EBX].fDynHandlers LODSD CALL TObj.RefDec LODSD // fChildren CALL TObj.RefDec - {$ELSE} - PUSH EBX - LEA ESI, [EBX].fDynHandlers - MOV BL, 5 -@@freeloo: - LODSD - CALL TObj.RefDec - DEC BL - JNZ @@freeloo - POP EBX - {$ENDIF} LEA EAX, [EBX].fCaption {$IFDEF UNICODE_CTRLS} @@ -5722,25 +4927,6 @@ asm POP EBX end; -{function TControl.GetParentWindow: HWnd; -asm - MOV ECX, [EAX].fHandle - JECXZ @@1 - PUSH EAX - PUSH GW_OWNER - PUSH EAX - CALL GetWindow - POP ECX - TEST EAX, EAX - JZ @@0 - RET -@@0: XCHG EAX, ECX -@@1: - MOV EAX, [EAX].fParent - TEST EAX, EAX - JNZ TControl.GetWindowHandle -end;} - function WndProcMouse(Self_: PControl; var Msg: TMsg; var Rslt: LRESULT): Boolean; asm PUSH EBX @@ -5900,16 +5086,12 @@ asm //cmd //opd JMP @@calldef //********************************************************** Added By M.Gerasimov @@chk_WM_DESTROY: - {$IFnDEF SMALLER_CODE} MOV EDX, [EDI].TMsg.hWnd - {$ENDIF SMALLER_CODE} CMP AX, WM_DESTROY JNE @@chk_WM_NCDESTROY - {$IFnDEF SMALLER_CODE} CMP EDX, [ESI].TControl.fHandle JNE @@chk_WM_NCDESTROY - {$ENDIF SMALLER_CODE} {$IFDEF USE_FLAGS} OR [ESI].TControl.fFlagsG2, (1 shl G2_BeginDestroying) @@ -5922,21 +5104,14 @@ asm //cmd //opd CMP AX, WM_NCDESTROY JNE @@chk_WM_SIZE // @@chk_CM_RELEASE //********************************************************** Added By M.Gerasimov - {$IFnDEF SMALLER_CODE} CMP EDX, [ESI].TControl.fHandle JNE @@chk_WM_SIZE - {$ENDIF SMALLER_CODE} - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] - PUSH [ESI].fHandle - CALL RemoveProp - {$ELSE} PUSH 0 PUSH GWL_USERDATA PUSH [ESI].fHandle CALL SetWindowLong - {$ENDIF} + JMP @@calldef //********************************************************** @@return0: @@ -5981,17 +5156,6 @@ asm //cmd //opd CALL TControl.CallDefWndProc PUSH EAX - {$IFDEF OLD_ALIGN} - {$IFDEF USE_FLAGS} - TEST [ESI].TControl.fFlagsG3, (1 shl G3_IsForm) - {$ELSE} - CMP [ESI].TControl.fIsForm, 0 - {$ENDIF} - JNZ @@doGlobalAlignSelf - MOV EAX, [ESI].TControl.fParent - CALL dword ptr [Global_Align] -@@doGlobalAlignSelf: - {$ENDIF} MOV EAX, ESI CALL dword ptr [Global_Align] JMP @@popeax_exit // fPass2DefProc not needed, CallDefWndProc already called @@ -6062,15 +5226,10 @@ asm //cmd //opd CMP AX, WM_COMMAND JNE @@chk_WM_KEY - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] - PUSH [EDI].TMsg.lParam - CALL GetProp - {$ELSE} PUSH GWL_USERDATA PUSH [EDI].TMsg.lParam CALL GetWindowLong - {$ENDIF} + TEST EAX, EAX JZ @@calldef @@ -6371,14 +5530,10 @@ asm PUSH EDX MOV ECX, [EBX].fMenuObj JECXZ @@no_free_menuctl - {$IFDEF USE_AUTOFREE4CONTROLS} PUSH EDX MOV EAX, EBX CALL TControl.RemoveFromAutoFree POP EAX - {$ELSE} - XCHG EAX, EDX - {$ENDIF} CALL TObj.RefDec @@no_free_menuctl: MOV ECX, [EBX].fMenu @@ -6511,73 +5666,6 @@ end; procedure TControl.Set_Visible( Value: Boolean ); const wsVisible = $10; asm - {$IFDEF OLD_ALIGN} - PUSH EBX - PUSH ESI - //MOV ESI, EAX - XCHG ESI, EAX - MOVZX EBX, DL - {CALL Get_Visible - CMP AL, BL - JE @@reset_fCreateHidden} - - MOV AL, byte ptr [ESI].fStyle + 3 - TEST EBX, EBX - JZ @@reset_WS_VISIBLE - {$IFDEF USE_FLAGS} - OR AL, 1 shl F3_Visible - {$ELSE} - OR AL, wsVisible - {$ENDIF} - PUSH SW_SHOW - JMP @@store_Visible -@@reset_WS_VISIBLE: - {$IFDEF USE_FLAGS} - AND AL, not(1 shl F3_Visible) - {$ELSE} - AND AL, not wsVisible - {$ENDIF} - PUSH SW_HIDE - -@@store_Visible: - MOV byte ptr [ESI].fStyle + 3, AL - {$IFDEF USE_FLAGS} - {$ELSE} - MOV [ESI].fVisible, BL - {$ENDIF} - MOV ECX, [ESI].fHandle - JECXZ @@after_showwindow - - PUSH ECX - CALL ShowWindow - PUSH ECX -@@after_showwindow: - POP ECX - - MOV EAX, [ESI].fParent - CALL dword ptr [Global_Align] - -@@chk_align_Self: - TEST EBX, EBX - JZ @@reset_fCreateHidden - MOV EAX, ESI - CALL dword ptr [Global_Align] - - -@@reset_fCreateHidden: - MOV ECX, [ESI].fHandle - JECXZ @@exit - TEST BL, BL - JNZ @@exit - {$IFDEF USE_FLAGS} - AND [ESI], not(1 shl G4_CreateHidden) - {$ELSE} - MOV [ESI].fCreateHidden, BL { +++ } - {$ENDIF} -@@exit: - POP ESI - POP EBX - {$ELSE NEW_ALIGN} AND byte ptr [EAX].fStyle.f3_Style, not(1 shl F3_Visible) TEST DL,DL JZ @@0 @@ -6609,7 +5697,6 @@ asm CALL ShowWindow POP EAX CALL dword ptr [Global_Align] - {$ENDIF} end; procedure TControl.SetVisible( Value: Boolean ); @@ -7005,24 +6092,15 @@ asm JMP @@store_fIcon @@main_icon: - {$IFDEF NUMERIC_APPICON} {$DEFINE CUSTOM_APPICON} {$ENDIF} - {$IFDEF CUSTOM_APPICON} - {$I CustomAppIconRsrcName_ASM.inc} // create such file with DB 'your icon rsrc name' / DD youriconnumber - {$ELSE} {$IFDEF UNICODE_CTRLS} DB 'M',0,'A',0,'I',0,'N',0,'I',0,'C',0,'O',0,'N',0,0,0 //dmiko {$ELSE} DB 'MAINICON' {$ENDIF} - {$ENDIF} DB 0 @@load: - {$IFDEF NUMERIC_APPICON} - PUSH DWORD [@@main_icon] - {$ELSE} PUSH offset @@main_icon - {$ENDIF} PUSH [hInstance] CALL LoadIcon @@store_fIcon: @@ -7163,21 +6241,17 @@ asm CALL TList.Remove POP EAX - {$IFNDEF USE_AUTOFREE4CONTROL} PUSH EAX MOV EDX, EBX CALL TObj.RemoveFromAutoFree POP EAX - {$ENDIF} - {$IFNDEF SMALLEST_CODE} MOV ECX, [EAX].PP.fNotifyChild {$IFDEF NIL_EVENTS} JECXZ @@1 {$ENDIF} XOR EDX, EDX CALL ECX - {$ENDIF} @@1: MOV [EBX].fParent, EDI TEST EDI, EDI @@ -7187,11 +6261,9 @@ asm MOV EDX, EBX CALL TList.Add - {$IFDEF USE_AUTOFREE4CHILDREN} MOV EAX, EDI MOV EDX, EBX CALL TControl.Add2AutoFree - {$ENDIF} {$IFNDEF INPACKAGE} MOV ECX, [EBX].fHandle @@ -7204,10 +6276,9 @@ asm @@2: {$ENDIF} - {$IFNDEF SMALLEST_CODE} MOV ECX, [EDI].PP.fNotifyChild {$IFDEF NIL_EVENTS} - JECXZ @@3 + JECXZ @@3 {$ENDIF} MOV EAX, EDI MOV EDX, EBX @@ -7215,12 +6286,12 @@ asm @@3: MOV ECX, [EBX].PP.fNotifyChild {$IFDEF NIL_EVENTS} - JECXZ @@4 + JECXZ @@4 {$ENDIF} MOV EAX, EDI MOV EDX, EBX CALL ECX -@@4: {$ENDIF} +@@4: {$IFNDEF USE_GRAPHCTLS} XCHG EAX, EBX @@ -7456,12 +6527,9 @@ asm JECXZ @@1 - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EBX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aSetBkColor - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aSetBkColor - {$ENDIF} + JECXZ @@1 PUSH EDX @@ -7554,10 +6622,8 @@ asm CMP WORD PTR [ESP].TMsg.message, WM_QUIT JNE @@tran_disp OR [AppletTerminated], DL - {$IFDEF PROVIDE_EXITCODE} MOV EDX, [ESP].TMsg.wParam MOV [ExitCode], EDX - {$ENDIF PROVIDE_EXITCODE} JMP @@fin @@tran_disp: @@ -7891,12 +6957,10 @@ asm //cmd //opd PUSH ECX MOVZX ECX, word ptr [EDI].TMsg.wParam+2 - {$IFDEF COMMANDACTIONS_OBJ} + MOV ESI, [EBX].TControl.fCommandActions CMP CX, [ESI].TCommandActionsObj.aClick - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aClick - {$ENDIF} + JNE @@chk_aEnter CMP [EBX].TControl.fClickDisabled, 0 @@ -7909,12 +6973,10 @@ asm //cmd //opd JMP @@calldef @@chk_aEnter: - {$IFDEF COMMANDACTIONS_OBJ} + MOV EAX, [EBX].TControl.fCommandActions CMP CX, [EAX].TCommandActionsObj.aEnter - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aEnter - {$ENDIF} + {$IFDEF EVENTS_DYNAMIC} MOV EAX, [EBX].TControl.EV LEA EAX, [EAX].TEvents.fOnEnter @@ -7924,19 +6986,15 @@ asm //cmd //opd JE @@goEvent //LEA EAX, [EBX].TControl.EV.fOnLeave ADD EAX, 8 - {$IFDEF COMMANDACTIONS_OBJ} + CMP CX, [ESI].TCommandActionsObj.aLeave - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aLeave - {$ENDIF} + JE @@goEvent //LEA EAX, [EBX].TControl.EV.fOnChangeCtl SUB EAX, 16 - {$IFDEF COMMANDACTIONS_OBJ} + CMP CX, [ESI].TCommandActionsObj.aChange - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aChange - {$ENDIF} + JNE @@chk_aSelChange @@goEvent: MOV ECX, [EAX].TMethod.Code @@ -7950,11 +7008,9 @@ asm //cmd //opd JMP @@calldef @@chk_aSelChange: - {$IFDEF COMMANDACTIONS_OBJ} + CMP CX, [ESI].TCommandActionsObj.aSelChange - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aSelChange - {$ENDIF} + JNE @@chk_WM_SETFOCUS_1 MOV EAX, EBX CALL TControl.DoSelChange @@ -8177,14 +7233,12 @@ asm LOOP @@exit PUSH EAX CALL NewFont - {$IFDEF USE_AUTOFREE4CONTROLS} POP EDX PUSH EDX PUSH EAX XCHG eax, edx CALL TObj.Add2AutoFree POP EAX - {$ENDIF} POP EDX MOV [EDX].FFont, EAX MOV ECX, [EDX].fTextColor @@ -8208,12 +7262,10 @@ asm MOV [EAX].TGraphicTool.fData.Color, ECX MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Code, offset[BrushChanged] MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Data, EDX - {$IFDEF USE_AUTOFREE4CONTROLS} PUSH EAX XCHG EAX, EDX CALL TControl.Add2AutoFree POP ECX - {$ENDIF} @@exit: XCHG EAX, ECX end; @@ -8787,12 +7839,9 @@ end; function TControl.GetSelStart: Integer; asm - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aGetSelRange - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aGetSelRange - {$ENDIF} + JECXZ @@exit XOR EDX, EDX PUSH EDX // space for Result @@ -8810,12 +7859,10 @@ end; function TControl.GetSelLength: Integer; asm XOR EDX, EDX - {$IFDEF COMMANDACTIONS_OBJ} + MOV ECX, [EAX].fCommandActions MOVZX ECX, word ptr[ECX].TCommandActionsObj.aGetSelCount - {$ELSE} - MOVZX ECX, word ptr[EAX].fCommandActions.aGetSelCount - {$ENDIF} + JECXZ @@ret_ecx CMP CX, EM_GETSEL @@ -8856,23 +7903,19 @@ asm POP EDX ADD ECX, EAX PUSH ECX - {$IFDEF COMMANDACTIONS_OBJ} + MOV ECX, [EDX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aSetSelRange - {$ELSE} - MOVZX ECX, [EDX].fCommandActions.aSetSelRange - {$ENDIF} + JECXZ @@check_ex PUSH EAX JMP @@perform @@check_ex: - {$IFDEF COMMANDACTIONS_OBJ} + MOV ECX, [EDX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aExSetSelRange - {$ELSE} - MOVZX ECX, [EDX].fCommandActions.aExSetSelRange - {$ENDIF} + JECXZ @@exit PUSH EAX PUSH ESP @@ -8888,12 +7931,8 @@ end; function TControl.GetItemsCount: Integer; asm PUSH 0 - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aGetCount - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aGetCount - {$ENDIF} JECXZ @@ret_0 PUSH 0 PUSH ECX @@ -8924,34 +7963,22 @@ end; function TControl.Item2Pos(ItemIdx: Integer): DWORD; asm - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.bItem2Pos - {$ELSE} - MOVZX ECX, BYTE PTR [EAX].fCommandActions.bItem2Pos - {$ENDIF} JMP HelpConvertItem2Pos end; function TControl.Pos2Item(Pos: Integer): DWORD; asm - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.bPos2Item - {$ELSE} - MOVZX ECX, BYTE PTR [EAX].fCommandActions.bPos2Item - {$ENDIF} JMP HelpConvertItem2Pos end; procedure TControl.Delete(Idx: Integer); asm - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aDeleteItem - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aDeleteItem - {$ENDIF} JECXZ @@exit PUSH 0 @@ -8964,12 +7991,8 @@ end; function TControl.GetItemSelected(ItemIdx: Integer): Boolean; asm - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aGetSelected - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aGetSelected - {$ENDIF} JECXZ @@check_range PUSH 1 @@ -9011,12 +8034,8 @@ procedure TControl.SetItemSelected(ItemIdx: Integer; const Value: Boolean); asm PUSH EDX PUSH ECX - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aSetSelected - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aSetSelected - {$ENDIF} JECXZ @@chk_aSetCurrent @@0: @@ -9027,12 +8046,8 @@ asm @@chk_aSetCurrent: POP ECX - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aSetCurrent - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aSetCurrent - {$ENDIF} JECXZ @@chk_aSetSelRange POP EDX @@ -9040,12 +8055,8 @@ asm JMP @@3 @@chk_aSetSelRange: - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aSetSelRange - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aSetSelRange - {$ENDIF} JECXZ @@chk_aExSetSelRange @@3: PUSH EDX @@ -9056,12 +8067,8 @@ asm JMP @@exit @@chk_aExSetSelRange: - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aExSetSelRange - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aExSetSelRange - {$ENDIF} JECXZ @@else PUSH EDX @@ -9217,12 +8224,8 @@ asm PUSH EBX XCHG EBX, EAX MOV EAX, [EBX].fCurIndex - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EBX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aGetCurrent - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aGetCurrent - {$ENDIF} JECXZ @@exit XOR EAX, EAX CDQ @@ -9246,45 +8249,10 @@ asm @@exit: POP EBX end; -{procedure TControl.SetCurIndex(const Value: Integer); -asm - MOVZX ECX, [EAX].fCommandActions.aSetCurrent - JECXZ @@set_item_sel - PUSHAD - PUSH 0 - PUSH EDX - PUSH ECX - PUSH EAX - CALL Perform - POPAD - CMP CX, TCM_SETCURSEL - JNE @@exit - PUSH TCN_SELCHANGE - PUSH EAX // idfrom doesn't matter - PUSH [EAX].fHandle - PUSH ESP - PUSH 0 - PUSH WM_NOTIFY - PUSH EAX - CALL Perform - POP ECX - POP ECX - POP ECX -@@exit: - RET -@@set_item_sel: - INC ECX - CALL SetItemSelected -end;} - procedure TControl.SetCurIndex(const Value: Integer); // fix av asm - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aSetCurrent - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aSetCurrent - {$ENDIF} JECXZ @@set_item_sel PUSH ECX //+aSetCurrent PUSH EAX //+self @@ -9319,12 +8287,8 @@ asm PUSH EAX CALL UpdateWndStyles MOV ECX, [EAX].fStyle - {$IFDEF COMMANDACTIONS_OBJ} MOV EDX, [EAX].fCommandActions MOV EDX, dword ptr [EDX].TCommandActionsObj.aTextAlignRight - {$ELSE} - MOV EDX, dword ptr [EAX].fCommandActions.aTextAlignRight - {$ENDIF} XOR EAX, EAX AND DX, CX JNZ @@ret_1 @@ -9342,51 +8306,32 @@ end; procedure TControl.SetTextAlign(const Value: TTextAlign); asm - {$IFDEF COMMANDACTIONS_OBJ} PUSH EBX - {$ENDIF} MOV [EAX].fTextAlign, DL XOR ECX, ECX - {$IFDEF COMMANDACTIONS_OBJ} MOV EBX, [EAX].fCommandActions MOV CX, [EBX].TCommandActionsObj.aTextAlignLeft OR CX, [EBX].TCommandActionsObj.aTextAlignCenter OR CX, [EBX].TCommandActionsObj.aTextAlignRight - {$ELSE} - MOV CX, [EAX].fCommandActions.aTextAlignLeft - OR CX, [EAX].fCommandActions.aTextAlignCenter - OR CX, [EAX].fCommandActions.aTextAlignRight - {$ENDIF} NOT ECX AND ECX, [EAX].fStyle AND EDX, 3 - {$IFDEF COMMANDACTIONS_OBJ} OR CX, [EBX + EDX * 2].TCommandActionsObj.aTextAlignLeft MOV DL, BYTE PTR [EBX].TCommandActionsObj.bTextAlignMask - {$ELSE} - OR CX, [EAX + EDX * 2].fCommandActions.aTextAlignLeft - MOV DL, BYTE PTR [EAX].fCommandActions.bTextAlignMask - {$ENDIF} NOT EDX AND EDX, ECX CALL SetStyle - {$IFDEF COMMANDACTIONS_OBJ} POP EBX - {$ENDIF} end; function TControl.GetVerticalAlign: TVerticalAlign; asm PUSH EAX CALL UpdateWndStyles - {$IFDEF COMMANDACTIONS_OBJ} MOV EDX, [EAX].fCommandActions MOV EDX, dword ptr [EDX].TCommandActionsObj.bVertAlignCenter - {$ELSE} - MOV EDX, dword ptr [EAX].fCommandActions.bVertAlignCenter - {$ENDIF} MOV ECX, [EAX].fStyle XOR EAX, EAX MOV DH, DL @@ -9413,12 +8358,8 @@ asm MOVZX EDX, DL MOV [EAX].fVerticalAlign, DL - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, byte ptr [ECX+EDX].TCommandActionsObj.bVertAlignTop - {$ELSE} - MOVZX ECX, byte ptr [EAX+EDX].fCommandActions.bVertAlignTop - {$ENDIF} SHL ECX, 8 MOV EDX, [EAX].fStyle @@ -9459,12 +8400,8 @@ function TControl.GetCanvas: PCanvas; asm PUSH EBX PUSH ESI - {$IFDEF SAFE_CODE} MOV EBX, EAX CALL CreateWindow - {$ELSE} - XCHG EBX, EAX - {$ENDIF} MOV ESI, [EBX].fCanvas TEST ESI, ESI @@ -9517,10 +8454,9 @@ asm {$ENDIF} MOV EDX, offset[WndProcTransparent] CALL TControl.AttachProc - {$IFnDEF SMALLEST_CODE} + LEA EAX, [TransparentAttachProcExtension] MOV [Global_AttachProcExtension], EAX - {$ENDIF} @@exit: end; @@ -9563,6 +8499,7 @@ function _NewTrayIcon: PTrayIcon; begin New(Result,Create); end; + function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon; asm PUSH EBX @@ -9878,40 +8815,6 @@ asm POP EBX end; -(* bugged -procedure TStrList.MergeFromFile(const FileName: KOLString); -asm - PUSH EAX - XCHG EAX, EDX - CALL NewReadFileStream - XCHG EDX, EAX - POP EAX - MOV CL, 1 - PUSH EDX - CALL LoadFromStream - POP EAX - JMP TObj.RefDec -end; - -procedure TStrList.SaveToStream(Stream: PStream); -asm - PUSH EDX - PUSH 0 - MOV EDX, ESP - CALL GetTextStr - POP EAX - PUSH EAX - CALL System.@LStrLen - XCHG ECX, EAX - POP EDX - POP EAX - PUSH EDX - JECXZ @@1 - CALL TStream.Write -@@1: - CALL RemoveStr -end;*) - procedure LowerCaseStrFromPCharEDX; asm { <- EDX = PChar string @@ -9932,47 +8835,6 @@ asm JMP LowerCase end; -procedure TStrList.Sort(CaseSensitive: Boolean); -asm - MOV [EAX].fCaseSensitiveSort, DL - MOV [EAX].fAnsiSort, 0 - {$IFDEF SPEED_FASTER} - {$DEFINE SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF TLIST_FAST} - {$UNDEF SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF SORT_STRLIST_ARRAY} - MOV ECX, offset[StrComp] - CMP DL, 0 - JNZ @@01 - {$IFDEF SMALLER_CODE} - MOV ECX, offset[StrComp_NoCase] - {$ELSE} - MOV ECX, [StrComp_NoCase] - {$ENDIF} -@@01: - MOV EAX, [EAX].fList - TEST EAX, EAX - JZ @@exit - MOV EDX, [EAX].TList.fCount - CMP EDX, 1 - JLE @@02 - MOV EAX, [EAX].TList.fItems - CALL SortArray -@@02: - {$ELSE} - PUSH Offset[TStrList.Swap] - MOV ECX, Offset[CompareStrListItems_Case] - CMP DL, 0 - JNZ @1 - MOV ECX, Offset[CompareStrListItems_NoCase] -@1: MOV EDX, [EAX].fCount - CALL SortData - {$ENDIF} -@@exit: -end; - procedure SortData( const Data: Pointer; const uNElem: Dword; const CompareFun: TCompareEvent; const SwapProc: TSwapEvent ); @@ -10169,8 +9031,7 @@ asm end; -procedure SortArray( const Data: Pointer; const uNElem: Dword; - const CompareFun: TCompareArrayEvent ); +procedure SortArray(const Data: Pointer; const uNElem: Dword; const CompareFun: TCompareArrayEvent); asm PUSH EBP MOV EBP, ESP @@ -10532,11 +9393,7 @@ function _NewStatusbar( AParent: PControl ): PControl; const STAT_CLS_NAM: PKOLChar = STATUSCLASSNAME; asm PUSH 0 - {$IFDEF COMMANDACTIONS_OBJ} PUSH OTHER_ACTIONS - {$ELSE} - PUSH 0 - {$ENDIF} {$IFDEF USE_FLAGS} TEST [EAX].TControl.fFlagsG3, (1 shl G3_SizeGrip) {$ELSE} @@ -10685,13 +9542,11 @@ asm CMP [ECX].TControl.fImageList, EAX JNZ @@fin MOV [ECX].TControl.fImageList, EDX - {$IFDEF USE_AUTOFREE4CONTROLS} PUSH EAX XCHG EAX, ECX MOV EDX, ECX CALL TControl.RemoveFromAutoFree POP EAX - {$ENDIF} @@fin: CALL TObj.Destroy end; @@ -10847,8 +9702,7 @@ asm //cmd //opd end; {$IFNDEF NEW_OPEN_DIR_STYLE_EX} -function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer; - stdcall; +function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer; stdcall; asm MOV EAX, [Wnd] MOV EDX, [lpData] @@ -10988,8 +9842,7 @@ end; // TODO: testcase //{$IFDEF ASM_UNICODE} -procedure TControl.TBSetTooltips(BtnID1st: Integer; - const Tooltips: array of PKOLChar); +procedure TControl.TBSetTooltips(BtnID1st: Integer; const Tooltips: array of PKOLChar); asm PUSH EBX PUSH ESI @@ -11001,22 +9854,18 @@ asm LOOP @@1 CALL NewList MOV [EBX].DF.fTBttCmd, EAX - {$IFDEF USE_AUTOFREE4CONTROLS} XCHG EDX, EAX MOV EAX, EBX CALL TControl.Add2AutoFree - {$ENDIF} {$IFDEF UNICODE_CTRLS} CALL NewWStrList {$ELSE} CALL NewStrList {$ENDIF} MOV [EBX].DF.fTBttTxt, EAX - {$IFDEF USE_AUTOFREE4CONTROLS} XCHG EDX, EAX MOV EAX, EBX CALL TControl.Add2AutoFree - {$ENDIF} @@1: POPAD MOV ECX, [EBP+8] INC ECX @@ -11121,13 +9970,7 @@ asm ADD ESP, 16 POP ECX TEST AL, AL - {$IFDEF USE_CMOV} CMOVNZ EAX, ECX - {$ELSE} - JZ @@2 - MOV EAX, ECX - JMP @@fin -@@2: {$ENDIF} JNZ @@fin LOOP @@1 @@ -11205,12 +10048,8 @@ asm CALL EDX2PChar PUSH EDX PUSH ECX - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aDir - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aDir - {$ENDIF} JECXZ @@exit PUSH ECX PUSH EAX @@ -11221,29 +10060,7 @@ asm POP ECX end; -{$IFDEF noASM_VERSION} -function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - CMP word ptr [EDX].TMsg.message, WM_CLOSE - JNZ @@ret_false - - XCHG EDX, EAX - XOR EAX, EAX - CMP [EDX].TControl.fModalResult, EAX - JNZ @@1 - OR [EDX].TControl.fModalResult, -1 -@@1: - MOV [ECX], EAX - INC EAX - RET -@@ret_false: - XOR EAX, EAX - -end; -{$ENDIF} - -procedure TimerProc( Wnd : HWnd; Msg : DWORD; T : PTimer; CurrentTime : DWord ); - stdcall; +procedure TimerProc( Wnd : HWnd; Msg : DWORD; T : PTimer; CurrentTime : DWord ); stdcall; asm //cmd //opd {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED} CMP [AppletTerminated], 0 @@ -11402,6 +10219,7 @@ begin Result.fWidth := W; Result.fHeight := H; end; + function NewBitmap( W, H: Integer ): PBitmap; asm PUSH EAX @@ -11575,12 +10393,7 @@ asm // [EBP+8] = Y CALL GetObject TEST EAX, EAX MOV ESI, [ESP].tagBitmap.bmHeight - {$IFDEF USE_CMOV} CMOVZ ESI, [EBX].fHeight - {$ELSE} - JNZ @@1 - MOV ESI, [EBX].fHeight -@@1: {$ENDIF} ADD ESP, szBitmap CALL StartDC @@ -12032,8 +10845,7 @@ asm CALL TObj.RefDec end; -function MoveTetrades(Mem, From:PByte; Size: Integer;incFrom, - xx: Integer): Integer; +function MoveTetrades(Mem, From:PByte; Size: Integer;incFrom, xx: Integer): Integer; asm PUSH EBX MOV EBX, ECX @@ -12056,9 +10868,7 @@ asm @@3: TEST BYTE PTR [xx], 1 //[EBP+8], 1 JZ @@4 - {$IFNDEF SMALLER_CODE} AND byte ptr [EAX], $F0 - {$ENDIF} OR byte ptr [EAX], BL INC EAX JMP @@5 @@ -12073,8 +10883,7 @@ asm POP EBX end; -function MoveRLEdata(Mem, From:PByte;Size: Integer;incFrom, - xx: Integer): Integer; +function MoveRLEdata(Mem, From:PByte;Size: Integer;incFrom, xx: Integer): Integer; asm PUSH EBX MOV EBX, ECX @@ -12092,8 +10901,7 @@ asm POP EBX end; -procedure DecodeRLE(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD; - MoveDataFun: TMoveData; shr_x: Integer); +procedure DecodeRLE(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD; MoveDataFun: TMoveData; shr_x: Integer); asm PUSHAD MOV ESI, EAX @@ -12568,12 +11376,7 @@ asm PUSH EAX MOV EAX, [EBX].fHeight CMP EAX, EDI - {$IFDEF USE_CMOV} CMOVG EAX, EDI - {$ELSE} - JLE @@3 - MOV EAX, EDI -@@3: {$ENDIF} PUSH EAX PUSH 0 @@ -12585,12 +11388,7 @@ asm MOV EDX, [EBX].fHeight CMP EDX, EDI - {$IFDEF USE_CMOV} CMOVG EDX, EDI - {$ELSE} - JLE @@30 - MOV EDX, EDI -@@30: {$ENDIF} CMP EAX, EDX JE @@2clearData @@ -14522,10 +13320,10 @@ asm PUSH EBX POP EDX PUSH EDX CALL TList.Add -@@exit: {$IFNDEF SMALLEST_CODE} +@@exit: MOV EAX, [EBX].fDynHandlers CALL [Global_AttachProcExtension] - {$ENDIF} + POP ECX POP EDI POP EBX @@ -14539,136 +13337,6 @@ asm //cmd //opd SETGE AL end; -{$IFDEF nASM_VERSION} -function WndProcAutoPopupMenu( Control: PControl; var Msg: TMsg; var MsgRslt: Integer ): Boolean; -asm - CMP WORD PTR[EDX].TMsg.message, WM_CONTEXTMENU - JNZ @@ret_0 - CMP DWORD PTR[EAX].TControl.fAutoPopupMenu, 0 - JZ @@ret_0 - PUSH ESI - PUSH EDI - PUSH EBX - XCHG ESI, EAX // ESI = Control - MOV EDI, EDX - - MOVSX EAX, WORD PTR[EDX].TMsg.lParam+2 - PUSH EAX // P.Y - MOVSX EAX, WORD PTR[EDX].TMsg.lParam - PUSH EAX // P.X - - CMP DWORD PTR[EDX].TMsg.lParam, -1 - JNZ @@auto_popup - - MOV EAX, ESI - CALL TControl.GetCurIndex - CMP EAX, 0 - JL @@coords_2screen - // EAX = I - - MOVZX EBX, WORD PTR[ESI].TControl.fCommandActions.aItem2XY - CMP EBX, 0 - JZ @@coords_2screen - - CMP BX, EM_POSFROMCHAR - JNZ @@chk_LB_LV_TC - - PUSH 1 - MOV EAX, ESI - CALL TControl.GetSelStart - PUSH EAX - MOV EAX, ESI - CALL TControl.GetSelLength - ADD DWORD PTR[ESP], EAX - PUSH EBX - PUSH ESI - CALL TControl.Perform - MOVSX EBX, AX - SHR EAX, 16 - MOVSX EAX, AX - POP ECX - POP ECX - PUSH EAX - PUSH EBX - JMP @@check_bounds - -@@chk_LB_LV_TC: - CMP BX, LB_GETITEMRECT - JZ @@LB_LV_TC - CMP BX, LVM_GETITEMRECT - JZ @@LB_LV_TC - CMP BX, TCM_GETITEMRECT - JNZ @@chk_TVM -@@LB_LV_TC: // EAX = I - PUSH ECX - PUSH LVIR_BOUNDS - PUSH ESP // @R - PUSH EAX // I - JMP @@get_2 - -@@chk_TVM: - CMP BX, TVM_GETITEMRECT - JNZ @@check_bounds - - MOV EDX, TVGN_CARET - MOV EAX, ESI - CALL TControl.TVGetItemIdx - PUSH ECX - PUSH EAX - PUSH ESP // @R - PUSH 1 // 1 -@@get_2: - PUSH EBX // M - PUSH ESI // Control - CALL TControl.Perform - POP EAX - POP ECX - POP ECX - PUSH EAX - -@@check_bounds: - POP EBX // P.X - POP EDI // P.Y - SUB ESP, 16 - MOV EDX, ESP - MOV EAX, ESI - CALL TControl.ClientRect - - POP EAX // R.Left == 0 - POP EAX // R.Top == 0 - POP EAX // R.Right - CMP EBX, EAX - JLE @@1 - XCHG EBX, EAX -@@1:POP EAX // R.Bottom - CMP EDI, EAX - JLE @@2 - XCHG EDI, EAX -@@2:PUSH EDI // P.Y - PUSH EBX // P.X - -@@coords_2screen: - MOV EDX, ESP - MOV EAX, ESI - MOV ECX, EDX - CALL TControl.Client2Screen - -@@auto_popup: - POP EDX // P.X - POP ECX // P.Y - MOV EAX, [ESI].TControl.fAutoPopupMenu - CALL TMenu.Popup - - POP EBX - POP EDI - POP ESI - OR EAX, -1 - RET -@@ret_0: - XOR EAX, EAX -end; -{$ENDIF nASM_VERSION} - function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: LRESULT ): Boolean; asm PUSH ESI @@ -14851,14 +13519,6 @@ asm JZ @@retDL MOV ECX, [EAX].TControl.fParent JECXZ @@retDL - - {$IFDEF OLD_ALIGN} - TEST [EAX].TControl.fFlagsG4, 1 shl G4_VisibleWOParent - JZ @@1 - MOV DL, DH - JMP @@retDL - {$ENDIF} - {$ELSE not USE_FLAGS} MOV DH, [EAX].TControl.fVisible MOV DL, [EAX].TControl.fCreateHidden @@ -14868,16 +13528,7 @@ asm JZ @@retDL MOV ECX, [EAX].TControl.fParent JECXZ @@retDL - - {$IFDEF OLD_ALIGN} - CMP [EAX].TControl.fVisibleWoParent, 0 - JZ @@1 - MOV DL, DH - JMP @@retDL - {$ENDIF} - {$ENDIF} - @@1: TEST DL, DL JZ @@retDL @@ -14891,61 +13542,6 @@ asm XCHG EAX, EDX end; -//dufa -//// by MTsv DN - v2.90 -- chg by VK -//function WinVer : TWindowsVersion; -//asm -// MOVSX EAX, byte ptr [SaveWinVer] -// INC AH // если <> 0 после инкремента, то AL содержит вычисленную версию -// JNZ @@exit -// CALL GetVersion // EAX < 0 для платформы 9х, иначе NT; AL=MajorVersion; AH=MinorVersion -// XCHG EDX, EAX -// XOR EAX, EAX -// TEST EDX, EDX -// XCHG DL, DH // DH=MajorVersion; DL=MinorVersion -// -// JL @@platform_9x -// MOV AL, wvNT -// CMP DX, $0400 -// JZ @@save_exit -// -// INC AL // wvY2K -// SUB DX, $0500 -// JZ @@save_exit -// -// INC AL // wvXP -// //CMP DX, $0501 -// DEC DX -// JZ @@save_exit -// -// INC AL // wvWin2003Server -// //CMP DX, $0502 -// DEC DX -// JZ @@save_exit -// -// INC AL // wvVista -// CMP DX, $0600 - $0502 -// JZ @@save_exit -// -// INC AL // wvSeven -// //CMP DX, $0601 -// //DEC DX -// JMP @@save_exit -//@@platform_9x: -// CMP DH, 4 -// JB @@save_exit // wv31 -// INC AL // wv95 -// CMP DX, $040A -// JB @@save_exit -// INC AL // wv98 -// CMP DX, $045A -// JB @@save_exit -// INC AL // wvME -//@@save_exit: -// MOV byte ptr [SaveWinVer], AL -//@@exit: -//end; - function TControl.MakeWordWrap: PControl; asm {$IFDEF USE_FLAGS} @@ -14970,946 +13566,4 @@ asm POP EAX end; -function TControl.FormGetIntParam: PtrInt; -asm - PUSH ESI - PUSH EDI - MOV EDI, EAX // EDX = @ Self - - XOR EDX, EDX -@@loop: - - LEA ECX, [EDI].DF.FormParams - MOV ESI, DWORD PTR[ECX] - LODSB - MOV DWORD PTR[ECX], ESI - - SHR AL, 1 - JNC @@nocont - - SHL EDX, 7 - OR DL, AL - JMP @@loop - -@@nocont: - - SHR AL, 1 - PUSHF - XCHG EDX, EAX - SHL EAX, 6 - OR AL, DL - POPF - JNC @@noneg - - NEG EAX -@@noneg: - POP EDI - POP ESI -end; - -function TControl.FormGetColorParam: Integer; -asm - CALL FormGetIntParam - ROR EAX, 1 -end; - -procedure TControl.FormGetStrParam; -asm - PUSH EDI - MOV EDI, EAX - CALL FormGetIntParam - XCHG ECX, EAX - LEA EAX, [EDI].FormString - PUSH ECX - MOV EDX, DWORD PTR[EDI].DF.FormParams - CALL System.@LStrFromPCharLen - POP ECX - ADD DWORD PTR[EDI].DF.FormParams, ECX - POP EDI -end; - -procedure TControl.FormExecuteCommands(AForm: PControl; ControlPtrOffsets: PSmallIntArray); -asm - PUSH EBX - PUSH ESI - PUSH EDI - XCHG EDI, EAX // EDI = @ Self - MOV EBX, EDX // EBX = AForm - MOV ESI, ECX // ECX = @ ControlPtrOffsets[0] -@@while_do: - MOV EAX, EDI - CALL FormGetIntParam - TEST EAX, EAX - JZ @@ewhile - JG @@not_create_ctrl - - NEG EAX - MOV ECX, [EDI].DF.FormAlphabet - MOV ECX, [ECX+EAX*4-4] - - MOV EAX, EDI - - CALL ECX - XCHG ECX, EAX - - XOR EAX, EAX - LODSW - MOV DWORD PTR[EBX+EAX*4], ECX - MOV [EDI].DF.FormLastCreatedChild, ECX - JMP @@while_do - -@@not_create_ctrl: - MOV ECX, [EDI].DF.FormAlphabet - MOV ECX, [ECX+EAX*4-4] - MOV EAX, [EDI].DF.FormLastCreatedChild - - XOR EDX, EDX - INC EDX - - CALL ECX - JMP @@while_do - -@@ewhile: - LEA EAX, [EDI].FormString - CALL System.@LStrClr - - POP EDI - POP ESI - POP EBX -end; - -function FormNewLabel( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewLabel -end; - -function FormNewWordWrapLabel( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewWordWrapLabel -end; - -function FormNewLabelEffect( Form: PControl ): PControl; -asm - PUSH EAX - CALL TControl.FormGetStrParam - POP EAX - PUSH EAX - CALL TControl.FormGetIntParam - POP ECX - PUSH EAX - MOV EAX, [ECX].TControl.DF.FormCurrentParent - MOV EDX, [ECX].TControl.FormString - POP ECX - CALL NewLabelEffect -end; - -function FormNewButton( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewButton -end; - -function FormNewPanel( Form: PControl ): PControl; -asm - CALL FormPrepareIntParamCreateCtrl - CALL NewPanel -end; - -function FormNewGroupbox( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewGroupbox -end; - -function FormNewEditBox( Form: PControl ): PControl; -asm - CALL FormPrepareIntParamCreateCtrl - CALL NewEditBox -end; - -{$IFDEF USE_RICHEDIT} -function FormNewRichEdit( Form: PControl ): PControl; -asm CALL FormPrepareIntParamCreateCtrl - CALL NewRichEdit -end; -{$ENDIF USE_RICHEDIT} - -function FormNewComboBox( Form: PControl ): PControl; -asm - CALL FormPrepareIntParamCreateCtrl - CALL NewCombobox -end; - -function FormNewCheckbox( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewCheckbox -end; - -function FormNewRadiobox( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewRadiobox -end; - -function FormNewListbox( Form: PControl ): PControl; -asm - CALL FormPrepareIntParamCreateCtrl - CALL NewListbox -end; - -//!!! asm version returns in EAX Control, -// and integer parameter in EDX and ECX (EDX=ECX) !!! -//--- this is enough to call method of Control with a single int param --- -function ParentForm_IntParamAsm(Control: PControl): Integer; -asm PUSH EAX - CALL TControl.FormParentForm - CALL TControl.FormGetIntParam - XCHG EDX, EAX - MOV ECX, EDX - POP EAX -end; -function ParentForm_ColorParamAsm(Control: PControl): Integer; -asm CALL ParentForm_IntParamAsm - ROR EDX, 1 -end; - -procedure FormSetSize( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - //XCHG ECX, EDX - POP EDX - CALL TControl.SetSize -end; - -function ParentForm_PCharParamAsm(Control: PControl): PChar; -asm PUSH EAX - CALL ParentForm_PCharParam - XCHG EDX, EAX - MOV ECX, EDX - POP EAX -end; - -procedure FormSetPosition( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - CALL TControl.SetPosition -end; - -procedure FormSetClientSize( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - //XCHG ECX, EDX - POP EDX - CALL TControl.SetClientSize -end; - -procedure FormSetAlign( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetAlign -end; - -procedure FormSetCanResizeFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetCanResize -end; - -procedure FormInitMenu( Form: PControl ); -asm - PUSH 0 - PUSH 0 - PUSH WM_INITMENU - PUSH EAX - CALL TControl.Perform -end; - -procedure FormSetExStyle( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - OR EDX, [EAX].TControl.fExStyle - CALL TControl.SetExStyle -end; - -procedure FormSetVisibleFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetVisible -end; - -procedure FormSetEnabledFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetEnabled -end; - -procedure FormResetStyles( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - NOT EDX - AND EDX, [EAX].TControl.fStyle - CALL TControl.SetStyle -end; - -procedure FormSetStyle( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - OR EDX, [EAX].TControl.fStyle - CALL TControl.SetStyle -end; - -procedure FormSetAlphaBlend( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetAlphaBlend -end; - -procedure FormSetHasBorderFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetHasBorder -end; - -procedure FormSetHasCaptionFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetHasCaption -end; - -procedure FormResetCtl3D( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetCtl3D -end; - -procedure FormIconLoad_hInstance( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV EDX, [hInstance] - CALL TControl.IconLoad -end; - -procedure FormIconLoadCursor_0( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - CALL TControl.IconLoadCursor -end; - -procedure FormSetIconNeg1( Form: PControl ); -asm - OR EDX, -1 - CALL TControl.SetIcon -end; - -procedure FormSetWindowState( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetWindowState -end; - -procedure FormCursorLoad_0( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - CALL TControl.CursorLoad -end; - -procedure FormSetColor( Form: PControl ); -asm - CALL ParentForm_ColorParamAsm - CALL TControl.SetCtlColor -end; - -procedure FormSetBrushStyle( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetBrush - POP EDX - CALL TGraphicTool.SetBrushStyle -end; - -procedure FormSetBrushBitmap( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - CALL TControl.FormParentForm - - PUSH EAX - CALL ParentForm_PCharParam - XCHG EDX, EAX - MOV EAX, [hInstance] - POP ECX - - CALL LoadBmp - - PUSH EAX - MOV EAX, EDI - CALL TControl.GetBrush - POP EDX - - CALL TGraphicTool.SetBrushBitmap - POP EDI -end; - -procedure FormSetFontColor( Form: PControl ); -asm - CALL ParentForm_ColorParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetColor -end; - -procedure FormSetFontStyles( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetFontStyle -end; - -procedure FormSetFontHeight( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - XOR EDX, EDX - MOV DL, 4 - POP ECX - CALL TGraphicTool.SetInt -end; - -procedure FormSetFontWidth( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - XOR EDX, EDX - MOV DL, 8 - POP ECX - CALL TGraphicTool.SetInt -end; - -procedure FormSetFontOrientation( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetFontOrientation -end; - -procedure FormSetFontCharset( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetFontCharset -end; - -procedure FormSetFontPitch( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetFontPitch -end; - -procedure FormSetBorder( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV [EAX].TControl.fMargin, DL -end; - -procedure FormSetMarginTop( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - INC EDX - CALL TControl.SetClientMargin -end; - -procedure FormSetMarginBottom( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - MOV DL, 2 - CALL TControl.SetClientMargin -end; - -procedure FormSetMarginLeft( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - MOV DL, 3 - CALL TControl.SetClientMargin -end; - -procedure FormSetMarginRight( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - MOV DL, 4 - CALL TControl.SetClientMargin -end; - -procedure FormSetSimpleStatusText( Form: PControl ); -asm - CALL ParentForm_PCharParamAsm - XOR EDX, EDX - MOV DL, 255 - CALL TControl.SetStatusText -end; - -procedure FormSetStatusText( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_PCharParamAsm - POP EDX - CALL TControl.SetStatusText -end; - -procedure FormRemoveCloseIcon( Form: PControl ); -asm - PUSH MF_BYCOMMAND - PUSH SC_CLOSE - CALL TControl.GetWindowHandle - PUSH 0 - PUSH EAX - CALL GetSystemMenu - PUSH EAX - CALL DeleteMenu -end; - -procedure FormSetConstraint; -asm - MOVZX EDX, DL - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - CALL TControl.SetConstraint -end; - -procedure FormSetMinWidth( Form: PControl ); -asm - XOR EDX, EDX - CALL FormSetConstraint -end; - -procedure FormSetMaxWidth( Form: PControl ); -asm - MOV DL, 2 - CALL FormSetConstraint -end; - -procedure FormSetMinHeight( Form: PControl ); -asm - MOV DL, 1 - CALL FormSetConstraint -end; - -procedure FormSetMaxHeight( Form: PControl ); -asm - MOV DL, 3 - CALL FormSetConstraint -end; - -procedure FormSetTextShiftX( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV [EAX].TControl.DF.fTextShiftX, EDX -end; - -procedure FormSetTextShiftY( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV [EAX].TControl.DF.fTextShiftY, EDX -end; - -procedure FormSetColor2( Form: PControl ); -asm - CALL ParentForm_ColorParamAsm - CALL TControl.SetColor2 -end; - -procedure FormSetTextAlign( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetTextAlign -end; - -procedure FormSetTextVAlign( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetVerticalAlign -end; - -procedure FormSetIgnoreDefault( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - {$IFDEF USE_FLAGS} - SHL EDX, G5_IgnoreDefault - AND [EAX].TControl.fFlagsG5, $7F //not(1 shl G5_IgnoreDefault) - OR [EAX].TControl.fFlagsG5, DL - {$ELSE} - MOV [EAX].TControl.FIgnoreDefault, DL - {$ENDIF} -end; - -procedure FormSetCaption( Form: PControl ); -asm - PUSH EAX - CALL TControl.FormParentForm - PUSH EAX - CALL TControl.FormGetStrParam - POP EAX - MOV EDX, [EAX].TControl.FormString - POP EAX - CALL TControl.SetCaption -end; - -procedure FormSetGradienStyle( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetGradientStyle -end; - -{$IFDEF USE_RICHEDIT} -procedure FormSetRE_AutoFontFalse( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 4 - XOR ECX, ECX - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_AutoFontSizeAdjustFalse( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 16 - XOR ECX, ECX - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_DualFontTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 128 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_UIFontsTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 32 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_IMECancelCompleteTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 4 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_IMEAlwaysSendNotifyTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 8 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetMaxTextSize( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetMaxTextSize -end; - -procedure FormSetRE_AutoKeyboardTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 1 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_Zoom( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - SHL ECX, 16 - OR EDX, ECX - CALL TControl.ReSetZoom -end; -{$ENDIF USE_RICHEDIT} - -procedure FormSetCount( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetItemsCount -end; - -procedure FormSetDroppedWidth( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetDroppedWidth -end; - -procedure FormSetButtonImage( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - CALL ParentForm_IntParamAsm - PUSH ECX - CALL ParentForm_IntParamAsm - POP ECX - PUSH $8000 // LR_SHARED - PUSH ECX - PUSH EDX - PUSH IMAGE_ICON - CALL ParentForm_PCharParam - PUSH EAX - PUSH [hInstance] - CALL LoadImage - XCHG EDX, EAX - XCHG EAX, EDI - CALL TControl.SetButtonIcon - POP EDI -end; - -procedure FormSetButtonBitmap( Form: PControl ); -asm - PUSH EAX - CALL ParentForm_PCharParam - PUSH EAX - PUSH [hInstance] - CALL LoadBitmap - XCHG EDX, EAX - POP EAX - CALL TControl.SetButtonBitmap -end; - -procedure FormSetMaxProgress( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV EDX, (PBM_SETRANGE32 or $8000) shl 16 - CALL TControl.SetMaxProgress -end; - -procedure FormSetProgress( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV EDX, (PBM_SETPOS or $8000) shl 16 - CALL TControl.SetIntVal -end; - -procedure FormLVColumsAdd( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - CALL ParentForm_IntParamAsm - JECXZ @@fin -@@1: - PUSH ECX - MOV EAX, EDI - CALL ParentForm_IntParamAsm - PUSH ECX - CALL ParentForm_StrParam - MOV EAX, EDI - CALL TControl.FormParentForm - MOV EDX, [EAX].TControl.FormString - XOR ECX, ECX - MOV CL, taLeft - MOV EAX, EDI - CALL TControl.LVColAdd - POP ECX - LOOP @@1 -@@fin: - POP EDI -end; - -procedure FormSetLVColOrder( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - PUSH ECX - MOV ECX, LVCF_ORDER or (28 shl 16) - CALL TControl.SetLVColEx -end; - -procedure FormSetLVColImage( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - PUSH ECX - MOV ECX, LVCF_IMAGE or (24 shl 16) - CALL TControl.SetLVColEx -end; - -procedure FormSetTVIndent( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV EDX, TVM_GETINDENT - CALL TControl.SetIntVal -end; - -procedure FormSetDateTimeFormat( Form: PControl ); -asm - PUSH EAX - CALL TControl.FormParentForm - PUSH EAX - CALL TControl.FormGetStrParam - POP EAX - MOV EDX, [EAX].TControl.FormString - POP EAX - CALL TControl.SetDateTimeFormat -end; - -procedure FormSetCurrentTab( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSHAD - CALL TControl.SetCurIndex - POPAD - CALL TControl.GetPages - CALL TControl.BringToFront -end; - -procedure FormSetCurIdx( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetCurIndex -end; - -procedure FormSetSBMin( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetSBMin -end; - -procedure FormSetSBMax( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetSBMax -end; - -procedure FormSetSBPosition( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetSBPosition -end; - -procedure FormSetSBPageSize( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetSBPageSize -end; - -procedure FormLastCreatedChildAsNewCurrentParent( Form: PControl ); -asm - PUSH EAX - CALL TControl.FormParentForm - POP [EAX].TControl.DF.FormCurrentParent -end; - -procedure FormSetTabpageAsParent( Form: PControl ); -asm - PUSH EAX - CALL TControl.FormParentForm - CALL ParentForm_IntParamAsm - POP ECX - PUSH EAX - XCHG EAX, ECX - CALL TControl.GetPages - POP EDX - MOV [EDX].TControl.DF.FormCurrentParent, EAX - MOV [EDX].TControl.DF.FormLastCreatedChild, EAX -end; - -procedure FormSetCurCtl( Form: PControl ); -asm - CALL TControl.FormParentForm - CALL ParentForm_IntParamAsm - MOV ECX, [EAX].TControl.DF.FormAddress - MOV ECX, [ECX + EDX*4] - - TEST ECX, ECX - JNZ @@1 - MOV ECX, EAX - -@@1: - MOV [EAX].TControl.DF.FormLastCreatedChild, ECX -end; - -procedure FormSetEvent( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - PUSH ESI - CALL TControl.FormParentForm - MOV ESI, EAX - PUSH [ESI].TControl.DF.FormObj - CALL ParentForm_IntParamAsm - MOV ESI, [EAX].TControl.DF.FormAlphabet - PUSH dword ptr [ESI+EDX*4] - CALL ParentForm_IntParamAsm - XCHG EAX, EDI - CALL dword ptr [ESI+EDX*4] - POP ESI - POP EDI -end; - -procedure FormSetIndexedEvent( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - PUSH ESI - CALL TControl.FormParentForm - MOV ESI, EAX - PUSH [ESI].TControl.DF.FormObj - CALL ParentForm_IntParamAsm - MOV ESI, [EAX].TControl.DF.FormAlphabet - PUSH dword ptr [ESI+EDX*4] - - CALL ParentForm_IntParamAsm // idx - PUSH EDX - - CALL ParentForm_IntParamAsm - XCHG EAX, EDI - MOV ECX, dword ptr [ESI+EDX*4] - - POP EDX - CALL ECX - POP ESI - POP EDI -end; - -{$ENDIF} - //======================================== THE END OF FILE KOL_ASM.inc diff --git a/KOL_ASM_NOUNICODE.inc b/KOL_ASM_NOUNICODE.inc index 52af64a..0179a2e 100644 --- a/KOL_ASM_NOUNICODE.inc +++ b/KOL_ASM_NOUNICODE.inc @@ -22,11 +22,9 @@ asm PUSH EAX CALL GetProcAddress XCHG ECX, EAX - {$IFDEF SAFE_CODE} POP EDX JECXZ @@fin PUSH EDX - {$ENDIF} PUSH 8 // dwSize PUSH ESP // @ ICC CALL ECX // Proc( @ ICC ) @@ -40,9 +38,7 @@ asm push edx // Flags mov ecx, [Applet] {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFDEF SAFE_CODE} jecxz @@0 - {$ENDIF} pushad xchg eax, ecx mov edx, offset[WndProcSnapMouse2DfltBtn] @@ -51,9 +47,7 @@ asm @@0: {$ENDIF} mov edx, 0 - {$IFDEF SAFE_CODE} jecxz @@1 - {$ENDIF} mov edx, [ecx].TControl.fHandle mov ecx, [ecx].TControl.fCaption @@1: push ecx // Title @@ -62,9 +56,7 @@ asm call MessageBox {$IFDEF SNAPMOUSE2DFLTBTN} mov ecx, [Applet] - {$IFDEF SAFE_CODE} jecxz @@2 - {$ENDIF} pushad xchg eax, ecx mov edx, offset[WndProcSnapMouse2DfltBtn] @@ -109,10 +101,8 @@ asm PUSH EAX // prepare Length(Text) CALL EDX2PChar PUSH EDX // prepare PChar(Text) - {$IFDEF SAFE_CODE} MOV EAX, EBX CALL RefInc - {$ENDIF} PUSH HandleValid or FontValid PUSH EBX CALL RequiredState @@ -152,12 +142,10 @@ asm XCHG EAX, EBX CALL SetHandle @@exit: - {$IFDEF SAFE_CODE} PUSH EAX XCHG EAX, EBX CALL RefDec POP EAX - {$ENDIF} POP ESI POP EBX end; @@ -229,10 +217,7 @@ asm // EAX = Value PUSH EDI PUSH ECX LEA EDI, [ESP+8+0Fh] // EBX := @Buf[ 15 ] - {$IFDEF SMALLEST_CODE} - {$ELSE} AND EDX, $F - {$ENDIF} @@loop: DEC EDI DEC EDX PUSH EAX @@ -634,16 +619,11 @@ function CopyTail( const S : AnsiString; Len : Integer ) : AnsiString; asm PUSH ECX PUSH EAX - PUSH EDX - CALL System.@LStrLen - POP ECX - CMP ECX, EAX - {$IFDEF USE_CMOV} - CMOVG ECX, EAX - {$ELSE} - JLE @@1 - MOV ECX, EAX -@@1: {$ENDIF} + PUSH EDX + CALL System.@LStrLen + POP ECX + CMP ECX, EAX + CMOVG ECX, EAX MOV EDX, EAX SUB EDX, ECX @@ -660,12 +640,7 @@ asm CALL System.@LStrLen POP ECX CMP ECX, EAX - {$IFDEF USE_CMOV} CMOVG ECX, EAX - {$ELSE} - JLE @@1 - MOV ECX, EAX -@@1: {$ENDIF} MOV EDX, EAX SUB EDX, ECX @@ -674,7 +649,6 @@ asm CALL System.@LStrDelete end; -{$IFnDEF TEST_INDEXOFCHARS_COMPAT} function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer; asm CALL EAX2PChar @@ -686,7 +660,6 @@ asm LEA EDX, [EAX+1] @@1: SUB EAX, EDX end; -{$ENDIF} function IndexOfCharsMin( const S, Chars : AnsiString ) : Integer; asm PUSH ESI @@ -873,6 +846,12 @@ asm CALL RemoveStr XCHG EAX, ESI + //dufa: if true -> AL=42 (this is char "*"), fix AL -> 1 +@@fix_true_result: + TEST AL, AL + JZ @@exit + MOV AL, 1 + //dufa. @@exit: POP ESI end; @@ -1550,105 +1529,6 @@ asm JMP _FillStrList end; -procedure TIniFile.SectionData(Names: PStrList); -asm - PUSH ESI - PUSH EDI - PUSH EBX - PUSH ECX - - MOV EBX,EAX - MOV EAX, IniBufferStrSize - MOV EDI,EDX - - CALL System.@GetMem - MOV ESI,EAX - PUSH EAX - - OR [EBX].fMode,0 - JNE @@DOWrite - - PUSH [EBX].fFileName - MOV EAX,IniBufferSize - PUSH EAX - - LEA EAX,[ESI+4] - PUSH EAX - PUSH [EBX].fSection - - CALL GetPrivateProfileSection - JMP _FillStrList - -@@DOWrite: - - PUSH EBX - PUSH ESI - PUSH EDX - PUSH EBP - - MOV EDX,0 - MOV EBP,[EDI].TStrList.fCount - MOV EBX,IniBufferSize-2 // оставим место для #0#0 - -{ECM+++>} OR EBP,EBP // otherwise GetPChars when StrList.Count = 0 crashed - -@@LOOP: - JE @@ENDLOOP - - OR EBX,EBX - JE @@ENDLOOP - - PUSH EDX - MOV EAX,EDI - CALL TStrList.GetPChars - - PUSH EAX - CALL StrLen - POP EAX - - XOR ECX,-1 - MOV EDX,ESI - - SUB EBX,ECX - JA @@L1 - ADD ECX,EBX - XOR EBX,EBX -@@L1: - - ADD ESI,ECX - - CALL MOVE -@@L2: - POP EDX - INC EDX - DEC EBP - JMP @@LOOP -@@ENDLOOP: - MOV WORD PTR [ESI],0 - - POP EBP - POP EDX - POP ESI - POP EBX - MOV EAX,EBX - CALL ClearSection - - PUSH [EBX].fFileName - PUSH ESI - PUSH [EBX].fSection - - CALL WritePrivateProfileSection - - POP EAX - CALL System.@FreeMem - - POP ECX - POP EBX - POP EDI - POP ESI - -end; - function _NewControl( AParent: PControl; ControlClassName: PKOLChar; Style: DWORD; Ctl3D: Boolean; Actions: TCommandActionsParam ): PControl; @@ -1695,29 +1575,21 @@ asm LEA EDI, [EBX].TControl.fBoundsRect LODSB MOVSX EAX, AL - {$IFNDEF SMALLEST_CODE} PUSH EAX MOVSX ECX, byte ptr [ESI+2] ADD EAX, ECX // AParent.fClientLeft - {$ENDIF} STOSD // fBoundsRect.Left - {$IFNDEF SMALLEST_CODE} POP EAX PUSH EAX MOVSX ECX, byte ptr [ESI+0] ADD EAX, ECX // AParent.fClientTop - {$ENDIF} STOSD // fBoundsRect.Top - {$IFNDEF SMALLEST_CODE} XCHG EDX, EAX POP EAX - {$ENDIF} ADD EAX, 64 STOSD // fBoundsRect.Right - {$IFNDEF SMALLEST_CODE} XCHG EAX, EDX ADD EAX, 64 - {$ENDIF} STOSD // fBoundsRect.Bottom} POP ECX MOV EAX, [ECX].TControl.fCursor @@ -2503,11 +2375,7 @@ asm //cmd //opd CALL MakeFlags POP EDX - {$IFDEF COMMANDACTIONS_OBJ} PUSH TOOLBAR_ACTIONS - {$ELSE} - PUSH 0 //: actions : = nil - {$ENDIF} XCHG ECX, EAX // ECX = MakeFlags(...) MOV EDI, ECX MOV EAX, [ESP+8] // EAX = AParent @@ -2516,14 +2384,9 @@ asm //cmd //opd OR ECX, WS_CHILD or WS_VISIBLE or TBSTYLE_TOOLTIPS MOV EDX, offset[ TOOLBARCLASSNAME ] CALL _NewCommonControl - {$IFDEF COMMANDACTIONS_OBJ} MOV EDX, [EAX].TControl.fCommandActions MOV [EDX].TCommandActionsObj.aClear, offset[ClearToolbar] MOV [EDX].TCommandActionsObj.aGetCount, TB_BUTTONCOUNT - {$ELSE} - MOV [EAX].TControl.fCommandActions.aClear, offset[ClearToolbar] - MOV [EAX].TControl.fCommandActions.aGetCount, TB_BUTTONCOUNT - {$ENDIF} {$IFDEF USE_FLAGS} OR [EAX].TControl.fFlagsG5, 1 shl G5_IsButton {$ELSE} @@ -2838,11 +2701,7 @@ asm PUSH [hInstance]// Params.WindowClass.hInstance := hInstance PUSH ECX // Params.WindowClass.cbWndExtra := 0 PUSH ECX // Params.WindowClass.cbClsExtra := 0 - {$IFDEF SAFE_CODE} PUSH [EBX].fDefWndProc // Params.WindowClass.lpfnWndProc := fDefWndProc - {$ELSE} - PUSH 0 - {$ENDIF} PUSH [EBX].fClsStyle // Params.WindowClass.style := fStyle ADD ESP, -64 PUSH ECX @@ -2872,12 +2731,7 @@ asm @@1: PUSH EAX // Params.Height := Height | CW_UseDefault MOV EAX, [EBX].fBoundsRect.Right SUB EAX, [EBX].fBoundsRect.Left - {$IFDEF USE_CMOV} CMOVZ EAX, ECX - {$ELSE} - JNZ @@2 - MOV EAX, ECX -@@2: {$ENDIF} PUSH EAX // Params.Width := Width | CW_UseDefault MOV EAX, [EBX].fBoundsRect.Left @@ -2956,11 +2810,7 @@ asm TEST EAX, EAX JZ @@fin PUSH EAX - {$IFDEF USE_PROP} - PUSH offset ID_SELF - {$ELSE} PUSH GWL_USERDATA - {$ENDIF} PUSH EAX PUSH 0 @@ -2969,29 +2819,17 @@ asm PUSH EAX CALL SendMessage - {$IFDEF USE_PROP} - CALL GetProp - {$ELSE} CALL GetWindowLong - {$ENDIF} XCHG ECX, EAX POP EAX INC ECX LOOP @@propSet MOV [CreatingWindow], ECX PUSH EBX - {$IFDEF USE_PROP} - PUSH offset ID_SELF - PUSH EAX - CALL SetProp - {$ELSE} PUSH GWL_USERDATA PUSH EAX CALL SetWindowLong - {$ENDIF} @@propSet: - {$IFDEF SMALLEST_CODE} - {$ELSE} {$IFDEF USE_FLAGS} TEST [EBX].fFlagsG3, 1 shl G3_IsControl {$ELSE} @@ -3006,7 +2844,6 @@ asm PUSH EBX CALL Perform @@iconSet: - {$ENDIF} MOV ECX, [EBX].PP.fCreateWndExt {$IFDEF NIL_EVENTS} JECXZ @@dblbufcreate @@ -3191,12 +3028,8 @@ asm XCHG ESI, EAX // ESI = Idx' XOR EAX, EAX - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EBX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aGetItemLength - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aGetItemLength - {$ENDIF} JECXZ @@ret_empty PUSH ECX // push aGetItemLength @@ -3214,12 +3047,8 @@ asm POP EDX // restore L LEA ECX, [EDX+1] MOV dword ptr [EAX], ECX - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EBX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aGetItemText - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aGetItemText - {$ENDIF} JECXZ @@ret_buf PUSH EDX // save L @@ -3266,12 +3095,8 @@ asm CALL ECX2PChar PUSH ECX // @Value[1] - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EBX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aSetItemText - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aSetItemText - {$ENDIF} JECXZ @@1 PUSH 0 @@ -3309,12 +3134,8 @@ asm @@1: // @Value[1] in stack already POP EDX - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EBX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aDeleteItem - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aDeleteItem - {$ENDIF} JECXZ @@exit PUSH ESI @@ -3362,12 +3183,8 @@ asm PUSH EBX MOV EBX, EAX // EBX = @Self - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EBX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aAddItem - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aAddItem // ECX = aAddItem - {$ENDIF} JECXZ @@chk_addtext CALL EDX2PChar @@ -3392,12 +3209,8 @@ asm JMP @@exit @@chk_addtext: - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EBX].fCommandActions MOV ECX, [ECX].TCommandActionsObj.aAddText - {$ELSE} - MOV ECX, [EBX].fCommandActions.aAddText - {$ENDIF} JECXZ @@add_text_simple CALL ECX @@ -3420,12 +3233,8 @@ function TControl.Insert(Idx: Integer; const S: AnsiString): Integer; asm CALL ECX2PChar PUSH ECX - {$IFDEF COMMANDACTIONS_OBJ} MOV ECX, [EAX].fCommandActions MOVZX ECX, [ECX].TCommandActionsObj.aInsertItem - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aInsertItem - {$ENDIF} JECXZ @@exit_1 PUSH EDX @@ -4142,12 +3951,7 @@ asm { [EBP+$8] = @Self STOSD MOV EAX, [ToolbarsIDcmd] TEST EBX, EBX - {$IFDEF USE_CMOV} CMOVL EBX, EAX - {$ELSE} - JGE @@b0 - MOV EBX, EAX -@@b0: {$ENDIF} STOSD XOR EAX, EAX INC AH // TBSTYLE_SEP = 1 @@ -4179,12 +3983,7 @@ asm { [EBP+$8] = @Self MOV EAX, [ToolbarsIDcmd] STOSD TEST EBX, EBX - {$IFDEF USE_CMOV} CMOVL EBX, EAX - {$ELSE} - JGE @@210 - MOV EBX, EAX -@@210: {$ENDIF} MOV ECX, [EBP+8] MOV AH, BYTE PTR [ECX].TControl.DF.fDefaultTBBtnStyle POP ECX diff --git a/KOLadd.pas b/KOLadd.pas index 5d5884b..8d25da3 100644 --- a/KOLadd.pas +++ b/KOLadd.pas @@ -1178,47 +1178,8 @@ begin Result := ( PBitsList( fList ).fCount + 3) div 4; end; -{$IFDEF ASM_noVERSION} //[function TBits.IndexOf] function TBits.IndexOf(Value: Boolean): Integer; -asm //cmd //opd - PUSH EDI - MOV EDI, [EAX].fList - MOV ECX, [EDI].TList.fCount -@@ret_1: - OR EAX, -1 - JECXZ @@ret_EAX - MOV EDI, [EDI].TList.fItems - TEST DL, DL - MOV EDX, EDI - JE @@of_false - INC EAX - REPZ SCASD - JE @@ret_1 - MOV EAX, [EDI-4] - NOT EAX - JMP @@calc_offset - BSF EAX, EAX - SUB EDI, EDX - SHR EDI, 2 - ADD EAX, EDI - JMP @@ret_EAX -@@of_false: - REPE SCASD - JE @@ret_1 - MOV EAX, [EDI-4] -@@calc_offset: - BSF EAX, EAX - DEC EAX - SUB EDI, 4 - SUB EDI, EDX - SHL EDI, 3 - ADD EAX, EDI -@@ret_EAX: - POP EDI -end; -{$ELSE ASM_VERSION} //Pascal -function TBits.IndexOf(Value: Boolean): Integer; var I: Integer; D: DWORD; begin @@ -1262,7 +1223,6 @@ begin end; end; end; -{$ENDIF ASM_VERSION} //[function TBits.LoadFromStream] procedure TBits.InstallBits(FromIdx, N: Integer; Value: Boolean); @@ -1324,51 +1284,6 @@ begin end; //[procedure TBits.SetBit] -{$IFDEF ASM_noVERSION} -procedure TBits.SetBit(Idx: Integer; const Value: Boolean); -asm - PUSH EBX - XCHG EBX, EAX - CMP EDX, [EBX].fCount - JL @@2 - - LEA EAX, [EDX+32] - SHR EAX, 5 - - PUSH ECX - MOV ECX, [EBX].fList - CMP [ECX].TBitsList.fCount, EAX - JGE @@1 - - MOV [ECX].TBitsList.fCount, EAX - MOV ECX, [ECX].TBitsList.fCapacity - SHL ECX, 5 - CMP EDX, ECX - JLE @@1 - - PUSH EDX - INC EDX - PUSH EAX - MOV EAX, EBX - CALL SetCapacity - POP EAX - POP EDX - -@@1: - POP ECX -@@2: - MOV EAX, [EBX].fList - MOV EAX, [EAX].TBitsList.fItems - SHR ECX, 1 - JC @@2set - BTR [EAX], EDX - JMP @@exit -@@2set: - BTS [EAX], EDX -@@exit: - POP EBX -end; -{$ELSE} procedure TBits.SetBit(Idx: Integer; const Value: Boolean); var Msk: DWORD; MinListCount: Integer; @@ -1392,7 +1307,6 @@ begin if Idx >= fCount then fCount := Idx + 1; end; -{$ENDIF} //[procedure TBits.SetCapacity] procedure TBits.SetCapacity(const Value: Integer); @@ -2272,6 +2186,7 @@ function _NewDirChgNotifier: PDirChange; begin New( Result, Create ); end; + //[function NewDirChangeNotifier] function NewDirChangeNotifier( const Path: KOLString; Filter: TFileChangeFilter; WatchSubtree: Boolean; ChangeProc: TOnDirChange ) @@ -2371,31 +2286,8 @@ begin {$ENDIF ASM_VERSION} end; -{$IFDEF noASM_VERSION} //[destructor TDirChange.Destroy] destructor TDirChange.Destroy; -asm - PUSH EBX - XCHG EBX, EAX - MOV [EBX].FDestroying, 1 - MOV ECX, [EBX].FMonitor - JECXZ @@no_monitor - XCHG EAX, ECX - CALL TObj.Destroy // TObj.Free // -@@no_monitor: - MOV ECX, [EBX].FHandle - JECXZ @@exit - PUSH ECX - CALL FindCloseChangeNotification -@@exit: - LEA EAX, [EBX].FPath - CALL System.@LStrClr - XCHG EAX, EBX - CALL TObj.Destroy - POP EBX -end; -{$ELSE ASM_VERSION} //Pascal -destructor TDirChange.Destroy; begin FDestroying := TRUE; if FHandle > 0 then // FHandle <> INVALID_HANDLE_VALUE AND FHandle <> 0 @@ -2415,45 +2307,8 @@ begin FPath := ''; inherited; end; -{$ENDIF ASM_VERSION} -{$IFDEF ASM_noVERSION} //[function TDirChange.Execute] -function TDirChange.Execute(Sender: PThread): Integer; -asm - PUSH EBX - PUSH ESI - XCHG EBX, EAX - MOV ESI, EDX -@@loo: - MOVZX ECX, [ESI].TThread.FTerminated - INC ECX - LOOP @@e_loop - - MOV ECX, [EBX].FHandle - INC ECX - JZ @@e_loop - - PUSH INFINITE - PUSH ECX - CALL WaitForSingleObject - OR EAX, EAX - JNZ @@loo - - PUSH [EBX].FHandle - MOV EAX, [EBX].FMonitor - PUSH EBX - PUSH offset[TDirChange.Changed] - CALL TThread.Synchronize - CALL FindNextChangeNotification - JMP @@loo -@@e_loop: - - POP ESI - POP EBX - XOR EAX, EAX -end; -{$ELSE ASM_VERSION} //Pascal function TDirChange.Execute(Sender: PThread): PtrInt; var Handles: array[ 0..1 ] of THandle; //i: Integer; @@ -2477,20 +2332,15 @@ begin end; else break; end; - {$IFDEF SAFE_CODE} TRY - {$ENDIF} FindCloseChangeNotification( Handles[ 0 ] ); FHandle := 0; CloseHandle( FinEvent ); FinEvent := 0; - {$IFDEF SAFE_CODE} EXCEPT END; - {$ENDIF} Result := 0; end; -{$ENDIF ASM_VERSION} //////////////////////////////////////////////////////////////////////// // @@ -2736,36 +2586,17 @@ end; //[procedure TAction.LinkMenuItem] procedure TAction.LinkMenuItem(Menu: PMenu; MenuItemIdx: integer); -{$IFDEF _FPC} -var - arr1_DoOnMenuItem: array[ 0..0 ] of TOnMenuItem; -{$ENDIF _FPC} begin //LinkCtrl(Menu, ckMenu, MenuItemIdx, UpdateMenu); -- replaced by mdw to: LinkCtrl(Menu, ckMenu, Menu.Items[MenuItemIdx].MenuId, UpdateMenu); - - {$IFDEF _FPC} - arr1_DoOnMenuItem[ 0 ] := DoOnMenuItem; - Menu.AssignEvents(MenuItemIdx, arr1_DoOnMenuItem); - {$ELSE} Menu.AssignEvents(MenuItemIdx, [ DoOnMenuItem ]); - {$ENDIF} end; //[procedure TAction.LinkToolbarButton] procedure TAction.LinkToolbarButton(Toolbar: PControl; ButtonIdx: integer); -{$IFDEF _FPC} -var - arr1_DoOnToolbarButtonClick: array[ 0..0 ] of TOnToolbarButtonClick; -{$ENDIF _FPC} begin LinkCtrl(Toolbar, ckToolbar, ButtonIdx, UpdateToolbar); - {$IFDEF _FPC} - arr1_DoOnToolbarButtonClick[ 0 ] := DoOnToolbarButtonClick; - Toolbar.TBAssignEvents(ButtonIdx, arr1_DoOnToolbarButtonClick); - {$ELSE} Toolbar.TBAssignEvents(ButtonIdx, [DoOnToolbarButtonClick]); - {$ENDIF} end; //[destructor TAction.Destroy] diff --git a/MCKAppExpert200x.pas b/MCKAppExpert200x.pas index b1aba9f..af53fe2 100644 --- a/MCKAppExpert200x.pas +++ b/MCKAppExpert200x.pas @@ -110,8 +110,8 @@ const 'object KOLProj: TKOLProject' + #13#10 + 'Locked = False' + #13#10 + 'Localizy = False' + #13#10 + - 'projectName = ''prj''' + #13#10 + - 'projectDest = ''prj''' + #13#10 + + 'projectName = ''%prj_name%''' + #13#10 + + 'projectDest = ''%prj_name%''' + #13#10 + 'sourcePath = ''%path%''' + #13#10 + 'outdcuPath = ''%path%''' + #13#10 + 'dprResource = True' + #13#10 + @@ -126,9 +126,7 @@ const 'PaintType = ptWYSIWIG' + #13#10 + 'ShowHint = False' + #13#10 + 'ReportDetailed = False' + #13#10 + - 'GeneratePCode = False' + #13#10 + - 'NewIF = True' + #13#10 + - 'Left = 16' + #13#10 + + 'Left = 16' + #13#10 + 'Top = 16' + #13#10 + 'end' + #13#10 + 'object KOLForm: TKOLForm' + #13#10 + @@ -245,8 +243,9 @@ begin lst.Text := StringReplace(unt_template, '%unt_name%', unt_name, [rfReplaceAll]); lst.SaveToFile(ChangeFileExt(unt, '.pas')); // gen dfm - lst.Text := StringReplace(dfm_template, '%path%', ExtractFilePath(unt), [rfReplaceAll]); + lst.Text := StringReplace(dfm_template, '%prj_name%', ExtractFileName(prj), [rfReplaceAll]); lst.Text := StringReplace(lst.Text, '%unt_name%', unt_name, [rfReplaceAll]); + lst.Text := StringReplace(lst.Text, '%path%', ExtractFilePath(unt), [rfReplaceAll]); lst.SaveToFile(ChangeFileExt(unt, '.dfm')); // gen dummy res file resfile := FileCreate(ChangeFileExt(prj, '.res')); @@ -274,7 +273,7 @@ end; function TMCKWizard.GetComment: string; begin - Result := 'v0.03'; + Result := 'v0.04'; end; function TMCKWizard.GetGlyph: Cardinal; diff --git a/delphicommctrl.inc b/delphicommctrl.inc index 2db4a61..ed5eb3a 100644 --- a/delphicommctrl.inc +++ b/delphicommctrl.inc @@ -184,6 +184,7 @@ const PBS_SMOOTH = 01; PBS_VERTICAL = 04; + PBS_MARQUEE = $08; PBM_SETRANGE = WM_USER+1; PBM_SETPOS = WM_USER+2; @@ -196,6 +197,7 @@ const // wParam = True: Result = low PBM_GETPOS = WM_USER+8; PBM_SETBARCOLOR = WM_USER+9; // lParam = bar color + PBM_SETMARQUEE = WM_USER + 10; PBM_SETBKCOLOR = CCM_SETBKCOLOR; // lParam = bkColor SB_SETTEXTA = WM_USER+1; @@ -957,8 +959,8 @@ type dwDrawStage: DWORD; hdc: HDC; rc: TRect; - dwItemSpec: DWORD_PTR; // this is control specific, but it's how to specify an item. valid only with CDDS_ITEM bit set - uItemState: UINT; + dwItemSpec: DWORD_PTR; // this is control specific, but it's how to specify an item. valid only with CDDS_ITEM bit set + uItemState: UINT; lItemlParam: LPARAM; end; PNMCustomDraw = ^TNMCustomDraw; diff --git a/mckCtrlDraw.pas b/mckCtrlDraw.pas index 40a866f..13c1cc6 100644 --- a/mckCtrlDraw.pas +++ b/mckCtrlDraw.pas @@ -9,29 +9,44 @@ uses type TScrollStyle = (ssNone, ssHorz, ssVert, ssBoth); -const - TextHFlags: array[TTextAlign] of DWORD = (DT_LEFT, DT_RIGHT, DT_CENTER); - TextVFlags: array[TVerticalAlign] of DWORD = (DT_TOP, DT_VCENTER, DT_BOTTOM); - WordWrapFlags: array[Boolean] of DWORD = (DT_SINGLELINE, 0);//! - CheckFlags: array[Boolean] of DWORD = (0, DFCS_CHECKED); + TCDLVColumn = packed record + Caption: WideString; + TextAlign: TTextAlign; + Width: Integer; + end; + ArrayTCDLVColumn = array of TCDLVColumn; -procedure DrawButton(aUX: Boolean; DC: HDC; R: TRect; aEnabled, aDefBtn: Boolean; dwTextFlags: DWORD; aText: WideString); -procedure DrawEditBox(aUX: Boolean; DC: HDC; R: TRect; aEnabled, aIsPwd: Boolean; dwTextFlags: DWORD; aText: WideString); -procedure DrawMemo(aUX: Boolean; DC: HDC; R: TRect; aColor: Integer; aEnabled: Boolean; aScrollStyle: TScrollStyle; dwTextFlags: DWORD; aText: WideString); + TCDTBButton = packed record + Caption: WideString; + Rect: TRect; + Enabled: Boolean; + Separator: Boolean; + Checked: Boolean; + end; + ArrayTCDTBButton = array of TCDTBButton; + +const + TextHFlags: array[TTextAlign] of DWORD = (DT_LEFT, DT_RIGHT, DT_CENTER); + TextVFlags: array[TVerticalAlign] of DWORD = (DT_TOP, DT_VCENTER, DT_BOTTOM); + WordWrapFlags: array[Boolean] of DWORD = (DT_SINGLELINE, 0);//! + CheckFlags: array[Boolean] of DWORD = (0, DFCS_CHECKED); + +procedure DrawButton(aUX, aEnabled, aDefBtn: Boolean; DC: HDC; R: TRect; dwTextFlags: DWORD; aText: WideString); +procedure DrawEditBox(aUX, aEnabled, aIsPwd: Boolean; DC: HDC; R: TRect; dwTextFlags: DWORD; aText: WideString); +procedure DrawMemo(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aColor: Integer;aScrollStyle: TScrollStyle; dwTextFlags: DWORD; aText: WideString); procedure DrawCombobox(DC: HDC; R: TRect; aEnabled: Boolean; aText: WideString); procedure DrawLabel(DC: HDC; R: TRect; dwTextFlags: DWORD; aText: WideString); procedure DrawCheckbox(DC: HDC; R: TRect; aEnabled, aChecked, aHasBorder: Boolean; aText: WideString); -procedure DrawRadiobox(aUX: Boolean; DC: HDC; R: TRect; aEnabled, aChecked, aHasBorder: Boolean; aText: WideString); -procedure DrawListBox(aUX: Boolean; DC: HDC; R: TRect; aEnabled: Boolean; aText: WideString); -procedure DrawTreeView(aUX: Boolean; DC: HDC; R: TRect; aEnabled: Boolean; aText: WideString); -procedure DrawListView(aUX: Boolean; DC: HDC; R: TRect; aEnabled: Boolean; aColumns: KOLWideString); +procedure DrawRadiobox(aUX, aEnabled, aChecked, aHasBorder: Boolean; DC: HDC; R: TRect; aText: WideString); +procedure DrawListBox(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aText: WideString); +procedure DrawTreeView(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aText: WideString); +procedure DrawListView(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aCols: ArrayTCDLVColumn); procedure DrawProgressBar(DC: HDC; R: TRect; aVertical: Boolean; aProgress, aMaxProgress: Integer); procedure DrawTrackBar(DC: HDC; R: TRect; aVertical: Boolean; aProgress, aMaxProgress: Integer); procedure DrawGroupBox(aUX: Boolean; DC: HDC; R: TRect; aText: WideString); -procedure DrawScrollBar(aUX: Boolean; DC: HDC; R: TRect; aEnabled, aVertical: Boolean; aPos, aMin, aMax: Integer); +procedure DrawScrollBar(aUX, aEnabled, aVertical: Boolean; DC: HDC; R: TRect; aPos, aMin, aMax: Integer); procedure DrawScrollBox(aUX: Boolean; DC: HDC; R: TRect; aScrollStyle: TScrollStyle); -// not yet -procedure DrawToolbar(aUX: Boolean; DC: HDC; R: TRect; aEnabled: Boolean; aText: WideString); +procedure DrawToolbar(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aBtns: ArrayTCDTBButton); implementation @@ -43,17 +58,25 @@ begin Result := aPixelX + Round((aPos + Abs(aMin)) / (aMax + Abs(aMin)) * (aPixelMax - aPixelX * 3)); end; -procedure DrawScrollBar(aUX: Boolean; DC: HDC; R: TRect; aEnabled, aVertical: Boolean; aPos, aMin, aMax: Integer); +procedure DrawScrollBar(aUX, aEnabled, aVertical: Boolean; DC: HDC; R: TRect; aPos, aMin, aMax: Integer); const //enb btn arrThemedSBLU: array[Boolean, Boolean] of TThemedScrollBar = ( - (tsArrowBtnLeftDisabled, tsArrowBtnUpDisabled), (tsArrowBtnLeftNormal, tsArrowBtnUpNormal)); + (tsArrowBtnLeftDisabled, tsArrowBtnUpDisabled), + (tsArrowBtnLeftNormal, tsArrowBtnUpNormal)); + arrThemedSBRD: array[Boolean, Boolean] of TThemedScrollBar = ( - (tsArrowBtnRightDisabled, tsArrowBtnDownDisabled), (tsArrowBtnRightNormal, tsArrowBtnDownNormal)); + (tsArrowBtnRightDisabled, tsArrowBtnDownDisabled), + (tsArrowBtnRightNormal, tsArrowBtnDownNormal)); + arrThemedSBTH: array[Boolean] of TThemedScrollBar = (tsThumbBtnHorzNormal, tsThumbBtnVertNormal); + arrSBLU: array[Boolean, Boolean] of DWORD = ( - (DFCS_SCROLLLEFT or DFCS_INACTIVE,DFCS_SCROLLUP or DFCS_INACTIVE), (DFCS_SCROLLLEFT, DFCS_SCROLLUP)); + (DFCS_SCROLLLEFT or DFCS_INACTIVE,DFCS_SCROLLUP or DFCS_INACTIVE), + (DFCS_SCROLLLEFT, DFCS_SCROLLUP)); + arrSBRD: array[Boolean, Boolean] of DWORD = ( - (DFCS_SCROLLRIGHT or DFCS_INACTIVE, DFCS_SCROLLDOWN or DFCS_INACTIVE), (DFCS_SCROLLRIGHT, DFCS_SCROLLDOWN)); + (DFCS_SCROLLRIGHT or DFCS_INACTIVE, DFCS_SCROLLDOWN or DFCS_INACTIVE), + (DFCS_SCROLLRIGHT, DFCS_SCROLLDOWN)); var w: Integer; @@ -92,7 +115,7 @@ begin end; end; -procedure DrawButton(aUX: Boolean; DC: HDC; R: TRect; aEnabled, aDefBtn: Boolean; dwTextFlags: DWORD; aText: WideString); +procedure DrawButton(aUX, aEnabled, aDefBtn: Boolean; DC: HDC; R: TRect; dwTextFlags: DWORD; aText: WideString); const //enb defbtn arrThemedButton: array[Boolean, Boolean] of TThemedButton = ((tbPushButtonDisabled, tbPushButtonDisabled), (tbPushButtonNormal, tbPushButtonDefaulted)); @@ -125,7 +148,7 @@ begin end; end; -procedure DrawEditBox(aUX: Boolean; DC: HDC; R: TRect; aEnabled, aIsPwd: Boolean; dwTextFlags: DWORD; aText: WideString); +procedure DrawEditBox(aUX, aEnabled, aIsPwd: Boolean; DC: HDC; R: TRect; dwTextFlags: DWORD; aText: WideString); begin if ThemeServices.ThemesAvailable and aUX then begin // draw element @@ -148,7 +171,7 @@ begin end; end; -procedure DrawMemo(aUX: Boolean; DC: HDC; R: TRect; aColor: Integer; aEnabled: Boolean; aScrollStyle: TScrollStyle; dwTextFlags: DWORD; aText: WideString); +procedure DrawMemo(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aColor: Integer;aScrollStyle: TScrollStyle; dwTextFlags: DWORD; aText: WideString); var w: Integer; h: Integer; @@ -168,13 +191,13 @@ begin InflateRect(R, -1, -1); // draw scrolls case aScrollStyle of - ssHorz: DrawScrollBar(aUX, DC, Rect(R.Left, R.Bottom - h, R.Right, R.Bottom), False, False, 2, 0, 100); - ssVert: DrawScrollBar(aUX, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom), False, True, 2, 0, 100); + ssHorz: DrawScrollBar(aUX, False, False, DC, Rect(R.Left, R.Bottom - h, R.Right, R.Bottom), 2, 0, 100); + ssVert: DrawScrollBar(aUX, False, True, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom), 2, 0, 100); ssBoth: begin ThemeServices.DrawElement(DC, ThemeServices.GetElementDetails(tsLowerTrackVertNormal), Rect(R.Left, R.Bottom - h, R.Right, R.Bottom), nil); - DrawScrollBar(aUX, DC, Rect(R.Left, R.Bottom - h, R.Right - w, R.Bottom), False, False, 2, 0, 100); - DrawScrollBar(aUX, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom - h), False, True, 2, 0, 100); + DrawScrollBar(aUX, False, False, DC, Rect(R.Left, R.Bottom - h, R.Right - w, R.Bottom), 2, 0, 100); + DrawScrollBar(aUX, False, True, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom - h), 2, 0, 100); end; end; // draw text @@ -191,13 +214,13 @@ begin DeleteObject(b); // draw scrolls case aScrollStyle of - ssHorz: DrawScrollBar(aUX, DC, Rect(R.Left, R.Bottom - h, R.Right, R.Bottom), False, False, 2, 0, 100); - ssVert: DrawScrollBar(aUX, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom), False, True, 2, 0, 100); + ssHorz: DrawScrollBar(aUX, False, False, DC, Rect(R.Left, R.Bottom - h, R.Right, R.Bottom), 2, 0, 100); + ssVert: DrawScrollBar(aUX, False, True, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom), 2, 0, 100); ssBoth: begin FillRect(DC, Rect(R.Left, R.Bottom - h, R.Right, R.Bottom), GetSysColorBrush(COLOR_BTNFACE)); - DrawScrollBar(aUX, DC, Rect(R.Left, R.Bottom - h, R.Right - w, R.Bottom), False, False, 2, 0, 100); - DrawScrollBar(aUX, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom - h), False, True, 2, 0, 100); + DrawScrollBar(aUX, False, False, DC, Rect(R.Left, R.Bottom - h, R.Right - w, R.Bottom), 2, 0, 100); + DrawScrollBar(aUX, False, True, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom - h), 2, 0, 100); end; end; // draw text @@ -261,10 +284,11 @@ begin ThemeServices.DrawText(DC, d, aText, r, DT_LEFT, 0); end; -procedure DrawRadiobox(aUX: Boolean; DC: HDC; R: TRect; aEnabled, aChecked, aHasBorder: Boolean; aText: WideString); +procedure DrawRadiobox(aUX, aEnabled, aChecked, aHasBorder: Boolean; DC: HDC; R: TRect; aText: WideString); const //enb chk arrFlags: array[Boolean, Boolean] of DWORD = - ((DFCS_INACTIVE, DFCS_CHECKED or DFCS_INACTIVE), (0, DFCS_CHECKED)); + ((DFCS_INACTIVE, DFCS_CHECKED or DFCS_INACTIVE), + (0, DFCS_CHECKED)); //enb chk arrThemedRB: array[Boolean, Boolean] of TThemedButton = ((tbRadioButtonUncheckedDisabled, tbRadioButtonCheckedDisabled), @@ -303,7 +327,7 @@ begin end; end; -procedure DrawListBox(aUX: Boolean; DC: HDC; R: TRect; aEnabled: Boolean; aText: WideString); +procedure DrawListBox(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aText: WideString); begin if ThemeServices.ThemesAvailable and aUX then begin // draw element @@ -326,42 +350,44 @@ begin end; end; -procedure DrawTreeView(aUX: Boolean; DC: HDC; R: TRect; aEnabled: Boolean; aText: WideString); +procedure DrawTreeView(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aText: WideString); begin - DrawListBox(aUX, DC, R, aEnabled, aText); + DrawListBox(aUX, aEnabled, DC, R, aText); end; -procedure DrawListView(aUX: Boolean; DC: HDC; R: TRect; aEnabled: Boolean; aColumns: KOLWideString); +procedure DrawListView(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aCols: ArrayTCDLVColumn); +const + HEAD_HEIGHT = 20; + CXL = 8; //! + CXR = 6; //! + var - w: WideString; + i: Integer; d: TThemedElementDetails; + f: DWORD; begin // draw main - DrawListBox(aUX, DC, R, aEnabled, ''); + DrawListBox(aUX, aEnabled, DC, R, ''); // columns - if (aColumns <> '') then begin + if (Length(aCols) > 0) then begin // draw head back - R := Bounds(2, 2, R.Right - 4, 20); + R := Bounds(2, 2, R.Right - 4, HEAD_HEIGHT); ThemeServices.DrawElement(DC, ThemeServices.GetElementDetails(thHeaderRoot), R, nil); // draw columns - R := Bounds(2, 2, 50, 20); - repeat - w := ParseW(aColumns, #13); - if (aColumns = '') and (w = '') then - Break - else begin - // get element - d := ThemeServices.GetElementDetails(thHeaderItemNormal); - // draw head column - ThemeServices.DrawElement(DC, d, R, nil); - // draw text - Inc(R.Left, 10); - ThemeServices.DrawText(DC, d, w, R, DT_LEFT or DT_VCENTER or DT_SINGLELINE, 0); - // next - Inc(R.Left, 40); - Inc(R.Right, 50); - end; - until False; + for i := 0 to High(aCols) do begin + // get element + d := ThemeServices.GetElementDetails(thHeaderItemNormal); + // draw head column + R.Right := R.Left + aCols[i].Width; + ThemeServices.DrawElement(DC, d, R, nil); + // draw text + Inc(R.Left, CXL); + Dec(R.Right, CXR); + f := TextHFlags[aCols[i].TextAlign] or DT_VCENTER or DT_SINGLELINE; + ThemeServices.DrawText(DC, d, aCols[i].Caption, R, f, 0); + // next + R.Left := R.Right + CXR; + end; end; end; @@ -426,35 +452,54 @@ begin FillRect(DC, R, GetSysColorBrush(COLOR_BTNFACE)); DrawEdge(DC, R, EDGE_SUNKEN, BF_RECT or BF_ADJUST); case aScrollStyle of - ssHorz: DrawScrollBar(aUX, DC, Rect(R.Left, R.Bottom - h, R.Right, R.Bottom), True, False, 2, 0, 100); - ssVert: DrawScrollBar(aUX, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom), True, True, 2, 0, 100); + ssHorz: DrawScrollBar(aUX, True, False, DC, Rect(R.Left, R.Bottom - h, R.Right, R.Bottom), 2, 0, 100); + ssVert: DrawScrollBar(aUX, True, True, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom), 2, 0, 100); ssBoth: begin - DrawScrollBar(aUX, DC, Rect(R.Left, R.Bottom - h, R.Right - w, R.Bottom), True, False, 2, 0, 100); - DrawScrollBar(aUX, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom - h), True, True, 2, 0, 100); + DrawScrollBar(aUX, True, False, DC, Rect(R.Left, R.Bottom - h, R.Right - w, R.Bottom), 2, 0, 100); + DrawScrollBar(aUX, True, True, DC, Rect(R.Right - w, R.Top, R.Right, R.Bottom - h), 2, 0, 100); end; end; end; -// not yet -procedure DrawToolbar(aUX: Boolean; DC: HDC; R: TRect; aEnabled: Boolean; aText: WideString); +procedure DrawToolbar(aUX, aEnabled: Boolean; DC: HDC; R: TRect; aBtns: ArrayTCDTBButton); +const // enb, sep + arrTTB: array[Boolean, Boolean] of TThemedToolBar = ( + (ttbButtonDisabled, ttbSeparatorDisabled), + (ttbButtonNormal, ttbSeparatorNormal) + ); + var + i: Integer; d: TThemedElementDetails; begin if ThemeServices.ThemesAvailable and aUX then begin - // get element - d := ThemeServices.GetElementDetails(ttbToolBarRoot); - // draw element - ThemeServices.DrawElement(DC, d, R, nil); - - // get element - d := ThemeServices.GetElementDetails(ttbSplitButtonNormal); - // draw element - ThemeServices.DrawElement(DC, d, R, nil); - // text - ThemeServices.DrawText(DC, d, aText, R, 0, 0); + // draw background + ThemeServices.DrawElement(DC, ThemeServices.GetElementDetails(ttbToolBarRoot), R, nil); + // draw buttons + for i := 0 to High(aBtns) do begin + // get element + if aBtns[i].Checked then + d := ThemeServices.GetElementDetails(ttbButtonChecked) + else + d := ThemeServices.GetElementDetails(arrTTB[aBtns[i].Enabled, aBtns[i].Separator]); + // draw element + ThemeServices.DrawElement(DC, d, aBtns[i].Rect, nil); + // draw text + ThemeServices.DrawText(DC, d, aBtns[i].Caption, aBtns[i].Rect, 0, 0); + end; end else begin - + // draw background + FillRect(DC, R, GetSysColorBrush(COLOR_BTNFACE)); + // draw buttons + for i := 0 to High(aBtns) do begin + if aBtns[i].Separator then + Windows.Rectangle(DC, aBtns[i].Rect.Left, aBtns[i].Rect.Top, aBtns[i].Rect.Right, aBtns[i].Rect.Bottom) + else begin + DrawEdge(DC, aBtns[i].Rect, BDR_RAISEDINNER, BF_RECT); + DrawTextW(DC, PWideChar(aBtns[i].Caption), Length(aBtns[i].Caption), aBtns[i].Rect, DT_LEFT); + end; + end; end; end; diff --git a/mckCtrls.pas b/mckCtrls.pas index 0f3c3db..48d1859 100644 --- a/mckCtrls.pas +++ b/mckCtrls.pas @@ -39,9 +39,9 @@ interface {$I KOLDEF.INC} -uses KOL, Classes, Forms, Controls, Dialogs, Windows, Messages, extctrls, - stdctrls, comctrls, CommCtrl, SysUtils, Graphics, mirror, ShellAPI, - mckObjs, +uses + KOL, Classes, Forms, Controls, Dialogs, Windows, Messages, extctrls, stdctrls, + comctrls, CommCtrl, SysUtils, Graphics, mirror, ShellAPI, mckObjs, ////////////////////////////////////////////////// {$IFDEF _D6orHigher} // DesignIntf, DesignEditors, DesignConst, // @@ -51,8 +51,7 @@ uses KOL, Classes, Forms, Controls, Dialogs, Windows, Messages, extctrls, DsgnIntf, ////////////////////////////////////////////////////////// {$ENDIF} // - mckToolbarEditor, mckLVColumnsEditor - ; + mckToolbarEditor, mckLVColumnsEditor; type @@ -72,20 +71,13 @@ type public function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function GenerateTransparentInits: String; override; - procedure GenerateTransparentInits_Compact; override; - function P_GenerateTransparentInits: String; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupColor( SL: TStrings; const AName: String ); override; - procedure P_SetupColor( SL: TStrings; const AName: String; var ControlInStack: Boolean ); override; - procedure SetupFont( SL: TStrings; const AName: String ); override; - procedure P_SetupFont( SL: TStrings; const AName: String ); override; - procedure SetupTextAlign( SL: TStrings; const AName: String ); override; - procedure P_SetupTextAlign( SL: TStrings; const AName: String ); override; + function GenerateTransparentInits: string; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupColor(SL: TStrings; const AName: string); override; + procedure SetupFont(SL: TStrings; const AName: string); override; + procedure SetupTextAlign(SL: TStrings; const AName: string); override; function ClientMargins: TRect; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; function CanNotChangeFontColor: Boolean; override; function DefaultParentColor: Boolean; override; function CanChangeColor: Boolean; override; @@ -93,18 +85,17 @@ type function WYSIWIGPaintImplemented: Boolean; override; function NoDrawFrame: Boolean; override; procedure CreateKOLControl(Recreating: boolean); override; - function ImageResourceName: String; - function TypeName: String; override; - procedure DefineProperties( Filer: TFiler ); override; - procedure LoadImageIcon( Reader: TReader ); - procedure SaveImageIcon( Writer: TWriter ); - procedure LoadImageBitmap( Reader: TReader ); - procedure SaveImageBitmap( Writer: TWriter ); + function ImageResourceName: string; + function TypeName: string; override; + procedure DefineProperties(Filer: TFiler); override; + procedure LoadImageIcon(Reader: TReader); + procedure SaveImageIcon(Writer: TWriter); + procedure LoadImageBitmap(Reader: TReader); + procedure SaveImageBitmap(Writer: TWriter); procedure Loaded; override; public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - function Pcode_Generate: Boolean; override; published property Border; property TextAlign; @@ -128,11 +119,8 @@ type property Flat: Boolean read FFlat write SetFlat; // only for not windowed ? property WordWrap; property LikeSpeedButton; - property AllowBitmapCompression: Boolean read FAllowBitmapCompression write SetAllowBitmapCompression - default TRUE; - public - procedure SetupConstruct_Compact; override; - function SupportsFormCompact: Boolean; override; + property AllowBitmapCompression: Boolean read FAllowBitmapCompression write + SetAllowBitmapCompression default TRUE; end; //============================================================================ @@ -172,30 +160,20 @@ type public function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function GenerateTransparentInits: String; override; - procedure GenerateTransparentInits_Compact; override; - function P_GenerateTransparentInits: String; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupTextAlign( SL: TStrings; const AName: String ); override; - procedure P_SetupTextAlign( SL: TStrings; const AName: String ); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; override; + function GenerateTransparentInits: string; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupTextAlign(SL: TStrings; const AName: string); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; function ClientMargins: TRect; override; procedure AutoSizeNow; override; procedure CreateKOLControl(Recreating: boolean); override; function NoDrawFrame: Boolean; override; public - constructor Create( AOwner: TComponent ); override; - procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + constructor Create(AOwner: TComponent); override; + procedure NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); override; destructor Destroy; override; - function Pcode_Generate: Boolean; override; function OptionsAsInteger: Integer; - procedure SetupConstruct_Compact; override; - function SupportsFormCompact: Boolean; override; published property options: TBitBtnOptions read FOptions write SetOptions; property glyphBitmap: TBitmap read FGlyphBitmap write SetGlyphBitmap; @@ -231,32 +209,10 @@ type property Brush; property action; property LikeSpeedButton; - property AllowBitmapCompression: Boolean read FAllowBitmapCompression write SetAllowBitmapCompression - default TRUE; + property AllowBitmapCompression: Boolean read FAllowBitmapCompression write + SetAllowBitmapCompression default TRUE; end; - - - - - - - - - - - - - - - - - - - - - - //============================================================================ //---- MIRROR FOR A LABEL ---- //---- ЗЕРКАЛО ДЛЯ МЕТКИ ---- @@ -267,29 +223,19 @@ type procedure Set_VertAlign(const Value: TVerticalAlign); procedure SetShowAccelChar(const Value: Boolean); public - function AdjustVerticalAlign( Value: TVerticalAlign ): TVerticalAlign; virtual; + function AdjustVerticalAlign(Value: TVerticalAlign): TVerticalAlign; virtual; procedure FirstCreate; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nParams: Integer ): String; override; - function P_GenerateTransparentInits: String; override; - - procedure SetupTextAlign( SL: TStrings; const AName: String ); override; - procedure P_SetupTextAlign( SL: TStrings; const AName: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupTextAlign(SL: TStrings; const AName: string); override; function GetTabOrder: Integer; override; - function TypeName: String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); - override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); - override; + function TypeName: string; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; procedure CallInheritedPaint; procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; procedure Loaded; override; public - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; - procedure SetupConstruct_Compact; override; - function SupportsFormCompact: Boolean; override; + constructor Create(AOwner: TComponent); override; published property Transparent; property TextAlign; @@ -302,32 +248,26 @@ type property windowed; end; - //============================================================================ //---- MIRROR FOR A LABEL EFFECT ---- //---- ЗЕРКАЛО ДЛЯ МЕТКИ С ЭФФЕКТАМИ ---- - TKOLLabelEffect = class( TKOLLabel ) + TKOLLabelEffect = class(TKOLLabel) private FShadowDeep: Integer; FColor2: TColor; procedure SetShadowDeep(const Value: Integer); procedure SetColor2(const Value: TColor); public - function AdjustVerticalAlign( Value: TVerticalAlign ): TVerticalAlign; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupTextAlign( SL: TStrings; const AName: String ); override; - procedure P_SetupTextAlign( SL: TStrings; const AName: String ); override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - function AutoWidth( Canvas: graphics.TCanvas ): Integer; override; - function AutoHeight( Canvas: graphics.TCanvas ): Integer; override; + function AdjustVerticalAlign(Value: TVerticalAlign): TVerticalAlign; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupTextAlign(SL: TStrings; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + function AutoWidth(Canvas: graphics.TCanvas): Integer; override; + function AutoHeight(Canvas: graphics.TCanvas): Integer; override; procedure Paint; override; - procedure SetWindowed( const Value: Boolean ); override; + procedure SetWindowed(const Value: Boolean); override; public - constructor Create( AOwner: TComponent ); override; - procedure SetupConstruct_Compact; override; - function SupportsFormCompact: Boolean; override; + constructor Create(AOwner: TComponent); override; published property ShadowDeep: Integer read FShadowDeep write SetShadowDeep; property Color2: TColor read FColor2 write SetColor2; @@ -338,22 +278,6 @@ type property HasBorder; end; - - - - - - - - - - - - - - - - //============================================================================ //---- MIRROR FOR A PANEL ---- //---- ЗЕРКАЛО ДЛЯ ПАНЕЛИ ---- @@ -366,27 +290,20 @@ type protected function Get_VA: TVerticalAlign; procedure Set_VA(const Value: TVerticalAlign); virtual; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupConstruct( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupConstruct( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupTextAlign( SL: TStrings; const AName: String ); override; - procedure P_SetupTextAlign( SL: TStrings; const AName: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupTextAlign(SL: TStrings; const AName: string); override; function ClientMargins: TRect; override; - function RefName: String; override; + function RefName: string; override; public procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; function NoDrawFrame: Boolean; override; procedure SetCaption(const Value: TDelphiString); override; public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; published property Transparent; property TextAlign; @@ -409,20 +326,17 @@ type TKOLMDIClient = class(TKOLControl) private FTimer: TTimer; - procedure Tick( Sender: TObject ); + procedure Tick(Sender: TObject); protected - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - function Pcode_Generate: Boolean; override; published property TabOrder; property OverrideScrollbars; end; - //=========================================================================== //---- MIRROR FOR A GRADIENT PANEL //---- ЗЕРКАЛО ДЛЯ ГРАДИЕНТНОЙ ПАНЕЛИ @@ -438,20 +352,15 @@ type procedure SetgradientStyle(const Value: KOL.TGradientStyle); protected function TabStopByDefault: Boolean; override; - function TypeName: String; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + function TypeName: string; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; public procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; function NoDrawFrame: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; public - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; + constructor Create(AOwner: TComponent); override; published property Transparent; property Color1: TColor read FColor1 write SetColor1; @@ -468,12 +377,10 @@ type property HasBorder; end; - - //=========================================================================== //---- MIRROR FOR A SPLITTER //---- ЗЕРКАЛО ДЛЯ РАЗДЕЛИТЕЛЯ - TKOLSplitter = class( TKOLControl ) + TKOLSplitter = class(TKOLControl) private FMinSizePrev: Integer; FMinSizeNext: Integer; @@ -486,21 +393,16 @@ type procedure SetEdgeStyle(const Value: TEdgeStyle); protected function IsCursorDefault: Boolean; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - function TypeName: String; override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + function TypeName: string; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; public - function BestEventName: String; override; + function BestEventName: string; override; procedure CreateKOLControl(Recreating: boolean); override; function NoDrawFrame: Boolean; override; public - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; + constructor Create(AOwner: TComponent); override; published property Transparent; property MinSizePrev: Integer read FMinSizePrev write SetMinSizePrev; @@ -514,36 +416,28 @@ type property Brush; end; - - //=========================================================================== //---- MIRROR FOR A GROUPBOX //---- ЗЕРКАЛО ДЛЯ ГРУППЫ - TKOLGroupBox = class( TKOLControl ) + TKOLGroupBox = class(TKOLControl) private protected function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; public - function P_GenerateTransparentInits: String; override; function ClientMargins: TRect; override; function DrawMargins: TRect; override; {$IFDEF _KOLCtrlWrapper_} {YS} procedure CreateKOLControl(Recreating: boolean); override; {$ENDIF} - procedure SetupTextAlign( SL: TStrings; const AName: String ); override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; + procedure SetupTextAlign(SL: TStrings; const AName: string); override; public //dufa function WYSIWIGPaintImplemented: Boolean; override; procedure Paint; override; - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; + constructor Create(AOwner: TComponent); override; published property Transparent; property TabOrder; @@ -562,7 +456,7 @@ type //=========================================================================== //---- MIRROR FOR A CHECKBOX //---- ЗЕРКАЛО ДЛЯ ФЛАЖКА - TKOLCheckBox = class( TKOLControl ) + TKOLCheckBox = class(TKOLControl) private FChecked: Boolean; FAuto3State: Boolean; @@ -571,22 +465,16 @@ type protected function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; public - function P_GenerateTransparentInits: String; override; procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; function NoDrawFrame: Boolean; override; procedure CreateKOLControl(Recreating: boolean); override; - function TypeName: String; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; + function TypeName: string; override; public - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; + constructor Create(AOwner: TComponent); override; published property Transparent; property Checked: Boolean read FChecked write SetChecked; @@ -611,31 +499,24 @@ type property LikeSpeedButton; end; - //=========================================================================== //---- MIRROR FOR A RADIOBOX //---- ЗЕРКАЛО ДЛЯ РАДИО-ФЛАЖКА - TKOLRadioBox = class( TKOLControl ) + TKOLRadioBox = class(TKOLControl) private FChecked: Boolean; procedure SetChecked(const Value: Boolean); protected function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; public - function P_GenerateTransparentInits: String; override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; function NoDrawFrame: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; public - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; + constructor Create(AOwner: TComponent); override; published property Transparent; property Checked: Boolean read FChecked write SetChecked; @@ -670,11 +551,11 @@ type //---- MIRROR FOR AN EDITBOX //---- ЗЕРКАЛО ДЛЯ ОКНА ВВОДА TKOLEditOption = ( {eoNoHScroll, eoNoVScroll,} eoLowercase, {eoMultiline,} - eoNoHideSel, eoOemConvert, eoPassword, eoReadonly, - eoUpperCase, eoWantTab, eoNumber ); - TKOLEditOptions = Set of TKOLEditOption; + eoNoHideSel, eoOemConvert, eoPassword, eoReadonly, eoUpperCase, eoWantTab, eoNumber); - TKOLEditBox = class( TKOLControl ) + TKOLEditOptions = set of TKOLEditOption; + + TKOLEditBox = class(TKOLControl) private FOptions: TKOLEditOptions; FEdTransparent: Boolean; @@ -688,26 +569,20 @@ type protected function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; public - procedure WantTabs( Want: Boolean ); override; + procedure WantTabs(Want: Boolean); override; function DefaultColor: TColor; override; - function BestEventName: String; override; - procedure SetupTextAlign(SL: TStrings; const AName: String); override; - procedure P_SetupTextAlign(SL: TStrings; const AName: String); override; + function BestEventName: string; override; + procedure SetupTextAlign(SL: TStrings; const AName: string); override; function SetupColorFirst: Boolean; override; - procedure SetupSetUnicode( SL: TStringList; const AName: String ); override; + procedure SetupSetUnicode(SL: TStringList; const AName: string); override; public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; function NoDrawFrame: Boolean; override; - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; published property Transparent: Boolean read FEdTransparent write SetEdTransparent; property Text: TDelphiString read GetText write SetText; @@ -738,9 +613,8 @@ type //=========================================================================== //---- MIRROR FOR A MEMO //---- ЗЕРКАЛО ДЛЯ МНОГОСТРОЧНОГО ОКНА ВВОДА - TKOLMemoOption = ( eo_NoHScroll, eo_NoVScroll, eo_Lowercase, {eoMultiline,} - eo_NoHideSel, eo_OemConvert, eo_Password, eo_Readonly, - eo_UpperCase, eo_WantReturn, eo_WantTab ); + TKOLMemoOption = (eo_NoHScroll, eo_NoVScroll, eo_Lowercase, {eoMultiline,} + eo_NoHideSel, eo_OemConvert, eo_Password, eo_Readonly, eo_UpperCase, eo_WantReturn, eo_WantTab); // Character '_' is used to prevent conflict of option names // with the same in TKOLEditOption type. Fortunately, we never // should to use these names in run-time code of the project. @@ -749,16 +623,17 @@ type // именами таких же опций для типа TKOLEditOption. К счастью, // нам эти имена никогда не понадобятся при написании конечного // кода. - TKOLMemoOptions = Set of TKOLMemoOption; - TKOLMemo = class( TKOLControl ) + TKOLMemoOptions = set of TKOLMemoOption; + + TKOLMemo = class(TKOLControl) private FOptions: TKOLMemoOptions; FLines: TStrings; FEdTransparent: Boolean; FUnicode: Boolean; procedure SetOptions(const Value: TKOLMemoOptions); - function GetCaption: String; + function GetCaption: string; procedure SetText(const Value: TStrings); function GetText: TStrings; procedure SetEdTransparent(const Value: Boolean); @@ -766,33 +641,27 @@ type protected function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; function DefaultColor: TColor; override; public - function BestEventName: String; override; + function BestEventName: string; override; procedure CreateKOLControl(Recreating: boolean); override; procedure KOLControlRecreated; override; function NoDrawFrame: Boolean; override; procedure Loaded; override; procedure SetTextAlign(const Value: TTextAlign); override; - procedure SetupTextAlign(SL: TStrings; const AName: String); override; - procedure P_SetupTextAlign(SL: TStrings; const AName: String); override; + procedure SetupTextAlign(SL: TStrings; const AName: string); override; function SetupColorFirst: Boolean; override; - procedure SetupSetUnicode( SL: TStringList; const AName: String ); override; + procedure SetupSetUnicode(SL: TStringList; const AName: string); override; public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; //dufa procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; - function TypeName: String; override; - procedure WantTabs( Want: Boolean ); override; - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; + function TypeName: string; override; + procedure WantTabs(Want: Boolean); override; published property Transparent: Boolean read FEdTransparent write SetEdTransparent; property Text: TStrings read GetText write SetText; @@ -802,7 +671,7 @@ type property Options: TKOLMemoOptions read FOptions write SetOptions; property OnChange; property OnSelChange; - property Caption: String read GetCaption; // redefined as read only to remove from Object Inspector + property Caption: string read GetCaption; // redefined as read only to remove from Object Inspector property OnKeyDown; property OnKeyUp; property OnChar; @@ -825,9 +694,9 @@ type //=========================================================================== //---- MIRROR FOR A RICHEDIT //---- ЗЕРКАЛО ДЛЯ РЕДАКТОРА - TKOLRichEditVersion = ( ver1, ver3 ); + TKOLRichEditVersion = (ver1, ver3); - TKOLRichEdit = class( TKOLControl ) + TKOLRichEdit = class(TKOLControl) private FOptions: TKOLMemoOptions; FLines: TStrings; @@ -851,7 +720,7 @@ type function GetText: TStrings; procedure SetText(const Value: TStrings); procedure SetOptions(const Value: TKOLMemoOptions); - function GetCaption: String; + function GetCaption: string; procedure Setversion(const Value: TKOLRichEditVersion); procedure SetMaxTextSize(const Value: DWORD); procedure SetRE_FmtStandard(const Value: Boolean); @@ -872,38 +741,29 @@ type protected function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - function TypeName: String; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + function TypeName: string; override; public - function GenerateTransparentInits: String; override; - procedure GenerateTransparentInits_Compact; override; - function P_GenerateTransparentInits: String; override; - procedure BeforeFontChange( SL: TStrings; const AName, Prefix: String ); override; - procedure P_BeforeFontChange( SL: TStrings; const AName, Prefix: String ); override; - function FontPropName: String; override; - procedure AfterFontChange( SL: TStrings; const AName, Prefix: String ); override; - procedure P_AfterFontChange( SL: TStrings; const AName, Prefix: String ); override; - procedure WantTabs( Want: Boolean ); override; + function GenerateTransparentInits: string; override; + procedure BeforeFontChange(SL: TStrings; const AName, Prefix: string); override; + function FontPropName: string; override; + procedure AfterFontChange(SL: TStrings; const AName, Prefix: string); override; + procedure WantTabs(Want: Boolean); override; function DefaultColor: TColor; override; - function AdditionalUnits: String; override; - function BestEventName: String; override; + function AdditionalUnits: string; override; + function BestEventName: string; override; procedure CreateKOLControl(Recreating: boolean); override; procedure KOLControlRecreated; override; procedure Loaded; override; function NoDrawFrame: Boolean; override; function SetupColorFirst: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; public //dufa function WYSIWIGPaintImplemented: Boolean; override; procedure Paint; override; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - function Pcode_Generate: Boolean; override; published property Transparent read FRE_Transparent write SetRE_Transparent; property RE_Transparent: Boolean read FRE_Transparent write SetRE_Transparent; @@ -913,7 +773,7 @@ type property Options: TKOLMemoOptions read FOptions write SetOptions; property OnChange; property OnSelChange; - property Caption: String read GetCaption; // redefined as read only to remove from Object Inspector + property Caption: string read GetCaption; // redefined as read only to remove from Object Inspector property OnKeyDown; property OnKeyUp; property OnChar; @@ -924,7 +784,8 @@ type property OnRE_URLClick; property OnRE_OverURL; property OnRE_InsOvrMode_Change; - property RE_DisableOverwriteChange: Boolean read FRE_DisableOverwriteChange write SetRE_DisableOverwriteChange; + property RE_DisableOverwriteChange: Boolean read FRE_DisableOverwriteChange + write SetRE_DisableOverwriteChange; property MaxTextSize: DWORD read FMaxTextSize write SetMaxTextSize; property RE_FmtStandard: Boolean read FRE_FmtStandard write SetRE_FmtStandard; property RE_AutoKeyboard: Boolean read FRE_AutoKeyboard write SetRE_AutoKeyboard; @@ -956,13 +817,13 @@ type //=========================================================================== //---- MIRROR FOR A LISTBOX //---- ЗЕРКАЛО ДЛЯ СПИСКА - TKOLListboxOption = ( loNoHideScroll, loNoExtendSel, loMultiColumn, loMultiSelect, - loNoIntegralHeight, loNoSel, loSort, loTabstops, - loNoStrings, loNoData, loOwnerDrawFixed, loOwnerDrawVariable, - loHScroll ); - TKOLListboxOptions = Set of TKOLListboxOption; + TKOLListboxOption = (loNoHideScroll, loNoExtendSel, loMultiColumn, + loMultiSelect, loNoIntegralHeight, loNoSel, loSort, loTabstops, loNoStrings, + loNoData, loOwnerDrawFixed, loOwnerDrawVariable, loHScroll); - TKOLListBox = class( TKOLControl ) + TKOLListboxOptions = set of TKOLListboxOption; + + TKOLListBox = class(TKOLControl) private FOptions: TKOLListboxOptions; FItems: TStrings; @@ -974,37 +835,29 @@ type procedure SetOptions(const Value: TKOLListboxOptions); procedure SetItems(const Value: TStrings); procedure SetCurIndex(const Value: Integer); - function GetCaption: String; + function GetCaption: string; procedure SetCount(Value: Integer); procedure UpdateItems; procedure SetAlwaysAssignItems(const Value: Boolean); protected function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; function DefaultColor: TColor; override; public procedure CreateKOLControl(Recreating: boolean); override; procedure KOLControlRecreated; override; function NoDrawFrame: Boolean; override; procedure Loaded; override; - function GenerateTransparentInits: String; override; {+ecm} - procedure GenerateTransparentInits_Compact; override; {+ecm} - function P_GenerateTransparentInits: String; override; {+ecm} - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; + function GenerateTransparentInits: string; override; {+ecm} public //dufa procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - function Pcode_Generate: Boolean; override; published property Transparent; property TabStop; @@ -1018,7 +871,7 @@ type property OnChar; property OnKeyChar; property OnKeyDeadChar; - property Caption: String read GetCaption; // hide Caption in Object Inspector + property Caption: string read GetCaption; // hide Caption in Object Inspector property OnDrawItem; property OnMeasureItem; property Count: Integer read FCount write SetCount; @@ -1041,12 +894,12 @@ type //=========================================================================== //---- MIRROR FOR A COMBOBOX //---- ЗЕРКАЛО ДЛЯ ВЫПАДАЮЩЕГО СПИСКА - TKOLComboOption = ( coReadOnly, coNoHScroll, coAlwaysVScroll, coLowerCase, - coNoIntegralHeight, coOemConvert, coSort, coUpperCase, - coOwnerDrawFixed, coOwnerDrawVariable, coSimple ); - TKOLComboOptions = Set of TKOLComboOption; + TKOLComboOption = (coReadOnly, coNoHScroll, coAlwaysVScroll, coLowerCase, + coNoIntegralHeight, coOemConvert, coSort, coUpperCase, coOwnerDrawFixed, coOwnerDrawVariable, coSimple); - TKOLComboBox = class( TKOLControl ) + TKOLComboOptions = set of TKOLComboOption; + + TKOLComboBox = class(TKOLControl) private FOptions: TKOLComboOptions; FItems: TStrings; @@ -1063,10 +916,8 @@ type protected function TabStopByDefault: Boolean; override; procedure FirstCreate; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; function DefaultColor: TColor; override; function DefaultInitialColor: TColor; override; procedure SetAlign(const Value: TKOLAlign); override; @@ -1074,17 +925,12 @@ type procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; function NoDrawFrame: Boolean; override; - function AutoHeight( Canvas: graphics.TCanvas ): Integer; override; + function AutoHeight(Canvas: graphics.TCanvas): Integer; override; function AutoSizeRunTime: Boolean; override; - function GenerateTransparentInits: String; override; {+ecm} - procedure GenerateTransparentInits_Compact; override; {+ecm} - function P_GenerateTransparentInits: String; override; {+ecm} + function GenerateTransparentInits: string; override; {+ecm} public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; published property Transparent; property TabStop; @@ -1113,25 +959,18 @@ type property AlwaysAssignItems: Boolean read FAlwaysAssignItems write SetAlwaysAssignItems; end; - - - //=========================================================================== //---- MIRROR FOR A PAINTBOX //---- ЗЕРКАЛО ДЛЯ МОЛЬБЕРТА - TKOLPaintBox = class( TKOLControl ) + TKOLPaintBox = class(TKOLControl) private fNotAvailable: Boolean; protected - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; public - function BestEventName: String; override; + function BestEventName: string; override; public - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; + constructor Create(AOwner: TComponent); override; published property Transparent; property OnPaint; @@ -1145,12 +984,10 @@ type property windowed; end; - - //=========================================================================== //---- MIRROR FOR A IMAGESHOW //---- ЗЕРКАЛО ДЛЯ КАРТИНКИ - TKOLImageShow = class( TKOLControl ) + TKOLImageShow = class(TKOLControl) private FCurIndex: Integer; FImageListNormal: TKOLImageList; @@ -1161,25 +998,20 @@ type procedure SetImageListNormal(const Value: TKOLImageList); procedure SetImgShwAutoSize(const Value: Boolean); protected - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; procedure DoAutoSize; procedure SetHasBorder(const Value: Boolean); override; public procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; function NoDrawFrame: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; public - function Pcode_Generate: Boolean; override; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; - procedure SetBounds( aLeft, aTop, aWidth, aHeight: Integer ); override; + procedure NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); override; + procedure SetBounds(aLeft, aTop, aWidth, aHeight: Integer); override; published property ImageListNormal: TKOLImageList read FImageListNormal write SetImageListNormal; property CurIndex: Integer read FCurIndex write SetCurIndex; @@ -1196,7 +1028,7 @@ type //=========================================================================== //---- MIRROR FOR A PROGRESSBAR //---- ЗЕРКАЛО ДЛЯ ЛИНЕЙКИ ПРОГРЕССА - TKOLProgressBar = class( TKOLControl ) + TKOLProgressBar = class(TKOLControl) private FVertical: Boolean; FSmooth: Boolean; @@ -1214,11 +1046,9 @@ type function GetColor: TColor; procedure SetColor(const Value: TColor); protected - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - function TypeName: String; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + function TypeName: string; override; public procedure CreateKOLControl(Recreating: boolean); override; procedure KOLControlRecreated; override; @@ -1227,10 +1057,7 @@ type //dufa procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; + constructor Create(AOwner: TComponent); override; published property Transparent; property Vertical: Boolean read FVertical write SetVertical; @@ -1249,31 +1076,32 @@ type //=========================================================================== //---- MIRROR FOR A LISTVIEW //---- ЗЕРКАЛО ДЛЯ ПРОСМОТРА СПИСКА / ТАБЛИЦЫ - TKOLListViewStyle = ( lvsIcon, lvsSmallIcon, lvsList, lvsDetail, lvsDetailNoHeader ); + TKOLListViewStyle = (lvsIcon, lvsSmallIcon, lvsList, lvsDetail, lvsDetailNoHeader); - TKOLListViewOption = ( lvoIconLeft, lvoAutoArrange, lvoButton, lvoEditLabel, + TKOLListViewOption = (lvoIconLeft, lvoAutoArrange, lvoButton, lvoEditLabel, lvoNoLabelWrap, lvoNoScroll, lvoNoSortHeader, lvoHideSel, lvoMultiselect, lvoSortAscending, lvoSortDescending, lvoGridLines, lvoSubItemImages, - lvoCheckBoxes, lvoTrackSelect, lvoHeaderDragDrop, lvoRowSelect, lvoOneClickActivate, - lvoTwoClickActivate, lvoFlatsb, lvoRegional, lvoInfoTip, lvoUnderlineHot, - lvoMultiWorkares, lvoOwnerData, lvoOwnerDrawFixed ); - TKOLListViewOptions = Set of TKOLListViewOption; + lvoCheckBoxes, lvoTrackSelect, lvoHeaderDragDrop, lvoRowSelect, + lvoOneClickActivate, lvoTwoClickActivate, lvoFlatsb, lvoRegional, lvoInfoTip, + lvoUnderlineHot, lvoMultiWorkares, lvoOwnerData, lvoOwnerDrawFixed); - TKOLListViewColWidthType = ( lvcwtCustom, lvcwtAutosize, lvcwtAutoSizeCaption ); + TKOLListViewOptions = set of TKOLListViewOption; + + TKOLListViewColWidthType = (lvcwtCustom, lvcwtAutosize, lvcwtAutoSizeCaption); TKOLListView = class; - TKOLListViewColumn = class( TComponent ) + TKOLListViewColumn = class(TComponent) private FListView: TKOLListView; FLVColImage: Integer; FLVColOrder: Integer; FWidth: Integer; - FCaption: String; + FCaption: string; FWidthType: TKOLListViewColWidthType; FTextAlign: TTextAlign; FLVColRightImg: Boolean; - procedure SetCaption(const Value: String); + procedure SetCaption(const Value: string); procedure SetLVColImage(const Value: Integer); procedure SetLVColOrder(const Value: Integer); procedure SetTextAlign(const Value: TTextAlign); @@ -1282,29 +1110,29 @@ type procedure Change; procedure SetLVColRightImg(const Value: Boolean); protected - procedure SetName( const AName: TComponentName ); override; - procedure DefProps( const Prefix: String; Filer: TFiler ); - procedure LoadName( Reader: TReader ); - procedure SaveName( Writer: TWriter ); - procedure LoadCaption( Reader: TReader ); - procedure SaveCaption( Writer: TWriter ); - procedure LoadTextAlign( Reader: TReader ); - procedure SaveTextAlign( Writer: TWriter ); - procedure LoadWidth( Reader: TReader ); - procedure SaveWidth( Writer: TWriter ); - procedure LoadWidthType( Reader: TReader ); - procedure SaveWidthType( Writer: TWriter ); - procedure LoadLVColImage( Reader: TReader ); - procedure SaveLVColImage( Writer: TWriter ); - procedure LoadLVColOrder( Reader: TReader ); - procedure SaveLVColOrder( Writer: TWriter ); - procedure LoadLVColRightImg( Reader: TReader ); - procedure SaveLVColRightImg( Writer: TWriter ); + procedure SetName(const AName: TComponentName); override; + procedure DefProps(const Prefix: string; Filer: TFiler); + procedure LoadName(Reader: TReader); + procedure SaveName(Writer: TWriter); + procedure LoadCaption(Reader: TReader); + procedure SaveCaption(Writer: TWriter); + procedure LoadTextAlign(Reader: TReader); + procedure SaveTextAlign(Writer: TWriter); + procedure LoadWidth(Reader: TReader); + procedure SaveWidth(Writer: TWriter); + procedure LoadWidthType(Reader: TReader); + procedure SaveWidthType(Writer: TWriter); + procedure LoadLVColImage(Reader: TReader); + procedure SaveLVColImage(Writer: TWriter); + procedure LoadLVColOrder(Reader: TReader); + procedure SaveLVColOrder(Writer: TWriter); + procedure LoadLVColRightImg(Reader: TReader); + procedure SaveLVColRightImg(Writer: TWriter); public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; published - property Caption: String read FCaption write SetCaption; + property Caption: string read FCaption write SetCaption; property TextAlign: TTextAlign read FTextAlign write SetTextAlign; property Width: Integer read FWidth write SetWidth; property WidthType: TKOLListViewColWidthType read FWidthType write SetWidthType; @@ -1313,7 +1141,7 @@ type property LVColOrder: Integer read FLVColOrder write SetLVColOrder; end; - TKOLListView = class( TKOLControl ) + TKOLListView = class(TKOLControl) private FOptions: TKOLListViewOptions; FStyle: TKOLListViewStyle; @@ -1334,14 +1162,14 @@ type procedure SetImageListNormal(const Value: TKOLImageList); procedure SetImageListSmall(const Value: TKOLImageList); procedure SetImageListState(const Value: TKOLImageList); - function GetCaption: String; + function GetCaption: string; procedure SetLVCount(Value: Integer); procedure SetLVTextBkColor(const Value: TColor); function GetColor: TColor; procedure SetColor(const Value: TColor); //procedure SetOnLVDelete(const Value: TOnDeleteLVItem); - function GetColumns: String; - procedure SetColumns(const Value: String); + function GetColumns: string; + procedure SetColumns(const Value: string); procedure SetGenerateColIdxConst(const Value: Boolean); procedure SetOnLVCustomDraw(const Value: TOnLVCustomDraw); procedure SetOnLVSubitemDraw(const Value: TOnLVSubitemDraw); @@ -1351,20 +1179,15 @@ type FCols: TList; FColCount: Integer; function TabStopByDefault: Boolean; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; function DefaultColor: TColor; override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; override; - procedure DefineProperties( Filer: TFiler ); override; - procedure LoadColCount( Reader: TReader ); - procedure SaveColCount( Writer: TWriter ); - procedure DoGenerateConstants( SL: TStringList ); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure DefineProperties(Filer: TFiler); override; + procedure LoadColCount(Reader: TReader); + procedure SaveColCount(Writer: TWriter); + procedure DoGenerateConstants(SL: TStringList); override; public //dufa procedure Paint; override; @@ -1374,20 +1197,15 @@ type procedure CreateKOLControl(Recreating: boolean); override; procedure KOLControlRecreated; override; function GetDefaultControlFont: HFONT; override; - function GenerateTransparentInits: String; override; - procedure GenerateTransparentInits_Compact; override; - function P_GenerateTransparentInits: String; override; + function GenerateTransparentInits: string; override; public ActiveDesign: TfmLVColumnsEditor; - constructor Create( AOwner: TComponent ); override; - procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + constructor Create(AOwner: TComponent); override; + procedure NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); override; destructor Destroy; override; property Cols: TList read FCols; function HasOrderedColumns: Boolean; procedure Invalidate; override; {YS} - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; published property Transparent; property Style: TKOLListViewStyle read FStyle write SetStyle; @@ -1401,7 +1219,7 @@ type property OnChar; property OnKeyChar; property OnKeyDeadChar; - property Caption: String read GetCaption; // hide Caption in Object Inspector + property Caption: string read GetCaption; // hide Caption in Object Inspector property OnDeleteLVItem; property OnDeleteAllLVItems; property OnLVData; @@ -1423,13 +1241,13 @@ type property HasBorder; property OnScroll; property TabStop; - property Columns: String read GetColumns write SetColumns stored FALSE; + property Columns: string read GetColumns write SetColumns stored FALSE; property generateConstants: Boolean read FGenerateColIdxConst write SetGenerateColIdxConst; property Brush; property OverrideScrollbars; end; - TKOLLVColumnsEditor = class( TComponentEditor ) + TKOLLVColumnsEditor = class(TComponentEditor) private protected public @@ -1439,7 +1257,7 @@ type function GetVerbCount: Integer; override; end; - TKOLLVColumnsPropEditor = class( TStringProperty ) + TKOLLVColumnsPropEditor = class(TStringProperty) private protected public @@ -1452,13 +1270,13 @@ type //=========================================================================== //---- MIRROR FOR A TREEVIEW //---- ЗЕРКАЛО ДЛЯ ПРОСМОТРА ДЕРЕВА - TKOLTreeViewOption = ( tvoNoLines, tvoLinesRoot, tvoNoButtons, tvoEditLabels, tvoHideSel, - tvoDragDrop, tvoNoTooltips, tvoCheckBoxes, tvoTrackSelect, - tvoSingleExpand, tvoInfoTip, tvoFullRowSelect, tvoNoScroll, - tvoNonEvenHeight ); - TKOLTreeViewOptions = Set of TKOLTreeViewOption; + TKOLTreeViewOption = (tvoNoLines, tvoLinesRoot, tvoNoButtons, tvoEditLabels, + tvoHideSel, tvoDragDrop, tvoNoTooltips, tvoCheckBoxes, tvoTrackSelect, + tvoSingleExpand, tvoInfoTip, tvoFullRowSelect, tvoNoScroll, tvoNonEvenHeight); - TKOLTreeView = class( TKOLControl ) + TKOLTreeViewOptions = set of TKOLTreeViewOption; + + TKOLTreeView = class(TKOLControl) private FOptions: TKOLTreeViewOptions; FCurIndex: Integer; @@ -1474,12 +1292,10 @@ type procedure SetTVIndent(const Value: Integer); protected function TabStopByDefault: Boolean; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; function DefaultColor: TColor; override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; public procedure CreateKOLControl(Recreating: boolean); override; function NoDrawFrame: Boolean; override; @@ -1487,12 +1303,9 @@ type //dufa procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; - constructor Create( AOwner: TComponent ); override; - procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + constructor Create(AOwner: TComponent); override; + procedure NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); override; destructor Destroy; override; - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; published property Transparent; property Options: TKOLTreeViewOptions read FOptions write SetOptions; @@ -1530,31 +1343,24 @@ type //---- ЗЕРКАЛО ДЛЯ ЛИНЕЙКИ КНОПОК TKOLToolbar = class; - TSystemToolbarImage = ( stiCustom, stdCUT, stdCOPY, stdPASTE, stdUNDO, - stdREDO, stdDELETE, stdFILENEW, stdFILEOPEN, - stdFILESAVE, stdPRINTPRE, stdPROPERTIES, - stdHELP, stdFIND, stdREPLACE, stdPRINT, + TSystemToolbarImage = (stiCustom, stdCUT, stdCOPY, stdPASTE, stdUNDO, stdREDO, + stdDELETE, stdFILENEW, stdFILEOPEN, stdFILESAVE, stdPRINTPRE, stdPROPERTIES, + stdHELP, stdFIND, stdREPLACE, stdPRINT, viewLARGEICONS, viewSMALLICONS, + viewLIST, viewDETAILS, viewSORTNAME, viewSORTSIZE, viewSORTDATE, + viewSORTTYPE, viewPARENTFOLDER, viewNETCONNECT, viewNETDISCONNECT, + viewNEWFOLDER, viewVIEWMENU, histBACK, histFORWARD, histFAVORITES, histADDTOFAVORITES, histVIEWTREE); - viewLARGEICONS, viewSMALLICONS, viewLIST, - viewDETAILS, viewSORTNAME, viewSORTSIZE, - viewSORTDATE, viewSORTTYPE, viewPARENTFOLDER, - viewNETCONNECT, viewNETDISCONNECT, viewNEWFOLDER, - viewVIEWMENU, - - histBACK, histFORWARD, histFAVORITES, - histADDTOFAVORITES, histVIEWTREE ); - - TKOLToolbarButton = class( TComponent ) + TKOLToolbarButton = class(TComponent) private FToolbar: TKOLToolbar; Fenabled: Boolean; Fseparator: Boolean; Fvisible: Boolean; Fdropdown: Boolean; - Fcaption: String; - Ftooltip: String; + Fcaption: string; + Ftooltip: string; FonClick: TOnToolbarButtonClick; - fOnClickMethodName: String; + fOnClickMethodName: string; Fpicture: TPicture; Fchecked: Boolean; fNotAvailable: Boolean; @@ -1563,13 +1369,13 @@ type FimgIndex: Integer; Faction: TKOLAction; FCheckable: Boolean; - procedure Setcaption(const Value: String); + procedure Setcaption(const Value: string); procedure Setdropdown(const Value: Boolean); procedure Setenabled(const Value: Boolean); procedure SetonClick(const Value: TOnToolbarButtonClick); procedure Setpicture(Value: TPicture); procedure Setseparator(const Value: Boolean); - procedure Settooltip(const Value: String); + procedure Settooltip(const Value: string); procedure Setvisible(const Value: Boolean); procedure Setchecked(const Value: Boolean); procedure Setsysimg(const Value: TSystemToolbarImage); @@ -1579,39 +1385,39 @@ type procedure SetCheckable(const Value: Boolean); protected procedure Change; - procedure SetName( const NewName: TComponentName ); override; - procedure DefProps( const Prefix: String; Filer: Tfiler ); - procedure LoadName( Reader: TReader ); - procedure SaveName( Writer: TWriter ); - procedure LoadProps( Reader: TReader ); - procedure SaveProps( Writer: TWriter ); - procedure LoadCaption( Reader: TReader ); - procedure SaveCaption( Writer: TWriter ); - procedure LoadChecked( Reader: TReader ); - procedure SaveChecked( Writer: TWriter ); - procedure LoadDropDown( Reader: TReader ); - procedure SaveDropDown( Writer: TWriter ); - procedure LoadEnabled( Reader: TReader ); - procedure SaveEnabled( Writer: TWriter ); - procedure LoadSeparator( Reader: TReader ); - procedure SaveSeparator( Writer: TWriter ); - procedure LoadTooltip( Reader: TReader ); - procedure SaveTooltip( Writer: TWriter ); - procedure LoadVisible( Reader: TReader ); - procedure SaveVisible( Writer: TWriter ); - procedure LoadOnClick( Reader: TReader ); - procedure SaveOnClick( Writer: TWriter ); - procedure LoadPicture( Reader: TReader ); - procedure SavePicture( Writer: TWriter ); - procedure LoadSysImg( Reader: TReader ); - procedure SaveSysImg( Writer: TWriter ); - procedure LoadRadioGroup( Reader: TReader ); - procedure SaveRadioGroup( Writer: TWriter ); - procedure LoadImgIndex( Reader: TReader ); - procedure SaveImgIndex( Writer: TWriter ); + procedure SetName(const NewName: TComponentName); override; + procedure DefProps(const Prefix: string; Filer: Tfiler); + procedure LoadName(Reader: TReader); + procedure SaveName(Writer: TWriter); + procedure LoadProps(Reader: TReader); + procedure SaveProps(Writer: TWriter); + procedure LoadCaption(Reader: TReader); + procedure SaveCaption(Writer: TWriter); + procedure LoadChecked(Reader: TReader); + procedure SaveChecked(Writer: TWriter); + procedure LoadDropDown(Reader: TReader); + procedure SaveDropDown(Writer: TWriter); + procedure LoadEnabled(Reader: TReader); + procedure SaveEnabled(Writer: TWriter); + procedure LoadSeparator(Reader: TReader); + procedure SaveSeparator(Writer: TWriter); + procedure LoadTooltip(Reader: TReader); + procedure SaveTooltip(Writer: TWriter); + procedure LoadVisible(Reader: TReader); + procedure SaveVisible(Writer: TWriter); + procedure LoadOnClick(Reader: TReader); + procedure SaveOnClick(Writer: TWriter); + procedure LoadPicture(Reader: TReader); + procedure SavePicture(Writer: TWriter); + procedure LoadSysImg(Reader: TReader); + procedure SaveSysImg(Writer: TWriter); + procedure LoadRadioGroup(Reader: TReader); + procedure SaveRadioGroup(Writer: TWriter); + procedure LoadImgIndex(Reader: TReader); + procedure SaveImgIndex(Writer: TWriter); procedure Notification(AComponent: TComponent; Operation: TOperation); override; public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; function HasPicture: Boolean; property ToolbarComponent: TKOLToolbar read FToolbar; @@ -1627,17 +1433,17 @@ type property visible: Boolean read Fvisible write Setvisible; property enabled: Boolean read Fenabled write Setenabled; property onClick: TOnToolbarButtonClick read FonClick write SetonClick; - property caption: String read Fcaption write Setcaption; - property tooltip: String read Ftooltip write Settooltip; + property caption: string read Fcaption write Setcaption; + property tooltip: string read Ftooltip write Settooltip; property Tag: Boolean read fNotAvailable; property action: TKOLAction read Faction write Setaction; end; - TKOLToolbar = class( TKOLControl ) + TKOLToolbar = class(TKOLControl) private FOptions: TToolbarOptions; Fbitmap: TBitmap; - Fbuttons: String; + Fbuttons: string; FnoTextLabels: Boolean; Ftooltips: TStrings; FshowTooltips: Boolean; @@ -1658,7 +1464,6 @@ type FTBButtonsWidth: Integer; FgenerateVariables: Boolean; FOnTBCustomDraw: TOnTBCustomDraw; - FCompactCode: Boolean; FAutosizeButtons: Boolean; FNoSpaceForImages: Boolean; FAllowBitmapCompression: Boolean; @@ -1675,7 +1480,7 @@ type procedure SetgenerateConstants(const Value: Boolean); procedure SetbuttonMaxWidth(const Value: Integer); procedure SetbuttonMinWidth(const Value: Integer); - function GetButtons: String; + function GetButtons: string; procedure SetAutoHeight(const Value: Boolean); procedure UpdateButtons; procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST; @@ -1689,7 +1494,6 @@ type procedure SetTBButtonsWidth(const Value: Integer); procedure SetgenerateVariables(const Value: Boolean); procedure SetOnTBCustomDraw(const Value: TOnTBCustomDraw); - procedure SetCompactCode(const Value: Boolean); procedure SetAutosizeButtons(const Value: Boolean); procedure SetNoSpaceForImages(const Value: Boolean); procedure SetAllowBitmapCompression(const Value: Boolean); @@ -1699,23 +1503,20 @@ type FBmpTranColor: TColor; FBmpDesign: HBitmap; ValuesInStack: Integer; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; procedure DefineProperties(Filer: TFiler); override; - procedure ReadNewVersion( Reader: TReader ); - procedure WriteNewVersion( Writer: TWriter ); - procedure LoadButtonCount( R: TReader ); - procedure SaveButtonCount( W: TWriter ); + procedure ReadNewVersion(Reader: TReader); + procedure WriteNewVersion(Writer: TWriter); + procedure LoadButtonCount(R: TReader); + procedure SaveButtonCount(W: TWriter); public procedure Loaded; override; function StandardImagesUsed: Integer; function PicturedButtonsCount: Integer; function ImagedButtonsCount: Integer; - function NoMorePicturedButtonsFrom( Idx: Integer ): Boolean; + function NoMorePicturedButtonsFrom(Idx: Integer): Boolean; function AllPicturedButtonsAreLeading: Boolean; function LastBtnHasPicture: Boolean; procedure CreateKOLControl(Recreating: boolean); override; @@ -1725,31 +1526,26 @@ type procedure Paint; override; function GetDefaultControlFont: HFONT; override; function ImageListsUsed: Boolean; - function ButtonCaptionsList( var Cnt: Integer ): String; - function ButtonImgIndexesList( var Cnt: Integer ): String; - public - function Generate_SetSize: String; override; - function SupportsFormCompact: Boolean; override; - function HasCompactConstructor: Boolean; override; - procedure SetupConstruct_Compact; override; + function ButtonCaptionsList(var Cnt: Integer): string; + function ButtonImgIndexesList(var Cnt: Integer): string; + function Generate_SetSize: string; override; public ActiveDesign: TfmToolbarEditor; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Change; override; - procedure Tick( Sender: TObject ); + procedure Tick(Sender: TObject); property Items: TList read FItems; procedure Items2buttons; - procedure DoGenerateConstants( SL: TStringList ); override; - procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); override; + procedure DoGenerateConstants(SL: TStringList); override; + procedure NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); override; function MaxImgIndex: Integer; - function Pcode_Generate: Boolean; override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; published property Transparent; property Options: TToolbarOptions read FOptions write SetOptions; property bitmap: TBitmap read Fbitmap write Setbitmap; - property buttons: String read GetButtons write Fbuttons; + property buttons: string read GetButtons write Fbuttons; property OnTBDropDown; property OnClick; property OnTBCustomDraw: TOnTBCustomDraw read FOnTBCustomDraw write SetOnTBCustomDraw; @@ -1765,11 +1561,9 @@ type property popupMenu; property Caption: Boolean read fNotAvailable; property HasBorder; - - property ButtonCount: Integer read FButtonCount write SetBtnCount_Dummy - stored FALSE; + property ButtonCount: Integer read FButtonCount write SetBtnCount_Dummy stored FALSE; procedure buttons2Items; - procedure bitmap2ItemPictures( AnyWay: Boolean ); + procedure bitmap2ItemPictures(AnyWay: Boolean); procedure AssembleBitmap; procedure AssembleTooltips; procedure DesembleTooltips; @@ -1782,26 +1576,23 @@ type property HeightAuto: Boolean read FHeightAuto write SetAutoHeight; property Brush; property Ctl3D; - property imageListNormal: TKOLImageList read FimageListNormal write SetimageList; property imageListDisabled: TKOLImageList read FimageListDisabled write SetDisabledimageList; property imageListHot: TKOLImageList read FimageListHot write SetHotimageList; - property FixFlatXP: Boolean read FFixFlatXP write SetFixFlatXP; // If TRUE (default) then some styles are changed in case of XP on start. // This useful (and necessary) only if XP Manifest is used in the application // in other case this property can be set to FALSE to make code smaller // and to prevent "heavy" property TRUE from usage. // This property has effect only for toolbars with tboFlat style though. - property CompactCode: Boolean read FCompactCode write SetCompactCode; property AutosizeButtons: Boolean read FAutosizeButtons write SetAutosizeButtons; property NoSpaceForImages: Boolean read FNoSpaceForImages write SetNoSpaceForImages; property Autosize; - property AllowBitmapCompression: Boolean read FAllowBitmapCompression write SetAllowBitmapCompression - default TRUE; + property AllowBitmapCompression: Boolean read FAllowBitmapCompression write + SetAllowBitmapCompression default TRUE; end; - TKOLToolbarButtonsEditor = class( TStringProperty ) + TKOLToolbarButtonsEditor = class(TStringProperty) private protected public @@ -1809,7 +1600,7 @@ type procedure Edit; override; end; - TKOLToolbarEditor = class( TComponentEditor ) + TKOLToolbarEditor = class(TComponentEditor) private protected public @@ -1819,7 +1610,7 @@ type function GetVerbCount: Integer; override; end; - TKOLToolButtonOnClickPropEditor = class( TMethodProperty ) + TKOLToolButtonOnClickPropEditor = class(TMethodProperty) private FResetting: Boolean; protected @@ -1828,40 +1619,32 @@ type procedure SetValue(const AValue: string); override; end; - //=========================================================================== //---- MIRROR FOR A DATE TIME PICKER //---- ЗЕРКАЛО ДЛЯ ВВОДА ДАТЫ И ВРЕМЕНИ - TKOLDateTimePicker = class( TKOLControl ) + TKOLDateTimePicker = class(TKOLControl) private FOnDTPUserString: KOL.TDTParseInputEvent; FOptions: TDateTimePickerOptions; - FFormat: String; + FFormat: string; FMonthBkColor: TColor; FMonthTxtColor: TColor; procedure SetOnDTPUserString(const Value: KOL.TDTParseInputEvent); procedure SetOptions(const Value: TDateTimePickerOptions); - procedure SetFormat(const Value: String); + procedure SetFormat(const Value: string); procedure SetMonthBkColor(const Value: TColor); procedure SetMonthTxtColor(const Value: TColor); protected - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; - procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; public - function Pcode_Generate: Boolean; override; - constructor Create( AOwner: TComponent ); override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; + constructor Create(AOwner: TComponent); override; published function TabStopByDefault: Boolean; override; property OnDTPUserString: KOL.TDTParseInputEvent read FOnDTPUserString write SetOnDTPUserString; property Options: TDateTimePickerOptions read FOptions write SetOptions; - property Format: String read FFormat write SetFormat; + property Format: string read FFormat write SetFormat; property TabStop; property OnDropDown; property OnCloseUp; @@ -1870,20 +1653,19 @@ type property MonthTxtColor: TColor read FMonthTxtColor write SetMonthTxtColor; end; - - //=========================================================================== //---- MIRROR FOR A TAB CONTROL //---- ЗЕРКАЛО ДЛЯ ТАБУЛИРОВАННОГО БЛОКНОТА TKOLTabPage = class(TKOLPanel) - function TypeName: String; override; + function TypeName: string; override; end; - TKOLTabControl = class( TKOLControl ) + TKOLTabControl = class(TKOLControl) private FOptions: TTabControlOptions; FImageList: TKOLImageList; - public FTabs: TList; + public + FTabs: TList; protected FImageList1stIdx: Integer; FedgeType: TEdgeStyle; @@ -1897,7 +1679,7 @@ type procedure AdjustPages; function GetCurIndex: Integer; procedure SetCurIndex(const Value: Integer); - procedure AttemptToChangePageBounds( Sender: TObject; var NewBounds: TRect ); + procedure AttemptToChangePageBounds(Sender: TObject; var NewBounds: TRect); procedure SetImageList1stIdx(const Value: Integer); procedure SetedgeType(const Value: TEdgeStyle); procedure SetgenerateConstants(const Value: Boolean); @@ -1905,29 +1687,22 @@ type fDestroyingTabControl: Boolean; FAdjustingPages: Boolean; function TabStopByDefault: Boolean; override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; - procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; - procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: String); override; - procedure P_SetupLast(SL: TStringList; const AName, AParent, Prefix: String); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; procedure SchematicPaint; public procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; function NoDrawFrame: Boolean; override; function GetCurrentPage: TKOLPanel; - procedure DoGenerateConstants( SL: TStringList ); override; + procedure DoGenerateConstants(SL: TStringList); override; public - function Pcode_Generate: Boolean; override; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - property Pages[ Idx: Integer ]: TKOLPanel read GetPages; - procedure SetBounds( aLeft, aTop, aWidth, aHeight: Integer ); override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; - function HasCompactConstructor: Boolean; override; - function IndexOfPage( const page_name: String ): Integer; + property Pages[Idx: Integer]: TKOLPanel read GetPages; + procedure SetBounds(aLeft, aTop, aWidth, aHeight: Integer); override; + function IndexOfPage(const page_name: string): Integer; published property Transparent; property Options: TTabControlOptions read FOptions write SetOptions; @@ -1968,7 +1743,7 @@ type procedure Loaded; override; end; - TKOLTabControlEditor = class( TComponentEditor ) + TKOLTabControlEditor = class(TComponentEditor) // This component editor is to provide easy page select on tab control with // double click on one of page indicators. private @@ -1980,14 +1755,12 @@ type function GetVerbCount: Integer; override; end; - - //=========================================================================== //---- MIRROR FOR A SCROLL BOX //---- ЗЕРКАЛО ДЛЯ ОКНА ПРОКРУТКИ - TScrollBars = ( ssNone, ssHorz, ssVert, ssBoth ); + TScrollBars = (ssNone, ssHorz, ssVert, ssBoth); - TKOLScrollBox = class( TKOLControl ) + TKOLScrollBox = class(TKOLControl) private FScrollBars: TScrollBars; FControlContainer: Boolean; @@ -1997,19 +1770,15 @@ type procedure SetControlContainer(const Value: Boolean); procedure SetEdgeStyle(const Value: TEdgeStyle); protected - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; function IsControlContainer: Boolean; virtual; - function TypeName: String; override; + function TypeName: string; override; public - function Pcode_Generate: Boolean; override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; //dufa procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; published - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; property ScrollBars: TScrollBars read FScrollBars write SetScrollBars; property ControlContainer: Boolean read FControlContainer write SetControlContainer; property EdgeStyle: TEdgeStyle read FEdgeStyle write SetEdgeStyle; @@ -2030,7 +1799,7 @@ type //=========================================================================== //---- MIRROR FOR A SCROLL BAR //---- ЗЕРКАЛО ДЛЯ ПОЛОСЫ ПРОКРУТКИ - TKOLScrollBar = class( TKOLControl ) + TKOLScrollBar = class(TKOLControl) private FSBPageSize: Integer; FSBMin: Integer; @@ -2047,18 +1816,11 @@ type procedure SetOnSBBeforeScroll(const Value: TOnSBBeforeScroll); procedure SetOnSBScroll(const Value: TOnSBScroll); protected - procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; - procedure P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); override; - function SetupParams( const AName, AParent: TDelphiString): TDelphiString; override; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; public - function Pcode_Generate: Boolean; override; - constructor Create( AOwner: TComponent ); override; - function SupportsFormCompact: Boolean; override; - procedure SetupConstruct_Compact; override; + constructor Create(AOwner: TComponent); override; //dufa procedure Paint; override; function WYSIWIGPaintImplemented: Boolean; override; @@ -2075,28 +1837,26 @@ type procedure Register; - implementation -uses mckCtrlDraw; +uses + mckCtrlDraw; procedure Register; begin - RegisterComponents( 'KOL', [ TKOLButton, TKOLBitBtn, TKOLLabel, TKOLLabelEffect, TKOLPanel, - TKOLSplitter, TKOLGradientPanel, TKOLGroupBox, TKOLCheckBox, TKOLRadioBox, - TKOLEditBox, TKOLMemo, TKOLRichEdit, TKOLListBox, TKOLComboBox, TKOLPaintBox, - TKOLProgressBar, TKOLListView, TKOLTreeView, TKOLToolbar, TKOLTabControl, - TKOLTabPage, TKOLDateTimePicker, TKOLImageShow, TKOLScrollBox, TKOLScrollBar, - TKOLMDIClient ] ); - RegisterPropertyEditor( TypeInfo( string ), TKOLToolbar, 'buttons', - TKOLToolbarButtonsEditor ); - RegisterPropertyEditor( TypeInfo( TOnToolbarButtonClick ), TKOLToolbarButton, 'onClick', - TKOLToolButtonOnClickPropEditor ); - RegisterPropertyEditor( TypeInfo( string ), TKOLListView, 'Columns', - TKOLLVColumnsPropEditor ); - RegisterComponentEditor( TKOLToolbar, TKOLToolbarEditor ); - RegisterComponentEditor( TKOLTabControl, TKOLTabControlEditor ); - RegisterComponentEditor( TKOLListView, TKOLLVColumnsEditor ); + RegisterComponents('KOL', [TKOLButton, TKOLBitBtn, TKOLLabel, TKOLLabelEffect, + TKOLPanel, TKOLSplitter, TKOLGradientPanel, TKOLGroupBox, TKOLCheckBox, + TKOLRadioBox, TKOLEditBox, TKOLMemo, TKOLRichEdit, TKOLListBox, TKOLComboBox, + TKOLPaintBox, TKOLProgressBar, TKOLListView, TKOLTreeView, TKOLToolbar, + TKOLTabControl, TKOLTabPage, TKOLDateTimePicker, TKOLImageShow, + TKOLScrollBox, TKOLScrollBar, TKOLMDIClient]); + RegisterPropertyEditor(TypeInfo(string), TKOLToolbar, 'buttons', TKOLToolbarButtonsEditor); + RegisterPropertyEditor(TypeInfo(TOnToolbarButtonClick), TKOLToolbarButton, + 'onClick', TKOLToolButtonOnClickPropEditor); + RegisterPropertyEditor(TypeInfo(string), TKOLListView, 'Columns', TKOLLVColumnsPropEditor); + RegisterComponentEditor(TKOLToolbar, TKOLToolbarEditor); + RegisterComponentEditor(TKOLTabControl, TKOLTabControlEditor); + RegisterComponentEditor(TKOLListView, TKOLLVColumnsEditor); end; {function CanMapBitmap( Bitmap: TBitmap ): Boolean; @@ -2156,10 +1916,11 @@ end;*) function TKOLButton.CanChangeColor: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.CanChangeColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.CanChangeColor', 0 + +@@e_signature: end; Result := FALSE; end; @@ -2167,10 +1928,11 @@ end; function TKOLButton.CanNotChangeFontColor: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.CanNotChangeFontColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.CanNotChangeFontColor', 0 + +@@e_signature: end; Result := TRUE; end; @@ -2178,28 +1940,31 @@ end; function TKOLButton.ClientMargins: TRect; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.ClientMargins', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.ClientMargins', 0 + +@@e_signature: end; - Result := Rect( 2, 2, 2, 2 ); + Result := Rect(2, 2, 2, 2); end; constructor TKOLButton.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.Create', 0 + +@@e_signature: end; inherited; Fimage := TPicture.Create; FDefIgnoreDefault := TRUE; FIgnoreDefault := TRUE; fAutoSzX := 14; - Height := 22; DefaultHeight := 22; + Height := 22; + DefaultHeight := 22; TextAlign := taCenter; VerticalAlign := vaCenter; TabStop := True; @@ -2209,16 +1974,17 @@ end; procedure TKOLButton.CreateKOLControl(Recreating: boolean); begin inherited; - FKOLCtrl:=NewButton(KOLParentCtrl, ''); + FKOLCtrl := NewButton(KOLParentCtrl, ''); end; function TKOLButton.DefaultParentColor: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.DefaultParentColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.DefaultParentColor', 0 + +@@e_signature: end; Result := FALSE; end; @@ -2226,10 +1992,10 @@ end; procedure TKOLButton.DefineProperties(Filer: TFiler); begin inherited; - Filer.DefineProperty( 'ImageIcon', LoadImageIcon, SaveImageIcon, - Assigned( FImageIcon ) and not FImageIcon.Empty ); - Filer.DefineProperty( 'ImageBitmap', LoadImageBitmap, SaveImageBitmap, - Assigned( FImageBitmap ) and not FImageBitmap.Empty ); + Filer.DefineProperty('ImageIcon', LoadImageIcon, SaveImageIcon, Assigned(FImageIcon) + and not FImageIcon.Empty); + Filer.DefineProperty('ImageBitmap', LoadImageBitmap, SaveImageBitmap, Assigned + (FImageBitmap) and not FImageBitmap.Empty); end; destructor TKOLButton.Destroy; @@ -2243,97 +2009,50 @@ end; procedure TKOLButton.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.FirstCreate', 0 + +@@e_signature: end; Caption := Name; inherited; end; -function TKOLButton.GenerateTransparentInits: String; +function TKOLButton.GenerateTransparentInits: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.GenerateTransparentInits', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.GenerateTransparentInits', 0 + +@@e_signature: end; Result := inherited GenerateTransparentInits; - if assigned( FimageIcon ) and not FimageIcon.Empty then begin - Rpt( 'Button has icon, generating code SetButtonIcon:'#13#10 + Result, - WHITE ); - if + if assigned(FimageIcon) and not FimageIcon.Empty then begin + Rpt('Button has icon, generating code SetButtonIcon:'#13#10 + Result, WHITE); {$IFDEF ICON_DIFF_WH} - (FimageIcon.Width = 32) and (FimageIcon.Height = 32) + if (FimageIcon.Width = 32) and (FimageIcon.Height = 32) then {$ELSE} - FImageIcon.Size = 32 + if (FImageIcon.Size = 32) then {$ENDIF} - then - Result := Result + '.SetButtonIcon( LoadIcon( hInstance, ''' + - ImageResourceName + ''' ) )' + Result := Result + '.SetButtonIcon( LoadIcon( hInstance, ''' + ImageResourceName + ''' ) )' else - Result := Result + '.SetButtonIcon( LoadImage( hInstance, ''' + - ImageResourceName + ''', IMAGE_ICON, ' + - {$IFDEF ICON_DIFF_WH} - Int2Str( FimageIcon.Width ) + ', ' + Int2Str( FimageIcon.Height ) + - {$ELSE} - Int2Str( FimageIcon.Size ) + ', ' + Int2Str( FimageIcon.Size ) + - {$ENDIF} - ', LR_SHARED ) )' + Result := Result + '.SetButtonIcon( LoadImage( hInstance, ''' + + ImageResourceName + ''', IMAGE_ICON, ' + {$IFDEF ICON_DIFF_WH} + Int2Str(FimageIcon.Width) + ', ' + Int2Str(FimageIcon.Height) + {$ELSE} + Int2Str(FimageIcon.Size) + ', ' + Int2Str(FimageIcon.Size) + {$ENDIF} + ', LR_SHARED ) )' end - else - if Assigned( FimageBitmap ) and not FimageBitmap.Empty then - begin - Rpt( 'Button has bitmap, generating code SetBittonBitmap', WHITE ); - Result := Result + '.SetButtonBitmap( LoadBitmap( hInstance, ''' + - ImageResourceName + ''' ) )'; + else if Assigned(FimageBitmap) and not FimageBitmap.Empty then begin + Rpt('Button has bitmap, generating code SetBittonBitmap', WHITE); + Result := Result + '.SetButtonBitmap( LoadBitmap( hInstance, ''' + ImageResourceName + ''' ) )'; end; end; -procedure TKOLButton.GenerateTransparentInits_Compact; -var KF: TKOLForm; +function TKOLButton.ImageResourceName: string; begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - if not KF.FormCompact then Exit; - if assigned( FimageIcon ) and not FimageIcon.Empty then begin - if - {$IFDEF ICON_DIFF_WH} - (FimageIcon.Width = 32) and (FimageIcon.Height = 32) - {$ELSE} - FImageIcon.Size = 32 - {$ENDIF} - then - begin - KF.FormAddCtlCommand( Name, 'FormSetButtonIcon', '' ); - KF.FormAddStrParameter( ImageResourceName ); - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetButtonImage', '' ); - {$IFDEF ICON_DIFF_WH} - KF.FormAddNumParameter( FImageIcon.Width ); - {$ELSE} - KF.FormAddNumParameter( FImageIcon.Size ); - {$ENDIF} - KF.FormAddNumParameter( FImageIcon.Size ); - KF.FormAddStrParameter( ImageResourceName ); - end; - end - else - if Assigned( FimageBitmap ) and not FimageBitmap.Empty then - begin - KF.FormAddCtlCommand( Name, 'FormSetButtonBitmap', '' ); - KF.FormAddStrParameter( ImageResourceName ); - end; -end; - -function TKOLButton.ImageResourceName: String; -begin - Result := 'Z' + UpperCase( ParentForm.Name ) + '_' + UpperCase( Name ) + '_IMAGE'; + Result := 'Z' + UpperCase(ParentForm.Name) + '_' + UpperCase(Name) + '_IMAGE'; end; procedure TKOLButton.Loaded; @@ -2353,70 +2072,70 @@ begin end; procedure TKOLButton.LoadImageBitmap(Reader: TReader); -var Strm: TMemoryStream; - s: String; - i: Integer; - B: Byte; +var + Strm: TMemoryStream; + s: string; + i: Integer; + B: Byte; begin FImageBitmap.Free; FImageBitmap := TBitmap.Create; s := Reader.ReadString; Strm := TMemoryStream.Create; - TRY - for i := 1 to Length( s ) do - if i and 1 = 1 then - begin - B := Hex2Int( Copy( s, i, 2 ) ); - Strm.Write( B, 1 ); + try + for i := 1 to Length(s) do + if i and 1 = 1 then begin + B := Hex2Int(Copy(s, i, 2)); + Strm.Write(B, 1); end; - TRY + try Strm.Position := 0; - FImageBitmap.LoadFromStream( Strm ); - EXCEPT + FImageBitmap.LoadFromStream(Strm); + except FImageBitmap.Free; FImageBitmap := nil; - END; - FINALLY + end; + finally Strm.Free; - END; + end; end; procedure TKOLButton.LoadImageIcon(Reader: TReader); -var Strm: KOL.PStream; - s: String; - i: Integer; - B: Byte; - Sz: Integer; +var + Strm: KOL.PStream; + s: string; + i: Integer; + B: Byte; + Sz: Integer; begin FImageIcon.Free; FImageIcon := NewIcon; s := Reader.ReadString; Strm := NewMemoryStream; - TRY - Strm.Capacity := Length( s ) div 2; - for i := 1 to Length( s ) do - if i and 1 = 1 then - begin - B := Hex2Int( Copy( s, i, 2 ) ); - Strm.Write( B, 1 ); + try + Strm.Capacity := Length(s) div 2; + for i := 1 to Length(s) do + if i and 1 = 1 then begin + B := Hex2Int(Copy(s, i, 2)); + Strm.Write(B, 1); end; - TRY + try Strm.Position := 0; Sz := 0; - Strm.Read( Sz, 1 ); + Strm.Read(Sz, 1); FImageIcon.Size := Sz; - FImageIcon.LoadFromStream( Strm ); + FImageIcon.LoadFromStream(Strm); FImageIcon.Size := Sz; FImageIcon.Size := Sz; {if FImageIcon.Width = 32 then ShowMessage( 'wayay LoadImageIcon:32' );} - EXCEPT + except FImageIcon.Free; FImageIcon := nil; - END; - FINALLY + end; + finally Strm.Free; - END; + end; end; function TKOLButton.NoDrawFrame: Boolean; @@ -2427,234 +2146,76 @@ end; procedure TKOLButton.Paint; begin if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin - PrepareCanvasFontForWYSIWIGPaint( Canvas ); + PrepareCanvasFontForWYSIWIGPaint(Canvas); Canvas.Font.Color := clBtnText; Canvas.Brush.Color := clBtnFace; //dufa - DrawButton(True, Canvas.Handle, ClientRect, Enabled, DefaultBtn, - TextHFlags[KOL.TTextAlign(TextAlign)] or TextVFlags[KOL.TVerticalAlign(VerticalAlign)], Caption); + DrawButton(True, Enabled, DefaultBtn, Canvas.Handle, ClientRect, TextHFlags[KOL.TTextAlign + (TextAlign)] or TextVFlags[KOL.TVerticalAlign(VerticalAlign)], Caption); end; inherited; end; -function TKOLButton.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLButton.P_GenerateTransparentInits: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.P_GenerateTransparentInits', 0 - @@e_signature: - end; - Result := inherited P_GenerateTransparentInits; - if assigned( FimageIcon ) and not FImageIcon.Empty then begin - //Result := Result + '.SetButtonIcon( LoadIcon( hInstance, ''' + - // ImageResourceName + ''' ) )'; - {P}Result := Result + ' LoadAnsiStr ''' + - ImageResourceName + ''' #0 Load_hInstance LoadIcon RESULT ' + - 'C2 TControl.SetButtonIcon<2> DelAnsiStr'; - Rpt( 'Button has icon, generating Pcode SetButtonIcon:'#13#10 + Result, - WHITE ); - end - else - if Assigned( FimageBitmap ) and not FimageBitmap.Empty then - begin - Rpt( 'Button has bitmap, generating Pcode SetBittonBitmap', WHITE ); - //Result := Result + '.SetButtonBitmap( LoadBitmap( hInstance, ''' + - // ImageResourceName + ''' ) )'; - {P}Result := Result + ' LoadAnsiStr ''' + - ImageResourceName + ''' #0 Load_hInstance LoadBitmap<2>' + - ' C2 TControl.SetButtonBitmap<2> DelAnsiStr'; - end; - if LikeSpeedButton then - //Result := Result + '.LikeSpeedButton'; - {P}Result := Result + ' DUP TControl.LikeSpeedButton<1>'; - {P}Result := Result + ' xySwap DelAnsiStr'; -end; - -procedure TKOLButton.P_SetupColor(SL: TStrings; const AName: String; var ControlInStack: Boolean); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.P_SetupColor', 0 - @@e_signature: - end; - // there are no setup color for TKOLButton: - if ClassName = 'TKOLButton' then Exit; - inherited; -end; - -procedure TKOLButton.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var Updated: Boolean; - TmpIcon: TIcon; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if Flat then - if Windowed then - //SL.Add( Prefix + AName + '.Style := ' + AName + '.Style or BS_FLAT;' ) - {P}SL.Add( ' DUP AddWord_LoadRef ##TControl_.fStyle L(' + IntToStr( BS_FLAT ) + - ') | C1 TControl_.SetStyle<2>' ) - else - //SL.Add( Prefix + AName + '.Flat := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetFlat<2>' ); - - if assigned( FimageIcon ) and not Fimageicon.Empty then begin - Rpt( 'Button has icon, generate resource', WHITE ); - SL.Add( '{$R ' + ImageResourceName + '.res}' ); - TmpIcon := TIcon.Create; - TRY - TmpIcon.Handle := DuplicateIcon( hInstance, FImageIcon.Handle ); - GenerateIconResource( TmpIcon, ImageResourceName, ImageResourceName, - Updated ); - TmpIcon.Handle := 0; - FINALLY - TmpIcon.Free; - END; - end - else - if Assigned( FimageBitmap ) and not FimageBitmap.Empty then - begin - Rpt( 'Button has bitmap, generate resource', WHITE ); - GenerateBitmapResource( FimageBitmap, ImageResourceName, ImageResourceName, - Updated, AllowBitmapCompression ); - end; -end; - -procedure TKOLButton.P_SetupFont(SL: TStrings; const AName: String); -var BFont: TKOLFont; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.P_SetupFont', 0 - @@e_signature: - end; - if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm <> nil) then - BFont := ParentKOLForm.Font - else - if (ParentKOLControl <> nil) and (ParentKOLControl is TKOLCustomControl) then - BFont := (ParentKOLControl as TKOLCustomControl).Font - else - BFont := nil; - if BFont = nil then Exit; - BFont.Color := Font.Color; - if not Font.Equal2( BFont ) then - Font.P_GenerateCode( SL, AName, BFont ); -end; - -function TKOLButton.P_SetupParams(const AName, AParent: String; var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.P_SetupParams', 0 - @@e_signature: - end; - nparams := 2; - if action = nil then - Result := P_StringConstant('Caption',Caption) - else - Result := ' LoadAnsiStr #0 '; - //Result := AParent + ', ' + C; - {P}Result := Result + - #13#10' C2'; -end; - -procedure TKOLButton.P_SetupTextAlign(SL: TStrings; const AName: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.P_SetupTextAlign', 0 - @@e_signature: - end; - if TextAlign <> taCenter then - //SL.Add( ' ' + AName + '.TextAlign := ' + TextAligns[ TextAlign ] + ';' ); - //{P}SL.Add( 'L(' + IntToStr( Integer( TextAlign ) ) + ')' + - // ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - // Name + ' TControl_.SetTextAlign<2>' ); - {P}SL.Add( 'L(' + IntToStr( Integer( TextAlign ) ) + ')' + - ' C1 TControl_.SetTextAlign<2>' ); - if VerticalAlign <> vaCenter then - //SL.Add( ' ' + AName + '.VerticalAlign := ' + VertAligns[ VerticalAlign ] + ';' ); - //{P}SL.Add( 'L(' + IntToStr( VerticalAlignAsKOLVerticalAlign ) + ')' + - // ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - // Name + ' TControl_.SetVerticalAlign<2>' ); - {P}SL.Add( 'L(' + IntToStr( VerticalAlignAsKOLVerticalAlign ) + ')' + - ' C1 TControl_.SetVerticalAlign<2>' ); -end; - procedure TKOLButton.SaveImageBitmap(Writer: TWriter); -var Strm: TMemoryStream; - s, h: String; - B: Byte; +var + Strm: TMemoryStream; + s, h: string; + B: Byte; begin Strm := TMemoryStream.Create; - TRY - FImageBitmap.SaveToStream( Strm ); - SetLength( s, Strm.Size * 2 ); + try + FImageBitmap.SaveToStream(Strm); + SetLength(s, Strm.Size * 2); Strm.Position := 0; s := ''; - while Strm.Position < Strm.Size do - begin - Strm.Read( B, 1 ); - h := Int2Hex( B, 2 ); + while Strm.Position < Strm.Size do begin + Strm.Read(B, 1); + h := Int2Hex(B, 2); s := s + h; end; - Writer.WriteString( s ); - FINALLY + Writer.WriteString(s); + finally Strm.Free; - END; + end; end; procedure TKOLButton.SaveImageIcon(Writer: TWriter); -var Strm: KOL.PStream; - s, h: String; - B: Byte; - Sz: Integer; +var + Strm: KOL.PStream; + s, h: string; + B: Byte; + Sz: Integer; begin Strm := NewMemoryStream; - TRY + try {$IFDEF ICON_DIFF_WH} Sz := FImageIcon.Width; {$ELSE} Sz := FImageIcon.Size; {$ENDIF} - Strm.Write( Sz, 1 ); - FImageIcon.SaveToStream( Strm ); + Strm.Write(Sz, 1); + FImageIcon.SaveToStream(Strm); {if FImageIcon.Width = 32 then ShowMessage( 'wayay SaveImageIcon:32' );} - SetLength( s, Strm.Size * 2 ); + SetLength(s, Strm.Size * 2); Strm.Position := 0; s := ''; - while Strm.Position < Strm.Size do - begin - Strm.Read( B, 1 ); - h := Int2Hex( B, 2 ); + while Strm.Position < Strm.Size do begin + Strm.Read(B, 1); + h := Int2Hex(B, 2); s := s + h; end; - Writer.WriteString( s ); - FINALLY + Writer.WriteString(s); + finally Strm.Free; - END; + end; end; procedure TKOLButton.SetAllowBitmapCompression(const Value: Boolean); begin - if FAllowBitmapCompression = Value then Exit; + if FAllowBitmapCompression = Value then + Exit; FAllowBitmapCompression := Value; Change; end; @@ -2667,252 +2228,205 @@ end; procedure TKOLButton.Setimage(const Value: TPicture); begin - Fimage.Assign( Value ); - if ( csLoading in ComponentState ) then Exit; - if Assigned( FImage.Graphic ) and (FImage.Graphic is TBitmap) then - begin - Free_And_Nil( FimageIcon ); + Fimage.Assign(Value); + if (csLoading in ComponentState) then + Exit; + if Assigned(FImage.Graphic) and (FImage.Graphic is TBitmap) then begin + Free_And_Nil(FimageIcon); if FimageBitmap = nil then FImageBitmap := TBitmap.Create; - FimageBitmap.Assign( FImage.Bitmap ); + FimageBitmap.Assign(FImage.Bitmap); end - else - if Assigned( FImage.Graphic ) and (FImage.Graphic is TIcon) then - begin + else if Assigned(FImage.Graphic) and (FImage.Graphic is TIcon) then begin FImageBitmap.Free; FImageBitmap := nil; if FimageIcon = nil then FImageIcon := NewIcon; - FImageIcon.Handle := DuplicateIcon( hInstance, FImage.Icon.Handle ); + FImageIcon.Handle := DuplicateIcon(hInstance, FImage.Icon.Handle); {if FImageIcon.Size = 32 then ShowMessage( 'wayay Setmage:32' );} end - else - begin - FImageBitmap.Free; - FImageBitmap := nil; - Free_And_Nil( FimageIcon ); + else begin + FImageBitmap.Free; + FImageBitmap := nil; + Free_And_Nil(FimageIcon); end; Change; end; -procedure TKOLButton.SetupColor(SL: TStrings; const AName: String); +procedure TKOLButton.SetupColor(SL: TStrings; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.SetupColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.SetupColor', 0 + +@@e_signature: end; // there are no setup color for TKOLButton: - if ClassName = 'TKOLButton' then Exit; + if ClassName = 'TKOLButton' then + Exit; inherited; end; -procedure TKOLButton.SetupConstruct_Compact; -var KF: TKOLForm; - C: String; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewButton', TRUE, TRUE, '' ); - C := Caption; - if not KF.AssignTextToControls then - C := ''; - KF.FormAddStrParameter( C ); -end; - -procedure TKOLButton.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var Updated: Boolean; - TmpIcon: TIcon; - KF: TKOLForm; +procedure TKOLButton.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +var + Updated: Boolean; + TmpIcon: TIcon; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if Flat then - if Windowed then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetStyle', '' ); - KF.FormAddNumParameter( BS_FLAT ); - end else - SL.Add( Prefix + AName + '.Style := ' + AName + '.Style or BS_FLAT;' ) - else if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetFlat', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.Flat := TRUE;' ); + if Flat then + if Windowed then + SL.Add(Prefix + AName + '.Style := ' + AName + '.Style or BS_FLAT;') + else + SL.Add(Prefix + AName + '.Flat := TRUE;'); - if WordWrap and Windowed then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetStyle', '' ); - KF.FormAddNumParameter( BS_MULTILINE ); - end else - SL.Add( Prefix + AName + '.Style := ' + AName + '.Style or BS_MULTILINE;' ); + if WordWrap and Windowed then + SL.Add(Prefix + AName + '.Style := ' + AName + '.Style or BS_MULTILINE;'); - if assigned( FimageIcon ) and not FimageIcon.Empty then begin - Rpt( 'Button has icon, generate resource', WHITE ); - if (KF <> nil) and KF.FormCompact then - begin - (SL as TFormStringList).OnAdd := nil; - SL.Add( '{$R ' + ImageResourceName + '.res}' ); - (SL as TFormStringList).OnAdd := KF.DoFlushFormCompact; - end - else - SL.Add( '{$R ' + ImageResourceName + '.res}' ); - TmpIcon := TIcon.Create; - TRY - TmpIcon.Handle := DuplicateIcon( hInstance, FImageIcon.Handle ); - GenerateIconResource( TmpIcon, ImageResourceName, ImageResourceName, - Updated ); - FINALLY - TmpIcon.Free; - END; + if assigned(FimageIcon) and not FimageIcon.Empty then begin + Rpt('Button has icon, generate resource', WHITE); + SL.Add('{$R ' + ImageResourceName + '.res}'); + + TmpIcon := TIcon.Create; + try + TmpIcon.Handle := DuplicateIcon(hInstance, FImageIcon.Handle); + GenerateIconResource(TmpIcon, ImageResourceName, ImageResourceName, Updated); + finally + TmpIcon.Free; + end; end - else - if Assigned( FimageBitmap ) and not FimageBitmap.Empty then - begin - Rpt( 'Button has bitmap, generate resource', WHITE ); - if (KF <> nil) and KF.FormCompact then - begin - (SL as TFormStringList).OnAdd := nil; - SL.Add( '{$R ' + ImageResourceName + '.res}' ); - (SL as TFormStringList).OnAdd := KF.DoFlushFormCompact; - end - else - SL.Add( '{$R ' + ImageResourceName + '.res}' ); - GenerateBitmapResource( FimageBitmap, ImageResourceName, ImageResourceName, - Updated, AllowBitmapCompression ); + else if Assigned(FimageBitmap) and not FimageBitmap.Empty then begin + Rpt('Button has bitmap, generate resource', WHITE); + SL.Add('{$R ' + ImageResourceName + '.res}'); + GenerateBitmapResource(FimageBitmap, ImageResourceName, ImageResourceName, + Updated, AllowBitmapCompression); end; end; -procedure TKOLButton.SetupFont(SL: TStrings; const AName: String); -var BFont: TKOLFont; +procedure TKOLButton.SetupFont(SL: TStrings; const AName: string); +var + BFont: TKOLFont; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.SetupFont', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.SetupFont', 0 + +@@e_signature: end; if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm <> nil) then BFont := ParentKOLForm.Font - else - if (ParentKOLControl <> nil) and (ParentKOLControl is TKOLCustomControl) then + else if (ParentKOLControl <> nil) and (ParentKOLControl is TKOLCustomControl) then BFont := (ParentKOLControl as TKOLCustomControl).Font else BFont := nil; - if BFont = nil then Exit; + if BFont = nil then + Exit; BFont.Color := Font.Color; - if not Font.Equal2( BFont ) then - Font.GenerateCode( SL, AName, BFont ); + if not Font.Equal2(BFont) then + Font.GenerateCode(SL, AName, BFont); end; -function TKOLButton.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLButton.SetupParams(const AName, AParent: TDelphiString): TDelphiString; var {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.SetupParams', 0 + +@@e_signature: end; - if (action = nil) and - (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - C := StringConstant('Caption', Caption) + if (action = nil) and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then + C := StringConstant('Caption', Caption) else - C := ''''''; + C := ''''''; {$IFDEF _D2009orHigher} - if C <> '''''' then - begin - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; - end; + if C <> '''''' then begin + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[i])); + C := C2; + end; {$ENDIF} Result := AParent + ', ' + C; end; -procedure TKOLButton.SetupTextAlign(SL: TStrings; const AName: String); +procedure TKOLButton.SetupTextAlign(SL: TStrings; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.SetupTextAlign', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.SetupTextAlign', 0 + +@@e_signature: end; - if TextAlign <> taCenter then - GenerateTextAlign( SL, AName ); + if TextAlign <> taCenter then + GenerateTextAlign(SL, AName); - if VerticalAlign <> vaCenter then - GenerateVerticalAlign( SL, AName ); -end; - -function TKOLButton.SupportsFormCompact: Boolean; -begin - Result := TRUE; + if VerticalAlign <> vaCenter then + GenerateVerticalAlign(SL, AName); end; function TKOLButton.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; -function TKOLButton.TypeName: String; +function TKOLButton.TypeName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.TypeName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.TypeName', 0 + +@@e_signature: end; Result := inherited TypeName; end; function TKOLButton.WYSIWIGPaintImplemented: Boolean; begin - Result := TRUE; + Result := TRUE; end; { TKOLLabel } -function TKOLLabel.AdjustVerticalAlign( - Value: TVerticalAlign): TVerticalAlign; +function TKOLLabel.AdjustVerticalAlign(Value: TVerticalAlign): TVerticalAlign; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLButton.AdjustVerticalAlign', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLButton.AdjustVerticalAlign', 0 + +@@e_signature: end; - if (Value = vaBottom) and Windowed and not( csLoading in ComponentState ) then - begin + if (Value = vaBottom) and Windowed and not (csLoading in ComponentState) then begin Result := vaCenter; - if not (csLoading in ComponentState) then - ShowMessage( 'Windowed Label can not be aligned bottom !' ); + if not (csLoading in ComponentState) then + ShowMessage('Windowed Label can not be aligned bottom !'); end else Result := Value; @@ -2926,25 +2440,28 @@ end; constructor TKOLLabel.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.Create', 0 + +@@e_signature: end; inherited; fAutoSzX := 1; fAutoSzY := 1; - Height := 22; DefaultHeight := 22; + Height := 22; + DefaultHeight := 22; fTabOrder := -1; end; procedure TKOLLabel.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.FirstCreate', 0 + +@@e_signature: end; Caption := Name; inherited; @@ -2953,22 +2470,24 @@ end; function TKOLLabel.GetTaborder: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.GetTaborder', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.GetTaborder', 0 + +@@e_signature: end; Result := //-1; - inherited GetTaborder; + inherited GetTaborder; end; function TKOLLabel.Get_VertAlign: TVerticalAlign; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.Get_VertAlign', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.Get_VertAlign', 0 + +@@e_signature: end; Result := inherited VerticalAlign; end; @@ -2981,215 +2500,142 @@ end; procedure TKOLLabel.Paint; var - R:TRect; - Flag:DWord; + R: TRect; + Flag: DWord; TMPBrushStyle: TBrushStyle; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.Paint', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.Paint', 0 + +@@e_signature: end; - R.Left:=0; - R.Top:=0; - R.Right:=Width; - R.Bottom:=Height; - Flag:=0; + R.Left := 0; + R.Top := 0; + R.Right := Width; + R.Bottom := Height; + Flag := 0; case TextAlign of - taRight: Flag:=Flag or DT_RIGHT; - taLeft: Flag:=Flag or DT_LEFT; - taCenter: Flag:=Flag or DT_CENTER; + taRight: + Flag := Flag or DT_RIGHT; + taLeft: + Flag := Flag or DT_LEFT; + taCenter: + Flag := Flag or DT_CENTER; end; case VerticalAlign of - vaTop: Flag:=Flag or DT_TOP; - vaBottom: Flag:=Flag or DT_BOTTOM; - vaCenter: Flag:=Flag or DT_VCENTER or DT_SINGLELINE; + vaTop: + Flag := Flag or DT_TOP; + vaBottom: + Flag := Flag or DT_BOTTOM; + vaCenter: + Flag := Flag or DT_VCENTER or DT_SINGLELINE; end; - if (WordWrap) and (not AutoSize or (Align in [ caClient, caTop, caBottom ])) then - Flag:=Flag or DT_WORDBREAK; + if (WordWrap) and (not AutoSize or (Align in [caClient, caTop, caBottom])) then + Flag := Flag or DT_WORDBREAK; - PrepareCanvasFontForWYSIWIGPaint( Canvas ); + PrepareCanvasFontForWYSIWIGPaint(Canvas); TMPBrushStyle := Canvas.Brush.Style; Canvas.Brush.Style := bsClear; - DrawText(Canvas.Handle,PChar(Caption),Length(Caption),R,Flag); - Canvas.Brush.Style :=TMPBrushStyle; + DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R, Flag); + Canvas.Brush.Style := TMPBrushStyle; inherited; end; -function TKOLLabel.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLLabel.P_GenerateTransparentInits: String; -begin - Result := ' xySwap DelAnsiStr ' + inherited P_GenerateTransparentInits; -end; - -procedure TKOLLabel.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.SetupFirst', 0 - @@e_signature: - end; - inherited; - if ShowAccelChar then - //SL.Add( Prefix + AName + '.Style := ' + AName + '.Style and not SS_NOPREFIX;' ); - begin - {P}SL.Add( ' DUP AddWord_LoadRef ##TControl_.fStyle' ); - {P}SL.Add( ' L(' + IntToStr( SS_NOPREFIX ) + ') ~ &' ); - {P}SL.Add( ' C1 TControl_.SetStyle<2>' ); - end; -end; - -function TKOLLabel.P_SetupParams(const AName, AParent: String; var nParams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.P_SetupParams', 0 - @@e_signature: - end; - //Result := AParent + ', ' + StringConstant('Caption', Caption); - nparams := 2; - {P}Result := P_StringConstant( 'Caption', Caption ) + ' C2'; -end; - -procedure TKOLLabel.P_SetupTextAlign(SL: TStrings; const AName: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.P_SetupTextAlign', 0 - @@e_signature: - end; - if TextAlign <> taLeft then - //SL.Add( ' ' + AName + '.TextAlign := ' + TextAligns[ TextAlign ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( TextAlign ) ) + ') C1 TControl_.SetTextAlign<2>' ); - if VerticalAlign <> vaTop then - //SL.Add( ' ' + AName + '.VerticalAlign := ' + VertAligns[ VerticalAlign ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( VerticalAlignAsKOLVerticalAlign ) + ') C1 TControl_.SetVerticalAlign<2>' ); -end; - procedure TKOLLabel.SetShowAccelChar(const Value: Boolean); begin FShowAccelChar := Value; Change; end; -procedure TKOLLabel.SetupConstruct_Compact; -var KF: TKOLForm; - C: String; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewLabel', TRUE, TRUE, '' ); - C := Caption; - if not KF.AssignTextToControls then - C := ''; - KF.FormAddStrParameter( C ); -end; - -procedure TKOLLabel.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLLabel.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if ShowAccelChar then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormResetStyles', '' ); - KF.FormAddNumParameter( SS_NOPREFIX ); - end else - SL.Add( Prefix + AName + '.Style := ' + AName + '.Style and not SS_NOPREFIX;' ); + if ShowAccelChar then + SL.Add(Prefix + AName + '.Style := ' + AName + '.Style and not SS_NOPREFIX;'); end; -function TKOLLabel.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLLabel.SetupParams(const AName, AParent: TDelphiString): TDelphiString; var {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.SetupParams', 0 + +@@e_signature: end; - if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - C := StringConstant('Caption', Caption) - else - C := ''''''; + if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then + C := StringConstant('Caption', Caption) + else + C := ''''''; {$IFDEF _D2009orHigher} - if C <> '''''' then - begin - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; - end; + if C <> '''''' then begin + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[i])); + C := C2; + end; {$ENDIF} - Result := AParent + ', ' + C; + Result := AParent + ', ' + C; end; -procedure TKOLLabel.SetupTextAlign(SL: TStrings; const AName: String); +procedure TKOLLabel.SetupTextAlign(SL: TStrings; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.SetupTextAlign', 0 - @@e_signature: - end; - if TextAlign <> taLeft then - GenerateTextAlign( SL, AName ); + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.SetupTextAlign', 0 - if VerticalAlign <> vaTop then - GenerateVerticalAlign( SL, AName ); +@@e_signature: + end; + if TextAlign <> taLeft then + GenerateTextAlign(SL, AName); + + if VerticalAlign <> vaTop then + GenerateVerticalAlign(SL, AName); end; procedure TKOLLabel.Set_VertAlign(const Value: TVerticalAlign); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.Set_VertAlign', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.Set_VertAlign', 0 + +@@e_signature: end; - inherited VerticalAlign := AdjustVerticalAlign( Value ); + inherited VerticalAlign := AdjustVerticalAlign(Value); end; -function TKOLLabel.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - -function TKOLLabel.TypeName: String; +function TKOLLabel.TypeName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.TypeName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.TypeName', 0 + +@@e_signature: end; Result := inherited TypeName; end; @@ -3197,10 +2643,11 @@ end; function TKOLLabel.WYSIWIGPaintImplemented: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabel.WYSIWIGPaintImplemented', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabel.WYSIWIGPaintImplemented', 0 + +@@e_signature: end; Result := TRUE; end; @@ -3210,60 +2657,70 @@ end; function TKOLPanel.ClientMargins: TRect; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.ClientMargins', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.ClientMargins', 0 + +@@e_signature: end; case edgeStyle of - esLowered: Result := Rect( 1, 1, 1, 1 ); - esRaised: Result := Rect( 3, 3, 3, 3 ); + esLowered: + Result := Rect(1, 1, 1, 1); + esRaised: + Result := Rect(3, 3, 3, 3); //esNone, esTransparent, esSolid: - else Result := Rect( 0, 0, 0, 0 ); + else + Result := Rect(0, 0, 0, 0); end; end; constructor TKOLPanel.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.Create', 0 + +@@e_signature: end; inherited; - Width := 100; DefaultWidth := Width; - Height := 100; DefaultHeight := 100; + Width := 100; + DefaultWidth := Width; + Height := 100; + DefaultHeight := 100; //ControlStyle := ControlStyle + [ csAcceptsControls ]; AcceptChildren := TRUE; end; destructor TKOLPanel.Destroy; -var P: TKOLTabControl; +var + P: TKOLTabControl; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.Destroy', 0 + +@@e_signature: end; if Parent <> nil then - if Parent is TKOLTabControl then - begin - P:=Parent as TKOLTabControl; - if (P.FCurPage=self) and (P.CurIndex>0) then P.CurIndex:=pred(P.CurIndex); - P.Invalidate; - end; + if Parent is TKOLTabControl then begin + P := Parent as TKOLTabControl; + if (P.FCurPage = self) and (P.CurIndex > 0) then + P.CurIndex := pred(P.CurIndex); + P.Invalidate; + end; inherited; end; function TKOLPanel.Get_VA: TVerticalAlign; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.Get_VA', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.Get_VA', 0 + +@@e_signature: end; Result := inherited VerticalAlign; end; @@ -3271,181 +2728,111 @@ end; function TKOLPanel.NoDrawFrame: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.NoDrawFrame', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.NoDrawFrame', 0 + +@@e_signature: end; - Result := not(EdgeStyle in [esNone,esTransparent,esSolid]) or - (Parent <> nil) and (Parent is TKOLTabControl); + Result := not (EdgeStyle in [esNone, esTransparent, esSolid]) or (Parent <> + nil) and (Parent is TKOLTabControl); end; procedure TKOLPanel.Paint; var - R:TRect; - Flag,EdgeFlag:DWord; - Delta:Integer; + R: TRect; + Flag, EdgeFlag: DWord; + Delta: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.Paint', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.Paint', 0 + +@@e_signature: end; - R.Left:=0; - R.Top:=0; - R.Right:=Width; - R.Bottom:=Height; + R.Left := 0; + R.Top := 0; + R.Right := Width; + R.Bottom := Height; case edgeStyle of esRaised: - begin - EdgeFlag:=EDGE_RAISED; - Delta:=3; - end; + begin + EdgeFlag := EDGE_RAISED; + Delta := 3; + end; esLowered: - begin - EdgeFlag:=BDR_SUNKENOUTER; - Delta:=1; - end; + begin + EdgeFlag := BDR_SUNKENOUTER; + Delta := 1; + end; //esNone, esTransparent, esSolid: - else + else begin - EdgeFlag:=0; - Delta:=0; + EdgeFlag := 0; + Delta := 0; end; end; //case - if Delta <> 0 then - begin - DrawEdge(Canvas.Handle,R,EdgeFlag,BF_RECT or BF_MIDDLE ); - R.Left:=Delta; - R.Top:=Delta; - R.Right:=Width-Delta; - R.Bottom:=Height-Delta; + if Delta <> 0 then begin + DrawEdge(Canvas.Handle, R, EdgeFlag, BF_RECT or BF_MIDDLE); + R.Left := Delta; + R.Top := Delta; + R.Right := Width - Delta; + R.Bottom := Height - Delta; Canvas.Brush.Color := Color; - Canvas.FillRect( R ); + Canvas.FillRect(R); end; - Flag:=0; + Flag := 0; case TextAlign of - taRight: Flag:=Flag or DT_RIGHT; - taLeft: Flag:=Flag or DT_LEFT; - taCenter: Flag:=Flag or DT_CENTER; + taRight: + Flag := Flag or DT_RIGHT; + taLeft: + Flag := Flag or DT_LEFT; + taCenter: + Flag := Flag or DT_CENTER; end; //case case VerticalAlign of - vaTop: Flag:=Flag or DT_TOP or DT_SINGLELINE; - vaBottom: Flag:=Flag or DT_BOTTOM or DT_SINGLELINE; - vaCenter: Flag:=Flag or DT_VCENTER or DT_SINGLELINE; + vaTop: + Flag := Flag or DT_TOP or DT_SINGLELINE; + vaBottom: + Flag := Flag or DT_BOTTOM or DT_SINGLELINE; + vaCenter: + Flag := Flag or DT_VCENTER or DT_SINGLELINE; end; //case - Flag:=Flag+DT_WORDBREAK; + Flag := Flag + DT_WORDBREAK; - if not( (Parent <> nil) and (Parent is TKOLTabControl) ) then - begin - PrepareCanvasFontForWYSIWIGPaint( Canvas ); - DrawText(Canvas.Handle,PChar(Caption),Length(Caption),R,Flag); + if not ((Parent <> nil) and (Parent is TKOLTabControl)) then begin + PrepareCanvasFontForWYSIWIGPaint(Canvas); + DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R, Flag); end; inherited; end; -function TKOLPanel.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLPanel.P_SetupConstruct(SL: TStringList; const AName, AParent, - Prefix: String); +function TKOLPanel.RefName: string; +var + J: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.P_SetupConstruct', 0 - @@e_signature: - end; - if Parent <> nil then - if Parent is TKOLTabControl then - Exit; // this is not a panel, but a tab page on tab control. - inherited; -end; + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.RefName', 0 -procedure TKOLPanel.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if Parent <> nil then - if Parent is TKOLTabControl then - Exit; // this is not a panel, but a tab page on tab control. - if Caption <> '' then - //SL.Add( Prefix + AName + '.Caption := ' + StringConstant('Caption', Caption) + ';' ); - {P}SL.Add( P_StringConstant('Caption', Caption) + - ' C2 TControl_.SetCaption<2> DelAnsiStr' ); - if ShowAccelChar then - //SL.Add( Prefix + AName + '.Style := ' + AName + '.Style and not SS_NOPREFIX;' ); - {P}SL.Add( ' L(' + IntToStr( not SS_NOPREFIX ) + ') ' + - ' C1 AddWord_LoadRef ##TControl_.fStyle & C2 TControl_.SetStyle<2>' ); -end; - -function TKOLPanel.P_SetupParams(const AName, AParent: String; var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.P_SetupParams', 0 - @@e_signature: - end; - //Result := AParent + ', ' + EdgeStyles[ EdgeStyle ]; - {P}Result := ' L(' + IntToStr( Integer( EdgeStyle ) ) + ') ' + - //' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + Remove_Result_dot( AParent ) - ' C1'; - nparams := 2; -end; - -procedure TKOLPanel.P_SetupTextAlign(SL: TStrings; const AName: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.P_SetupTextAlign', 0 - @@e_signature: - end; - if TextAlign <> taLeft then - //SL.Add( ' ' + AName + '.TextAlign := ' + TextAligns[ TextAlign ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( TextAlign ) ) + ') ' + - ' C1 TControl_.SetTextAlign<2>' ); - if VerticalAlign <> vaTop then - //SL.Add( ' ' + AName + '.VerticalAlign := ' + VertAligns[ VerticalAlign ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( VerticalAlignAsKOLVerticalAlign ) + ') ' + - ' C1 TControl_.SetVerticalAlign<2>' ); -end; - -function TKOLPanel.RefName: String; -var J: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.RefName', 0 - @@e_signature: +@@e_signature: end; Result := inherited RefName; - if Parent is TKOLTabControl then - begin + if Parent is TKOLTabControl then begin for J := 0 to (Parent as TKOLTabControl).Count - 1 do - if (Parent as TKOLTabControl).Pages[ J ] = Self then - begin - Result := (Parent as TKOLTabControl).RefName + '.Pages[ ' + IntToStr( J ) + ' ]'; + if (Parent as TKOLTabControl).Pages[J] = Self then begin + Result := (Parent as TKOLTabControl).RefName + '.Pages[ ' + IntToStr(J) + ' ]'; break; end; end; @@ -3461,15 +2848,17 @@ end; procedure TKOLPanel.SetEdgeStyle(const Value: TEdgeStyle); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.SetEdgeStyle', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.SetEdgeStyle', 0 + +@@e_signature: end; - if FEdgeStyle = Value then Exit; + if FEdgeStyle = Value then + Exit; FEdgeStyle := Value; Change; - ReAlign( FALSE ); + ReAlign(FALSE); Invalidate; end; @@ -3479,165 +2868,146 @@ begin Change; end; -procedure TKOLPanel.SetupConstruct(SL: TStringList; const AName, AParent, - Prefix: String); +procedure TKOLPanel.SetupConstruct(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.SetupConstruct', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.SetupConstruct', 0 + +@@e_signature: end; if Parent <> nil then - if Parent is TKOLTabControl then - Exit; // this is not a panel, but a tab page on tab control. + if Parent is TKOLTabControl then + Exit; // this is not a panel, but a tab page on tab control. inherited; end; -procedure TKOLPanel.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewPanel', TRUE, TRUE, '' ); - KF.FormAddNumParameter( Integer( EdgeStyle ) ); -end; - -procedure TKOLPanel.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -var KF: TKOLForm; - C: String; +procedure TKOLPanel.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +var + KF: TKOLForm; + C: string; {$IFDEF _D2009orHigher} - C2: WideString; - i : integer; + C2: WideString; + i: integer; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.SetupFirst', 0 + +@@e_signature: end; inherited; if Parent <> nil then - if Parent is TKOLTabControl then - Exit; // this is not a panel, but a tab page on tab control. + if Parent is TKOLTabControl then + Exit; // this is not a panel, but a tab page on tab control. KF := ParentKOLForm; - if (Caption <> '') and (KF <> nil) and KF.AssignTextToControls then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetCaption', '' ); - KF.FormAddStrParameter( Caption ); - end - else - begin - C := StringConstant('Caption', Caption); - {$IFDEF _D2009orHigher} - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; - {$ENDIF} - SL.Add( Prefix + AName + '.Caption := ' + C + ';' ); - end; + if (Caption <> '') and (KF <> nil) and KF.AssignTextToControls then begin + C := StringConstant('Caption', Caption); + {$IFDEF _D2009orHigher} + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[i])); + C := C2; + {$ENDIF} + SL.Add(Prefix + AName + '.Caption := ' + C + ';'); end; - if ShowAccelChar then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormResetStyles', '' ); - KF.FormAddNumParameter( SS_NOPREFIX ); - end else - SL.Add( Prefix + AName + '.Style := ' + AName + '.Style and not SS_NOPREFIX;' ); + if ShowAccelChar then + SL.Add(Prefix + AName + '.Style := ' + AName + '.Style and not SS_NOPREFIX;'); end; -function TKOLPanel.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -const EdgeStyles: array[ TEdgeStyle ] of String = - ( 'esRaised', 'esLowered', 'esNone', 'esTransparent', 'esSolid' ); +function TKOLPanel.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +const + EdgeStyles: array[TEdgeStyle] of string = ('esRaised', 'esLowered', 'esNone', 'esTransparent', 'esSolid'); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.SetupParams', 0 + +@@e_signature: end; - Result := AParent + ', ' + EdgeStyles[ EdgeStyle ]; + Result := AParent + ', ' + EdgeStyles[EdgeStyle]; end; -procedure TKOLPanel.SetupTextAlign(SL: TStrings; const AName: String); +procedure TKOLPanel.SetupTextAlign(SL: TStrings; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.SetupTextAlign', 0 - @@e_signature: - end; - if TextAlign <> taLeft then - GenerateTextAlign( SL, AName ); + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.SetupTextAlign', 0 - if VerticalAlign <> vaTop then - GenerateVerticalAlign( SL, AName ); +@@e_signature: + end; + if TextAlign <> taLeft then + GenerateTextAlign(SL, AName); + + if VerticalAlign <> vaTop then + GenerateVerticalAlign(SL, AName); end; procedure TKOLPanel.Set_VA(const Value: TVerticalAlign); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.Set_VA', 0 - @@e_signature: - end; - if Value = vaBottom then - begin - if not (csLoading in ComponentState) then - ShowMessage( 'Panel text can not be aligned bottom !' ); - inherited VerticalAlign := vaCenter - end else - inherited VerticalAlign := Value; -end; + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.Set_VA', 0 -function TKOLPanel.SupportsFormCompact: Boolean; -begin - Result := TRUE; +@@e_signature: + end; + if Value = vaBottom then begin + if not (csLoading in ComponentState) then + ShowMessage('Panel text can not be aligned bottom !'); + inherited VerticalAlign := vaCenter + end + else + inherited VerticalAlign := Value; end; function TKOLPanel.WYSIWIGPaintImplemented: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPanel.WYSIWIGPaintImplemented', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPanel.WYSIWIGPaintImplemented', 0 + +@@e_signature: end; Result := TRUE; end; { TKOLBitBtn } -procedure TKOLBitBtn.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLBitBtn.AssignEvents(SL: TStringList; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.AssignEvents', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.AssignEvents', 0 + +@@e_signature: end; inherited; - DoAssignEvents( SL, AName, [ 'OnTestMouseOver' ], [ @OnTestMouseOver ] ); + DoAssignEvents(SL, AName, ['OnTestMouseOver'], [@OnTestMouseOver]); end; procedure TKOLBitBtn.AutoSizeNow; -var TmpBmp: graphics.TBitmap; - W, H, I: Integer; +var + TmpBmp: graphics.TBitmap; + W, H, I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.AutoSizeNow', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.AutoSizeNow', 0 + +@@e_signature: end; - if fAutoSizingNow then Exit; + if fAutoSizingNow then + Exit; fAutoSizingNow := TRUE; TmpBmp := graphics.TBitmap.Create; try @@ -3648,45 +3018,39 @@ begin TmpBmp.Canvas.Font.Style := TFontStyles(Font.FontStyle); if Font.FontHeight > 0 then TmpBmp.Canvas.Font.Height := Font.FontHeight - else - if Font.FontHeight < 0 then - TmpBmp.Canvas.Font.Size := - Font.FontHeight + else if Font.FontHeight < 0 then + TmpBmp.Canvas.Font.Size := -Font.FontHeight else TmpBmp.Canvas.Font.Size := 0; - W := TmpBmp.Canvas.TextWidth( Caption ); - if fsItalic in TFontStyles( Font.FontStyle ) then - Inc( W, TmpBmp.Canvas.TextWidth( ' ' ) ); - H := TmpBmp.Canvas.TextHeight( 'Ap^_' ); + W := TmpBmp.Canvas.TextWidth(Caption); + if fsItalic in TFontStyles(Font.FontStyle) then + Inc(W, TmpBmp.Canvas.TextWidth(' ')); + H := TmpBmp.Canvas.TextHeight('Ap^_'); //Rpt( 'W=' + IntToStr( W ) + ' H=' + IntToStr( H ) ); - if Align in [ caNone, caLeft, caRight ] then - begin - if (glyphBitmap.Width > 0) and (glyphBitmap.Height > 0) then - begin + if Align in [caNone, caLeft, caRight] then begin + if (glyphBitmap.Width > 0) and (glyphBitmap.Height > 0) then begin I := glyphBitmap.Width; if glyphCount > 1 then I := I div glyphCount; - if glyphLayout in [ glyphLeft, glyphRight ] then + if glyphLayout in [glyphLeft, glyphRight] then W := W + I - else - if W < I then - W := I; + else if W < I then + W := I; end; if not (bboNoBorder in options) then - Inc( W, 4 ); + Inc(W, 4); Width := W + fAutoSzX; end; - if Align in [ caNone, caTop, caBottom ] then - begin - if (glyphBitmap.Width > 0) and (glyphBitmap.Height > 0) then - begin + if Align in [caNone, caTop, caBottom] then begin + if (glyphBitmap.Width > 0) and (glyphBitmap.Height > 0) then begin I := glyphBitmap.Height; - if glyphLayout in [ glyphTop, glyphBottom ] then + if glyphLayout in [glyphTop, glyphBottom] then H := H + I + fAutoSzY else H := I; end; if not (bboNoBorder in options) then - Inc( H, 4 ); + Inc(H, 4); Height := H; // + fAutoSzY; end; finally @@ -3698,21 +3062,23 @@ end; function TKOLBitBtn.ClientMargins: TRect; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.ClientMargins', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.ClientMargins', 0 + +@@e_signature: end; - Result := Rect( 3, 3, 3, 3 ); + Result := Rect(3, 3, 3, 3); end; constructor TKOLBitBtn.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.Create', 0 + +@@e_signature: end; inherited; FDefIgnoreDefault := TRUE; @@ -3720,7 +3086,8 @@ begin fAutoSzX := 8; fAutoSzY := 8; FGlyphBitmap := TBitmap.Create; - Height := 22; DefaultHeight := 22; + Height := 22; + DefaultHeight := 22; DefaultWidth := Width; TextAlign := taCenter; VerticalAlign := vaCenter; @@ -3733,45 +3100,47 @@ end; procedure TKOLBitBtn.CreateKOLControl(Recreating: boolean); begin inherited; - FKOLCtrl:=NewBitBtn(KOLParentCtrl, '', [], glyphLeft, 0, 0); + FKOLCtrl := NewBitBtn(KOLParentCtrl, '', [], glyphLeft, 0, 0); end; destructor TKOLBitBtn.Destroy; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.Destroy', 0 + +@@e_signature: end; FGlyphBitmap.Free; if ImageList <> nil then - ImageList.NotifyLinkedComponent( Self, noRemoved ); + ImageList.NotifyLinkedComponent(Self, noRemoved); inherited; end; procedure TKOLBitBtn.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.FirstCreate', 0 + +@@e_signature: end; Caption := Name; inherited; end; -function TKOLBitBtn.GenerateTransparentInits: String; +function TKOLBitBtn.GenerateTransparentInits: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.GenerateTransparentInits', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.GenerateTransparentInits', 0 + +@@e_signature: end; - if autoAdjustSize then - begin + if autoAdjustSize then begin DefaultWidth := Width; DefaultHeight := Height; end; @@ -3780,34 +3149,19 @@ begin Result := Result + '.LikeSpeedButton'; end; -procedure TKOLBitBtn.GenerateTransparentInits_Compact; -var KF: TKOLForm; -begin - if autoAdjustSize then - begin - DefaultWidth := Width; - DefaultHeight := Height; - end; - inherited; - KF := ParentKOLForm; - if (KF = nil) or not KF.FormCompact then Exit; - if LikeSpeedButton then - KF.FormAddCtlCommand( Name, 'TControl.LikeSpeedButton', '' ); -end; - function TKOLBitBtn.NoDrawFrame: Boolean; begin - Result:=HasBorder; + Result := HasBorder; end; -procedure TKOLBitBtn.NotifyLinkedComponent(Sender: TObject; - Operation: TNotifyOperation); +procedure TKOLBitBtn.NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.NotifyLinkedComponent', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.NotifyLinkedComponent', 0 + +@@e_signature: end; inherited; if Operation = noRemoved then @@ -3817,201 +3171,32 @@ end; function TKOLBitBtn.OptionsAsInteger: Integer; begin Result := 0; - if bboImageList in Options then Result := 1; - if bboNoBorder in Options then Result := Result + 2; - if bboNoCaption in Options then Result := Result + 4; - if bboFixed in Options then Result := Result + 8; - if bboFocusRect in Options then Result := Result + 16; -end; - -function TKOLBitBtn.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLBitBtn.P_AssignEvents(SL: TStringList; const AName: String; CheckOnly: Boolean): Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.P_AssignEvents', 0 - @@e_signature: - end; - Result := inherited P_AssignEvents( SL, AName, CheckOnly ); - if Result and CheckOnly then Exit; - Result := Result or - P_DoAssignEvents( SL, AName, [ 'OnTestMouseOver' ], [ @OnTestMouseOver ], [ TRUE ], CheckOnly ); -end; - -function TKOLBitBtn.P_GenerateTransparentInits: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.GenerateTransparentInits', 0 - @@e_signature: - end; - if autoAdjustSize then - begin - DefaultWidth := Width; - DefaultHeight := Height; - end; - Result := inherited P_GenerateTransparentInits; - if LikeSpeedButton then - //Result := Result + '.LikeSpeedButton'; - {P}Result := Result + ' DUP TControl.LikeSpeedButton<1>'; - Result := Result + ' xySwap DelAnsiStr'; -end; - -procedure TKOLBitBtn.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var RName: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.P_SetupFirst', 0 - @@e_signature: - end; - if ImageList = nil then - if Assigned( GlyphBitmap ) and - (GlyphBitmap.Width <> 0) and (GlyphBitmap.Height <> 0) then - begin - RName := ParentKOLForm.FormName + '_' + Name; - Rpt( 'Prepare resource ' + RName + ' (' + UpperCase( Name + '_BITMAP' ) + ')', - WHITE ); - GenerateBitmapResource( GlyphBitmap, UpperCase( Name + '_BITMAP' ), RName, - fUpdated, AllowBitmapCompression ); - SL.Add( Prefix + '{$R ' + RName + '.res}' ); - end - else - begin - P_ProvideFakeType( SL, 'type TImageList_ = object(TImageList) end;' ); - end; - inherited; - if (Height = DefaultHeight) or autoAdjustSize then - if imageList <> nil then - if ImageIndex >= 0 then - //SL.Add( Prefix + AName + '.Height := ' + IntToStr( Height ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( Height ) + ') C1 TControl_.SetHeight<2>' ); - if (Width = DefaultWidth) or autoAdjustSize then - if imageList <> nil then - if ImageIndex >= 0 then - //SL.Add( Prefix + AName + '.Width := ' + IntToStr( Width ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( Width ) + ') C1 TControl_.SetWidth<2>' ); - if RepeatInterval > 0 then - //SL.Add( Prefix + AName + '.RepeatInterval := ' + IntToStr( RepeatInterval ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( RepeatInterval ) + ') C1 AddWord_Store ##TControl_.fRepeatInterval' ); - if Flat then - //SL.Add( Prefix + AName + '.Flat := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetFlat<2>' ); - if BitBtnDrawMnemonic then - //SL.Add( Prefix + AName + '.BitBtnDrawMnemonic := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetBitBtnDrawMnemonic<2>' ); - if TextShiftX <> 0 then - //SL.Add( Prefix + AName + '.TextShiftX := ' + IntToStr( TextShiftX ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( TextShiftX ) + ') ' + - 'C1 AddWord_Store ##TControl_.fTextShiftX' ); - if TextShiftY <> 0 then - //SL.Add( Prefix + AName + '.TextShiftY := ' + IntToStr( TextShiftY ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( TextShiftY ) + ') ' + - 'C1 AddWord_Store ##TControl_.fTextShiftY' ); -end; - -function TKOLBitBtn.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -var S, U, C: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.P_SetupParams', 0 - @@e_signature: - end; - S := ' L(0)'; - U := ' L(0)'; - if (GlyphBitmap <> nil) and - (GlyphBitmap.Width <> 0) and (GlyphBitmap.Height <> 0) then - begin - //S := 'LoadBmp( hInstance, ' + String2Pascal(UpperCase( Name + '_BITMAP' )) + - // ', Result )'; - {P}S := ' LoadAnsiStr ' + P_String2Pascal( UpperCase( Name + '_BITMAP' ) ) + - #13#10' LoadSELF xySwap' + - #13#10' Load_hInstance LoadBmp<3> RESULT xySwap DelAnsiStr' ; - //U := IntToStr( GlyphCount ); - {P}U := ' L(' + IntToStr( GlyphCount ) + ')'; - end - else - if (ImageList <> nil) then - begin - if ImageList.ParentFORM.Name = ParentForm.Name then - //S := 'Result.' + ImageList.Name + '.Handle' - {P}S := ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - ImageList.Name + ' TImageList_.GetHandle<1> RESULT' - else //S := ImageList.ParentFORM.Name +'.'+ ImageList.Name + '.Handle'; - {P}S := ' Load4 ####(' + ImageList.ParentForm.Name + ') ' + - #13#10'AddWord_LoadRef ##T' + ImageList.ParentForm.Name + '.' + ImageList.Name + - ' TImageList_.GetHandle<1> RESULT'; - if GlyphCount > 0 then - //U := '$' + Int2Hex( GlyphCount shl 16, 5 ) + ' + ' + IntToStr( ImageIndex ) - {P}U := ' L($' + Int2Hex( GlyphCount shl 16, 5 ) + ' + ' + IntToStr( ImageIndex ) + - ')' - else - //U := IntToStr( ImageIndex ); - {P}U := ' L(' + IntToStr( ImageIndex ) + ')'; - end; - if action = nil then - C := P_StringConstant('Caption',Caption) - else - C := ' LoadAnsiStr #0 '; - //Result := AParent + ', ' + C + ', ' + - // BitBtnOptions( Options ) + ', ' + - // Layouts[ GlyphLayout ] + ', ' + S + ', ' + U; - {P}Result := - C + ' C2R' + - #13#10' L(' + IntToStr( Integer( GlyphLayout ) ) + ') ' + - #13#10 + S + - #13#10 + U + - #13#10' L(' + IntToStr( OptionsAsInteger ) + ') R2C' + - #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - Remove_Result_dot( AParent ); - nparams := 6; -end; - -procedure TKOLBitBtn.P_SetupTextAlign(SL: TStrings; const AName: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetupTextAlign', 0 - @@e_signature: - end; - if TextAlign <> taCenter then - //SL.Add( ' ' + AName + '.TextAlign := ' + TextAligns[ TextAlign ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( TextAlign ) ) + ') C1 ' + - ' TControl_.SetTextAlign<2>' ); - if VerticalAlign <> vaCenter then - //SL.Add( ' ' + AName + '.VerticalAlign := ' + VertAligns[ VerticalAlign ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( VerticalAlignAsKOLVerticalAlign ) + ') C1 ' + - ' TControl_.SetVerticalAlign<2>' ); + if bboImageList in Options then + Result := 1; + if bboNoBorder in Options then + Result := Result + 2; + if bboNoCaption in Options then + Result := Result + 4; + if bboFixed in Options then + Result := Result + 8; + if bboFocusRect in Options then + Result := Result + 16; end; procedure TKOLBitBtn.RecalcSize; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.RecalcSize', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.RecalcSize', 0 + +@@e_signature: end; - if (ImageList <> nil) or - (GlyphBitmap.Width <> 0) and (GlyphBitmap.Height <> 0) then - begin + if (ImageList <> nil) or (GlyphBitmap.Width <> 0) and (GlyphBitmap.Height <> 0) then begin DefaultWidth := 0; DefaultHeight := 0; end - else - begin + else begin DefaultWidth := 64; DefaultHeight := 22; end; @@ -4019,7 +3204,8 @@ end; procedure TKOLBitBtn.SetAllowBitmapCompression(const Value: Boolean); begin - if FAllowBitmapCompression = Value then Exit; + if FAllowBitmapCompression = Value then + Exit; FAllowBitmapCompression := Value; Change; end; @@ -4027,10 +3213,11 @@ end; procedure TKOLBitBtn.SetautoAdjustSize(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetautoAdjustSize', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetautoAdjustSize', 0 + +@@e_signature: end; FautoAdjustSize := Value; Change; @@ -4039,10 +3226,11 @@ end; procedure TKOLBitBtn.SetBitBtnDrawMnemonic(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetBitBtnDrawMnemonic', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetBitBtnDrawMnemonic', 0 + +@@e_signature: end; FBitBtnDrawMnemonic := Value; Change; @@ -4051,10 +3239,11 @@ end; procedure TKOLBitBtn.SetFlat(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetFlat', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetFlat', 0 + +@@e_signature: end; FFlat := Value; Change; @@ -4063,19 +3252,18 @@ end; procedure TKOLBitBtn.SetGlyphBitmap(const Value: TBitmap); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetGlyphBitmap', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetGlyphBitmap', 0 + +@@e_signature: end; - if (Value <> nil) and (not Value.Empty) then - begin - FGlyphBitmap.Assign( Value ); + if (Value <> nil) and (not Value.Empty) then begin + FGlyphBitmap.Assign(Value); FOptions := FOptions - [bboImageList]; FImageList := nil; end - else - begin + else begin {FGlyphBitmap.Width := 0; FGlyphBitmap.Height := 0;} FGlyphBitmap.Free; @@ -4085,8 +3273,7 @@ begin if FGlyphBitmap.Height > 0 then FGlyphCount := FGlyphBitmap.Width div FGlyphBitmap.Height; RecalcSize; - if (DefaultWidth <> 0) and (DefaultHeight <> 0) then - begin + if (DefaultWidth <> 0) and (DefaultHeight <> 0) then begin Width := DefaultWidth; Height := DefaultHeight; end; @@ -4096,16 +3283,18 @@ end; procedure TKOLBitBtn.SetGlyphCount(Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetGlyphCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetGlyphCount', 0 + +@@e_signature: end; if Value < 0 then Value := 0; if Value > 5 then Value := 5; - if Value = FGlyphCount then Exit; + if Value = FGlyphCount then + Exit; FGlyphCount := Value; Change; end; @@ -4113,10 +3302,11 @@ end; procedure TKOLBitBtn.SetGlyphLayout(const Value: TGlyphLayout); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetGlyphLayout', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetGlyphLayout', 0 + +@@e_signature: end; FGlyphLayout := Value; if AutoSize then @@ -4127,10 +3317,11 @@ end; procedure TKOLBitBtn.SetImageIndex(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetImageIndex', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetImageIndex', 0 + +@@e_signature: end; FImageIndex := Value; Change; @@ -4139,22 +3330,22 @@ end; procedure TKOLBitBtn.SetImageList(const Value: TKOLImageList); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetImageList', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetImageList', 0 + +@@e_signature: end; if FImageList <> nil then - FImageList.NotifyLinkedComponent( Self, noRemoved ); + FImageList.NotifyLinkedComponent(Self, noRemoved); FImageList := Value; - if (Value <> nil) and (Value is TKOLImageList) then - begin + if (Value <> nil) and (Value is TKOLImageList) then begin FGlyphBitmap.Width := 0; FGlyphBitmap.Height := 0; FOptions := FOptions + [bboImageList]; - Value.AddToNotifyList( Self ); + Value.AddToNotifyList(Self); end - else + else FOptions := FOptions - [bboImageList]; Change; end; @@ -4162,10 +3353,11 @@ end; procedure TKOLBitBtn.SetOnTestMouseOver(const Value: TOnTestMouseOver); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetOnTestMouseOver', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetOnTestMouseOver', 0 + +@@e_signature: end; FOnTestMouseOver := Value; Change; @@ -4174,25 +3366,27 @@ end; procedure TKOLBitBtn.SetOptions(Value: TBitBtnOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetOptions', 0 + +@@e_signature: end; - Value := Value - [ bboImageList ]; - if Assigned( ImageList ) then + Value := Value - [bboImageList]; + if Assigned(ImageList) then Value := Value + [bboImageList]; FOptions := Value; Change; end; -function BitBtnOptions( Options: TBitBtnOptions ): String; +function BitBtnOptions(Options: TBitBtnOptions): string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'BitBtnOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'BitBtnOptions', 0 + +@@e_signature: end; Result := ''; if bboImageList in Options then @@ -4205,19 +3399,20 @@ begin Result := Result + 'bboFixed, '; if bboFocusRect in Options then Result := Result + 'bboFocusRect, '; - Result := Trim( Result ); + Result := Trim(Result); if Result <> '' then - Result := Copy( Result, 1, Length( Result ) - 1 ); + Result := Copy(Result, 1, Length(Result) - 1); Result := '[ ' + Result + ' ]'; end; procedure TKOLBitBtn.SetRepeatInterval(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetRepeatInterval', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetRepeatInterval', 0 + +@@e_signature: end; FRepeatInterval := Value; Change; @@ -4226,10 +3421,11 @@ end; procedure TKOLBitBtn.SetTextShiftX(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetTextShiftX', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetTextShiftX', 0 + +@@e_signature: end; FTextShiftX := Value; Change; @@ -4238,220 +3434,142 @@ end; procedure TKOLBitBtn.SetTextShiftY(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetTextShiftY', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetTextShiftY', 0 + +@@e_signature: end; FTextShiftY := Value; Change; end; -procedure TKOLBitBtn.SetupConstruct_Compact; -var KF: TKOLForm; - C: String; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewBitBtn', TRUE, TRUE, '' ); - C := Caption; - if not KF.AssignTextToControls then - C := ''; - KF.FormAddStrParameter( C ); - KF.FormAddNumParameter( OptionsAsInteger ); - KF.FormAddNumParameter( Integer( GlyphLayout ) ); - if (GlyphBitmap <> nil) and - (GlyphBitmap.Width <> 0) and (GlyphBitmap.Height <> 0) then - begin - KF.FormAddStrParameter( Name + '_BITMAP' ); - KF.FormAddNumParameter( GlyphCount ); - end - else - begin - KF.FormAddStrParameter( '' ); - KF.FormAddNumParameter( 0 ); - end; -end; - -procedure TKOLBitBtn.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -var RName: String; - KF: TKOLForm; +procedure TKOLBitBtn.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +var + RName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetupFirst', 0 - @@e_signature: - end; + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetupFirst', 0 - KF := ParentKOLForm; +@@e_signature: + end; if ImageList = nil then - if Assigned( GlyphBitmap ) and - (GlyphBitmap.Width <> 0) and (GlyphBitmap.Height <> 0) then - begin - RName := ParentKOLForm.FormName + '_' + Name; - Rpt( 'Prepare resource ' + RName + ' (' + UpperCase( Name + '_BITMAP' ) + - ')', WHITE ); - GenerateBitmapResource( GlyphBitmap, UpperCase( Name + '_BITMAP' ), RName, fUpdated, - AllowBitmapCompression ); - if (KF <> nil) and KF.FormCompact and SupportsFormCompact then - begin - (SL as TFormStringList).OnAdd := nil; - SL.Add( Prefix + '{$R ' + RName + '.res}' ); - (SL as TFormStringList).OnAdd := KF.DoFlushFormCompact; - end else - SL.Add( Prefix + '{$R ' + RName + '.res}' ); - end; + if Assigned(GlyphBitmap) and (GlyphBitmap.Width <> 0) and (GlyphBitmap.Height <> 0) then begin + RName := ParentKOLForm.FormName + '_' + Name; + Rpt('Prepare resource ' + RName + ' (' + UpperCase(Name + '_BITMAP') + ')', WHITE); + GenerateBitmapResource(GlyphBitmap, UpperCase(Name + '_BITMAP'), RName, + fUpdated, AllowBitmapCompression); + SL.Add(Prefix + '{$R ' + RName + '.res}'); + end; inherited; - if (Height = DefaultHeight) or autoAdjustSize then - if imageList <> nil then - if ImageIndex >= 0 then - if (KF <> nil) and KF.FormCompact and SupportsFormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetHeight', '' ); - KF.FormAddNumParameter( Height ); - end else - SL.Add( Prefix + AName + '.Height := ' + IntToStr( Height ) + ';' ); - if (Width = DefaultWidth) or autoAdjustSize then - if imageList <> nil then - if ImageIndex >= 0 then - if (KF <> nil) and KF.FormCompact and SupportsFormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetWidth', '' ); - KF.FormAddNumParameter( Width ); - end else - SL.Add( Prefix + AName + '.Width := ' + IntToStr( Width ) + ';' ); + if (Height = DefaultHeight) or autoAdjustSize then + if imageList <> nil then + if ImageIndex >= 0 then + SL.Add(Prefix + AName + '.Height := ' + IntToStr(Height) + ';'); - if RepeatInterval > 0 then - if (KF <> nil) and KF.FormCompact and SupportsFormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRepeatInterval', '' ); - KF.FormAddNumParameter( RepeatInterval ); - end else - SL.Add( Prefix + AName + '.RepeatInterval := ' + IntToStr( RepeatInterval ) + ';' ); + if (Width = DefaultWidth) or autoAdjustSize then + if imageList <> nil then + if ImageIndex >= 0 then + SL.Add(Prefix + AName + '.Width := ' + IntToStr(Width) + ';'); - if Flat then - if (KF <> nil) and KF.FormCompact and SupportsFormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetFlat', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.Flat := TRUE;' ); + if RepeatInterval > 0 then + SL.Add(Prefix + AName + '.RepeatInterval := ' + IntToStr(RepeatInterval) + ';'); - if BitBtnDrawMnemonic then - if (KF <> nil) and KF.FormCompact and SupportsFormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetBitBtnDrawMnemonic', '' ); - end else - SL.Add( Prefix + AName + '.BitBtnDrawMnemonic := TRUE;' ); + if Flat then + SL.Add(Prefix + AName + '.Flat := TRUE;'); - if TextShiftX <> 0 then - if (KF <> nil) and KF.FormCompact and SupportsFormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetTextShiftX', '' ); - KF.FormAddNumParameter( TextShiftX ); - end else - SL.Add( Prefix + AName + '.TextShiftX := ' + IntToStr( TextShiftX ) + ';' ); + if BitBtnDrawMnemonic then + SL.Add(Prefix + AName + '.BitBtnDrawMnemonic := TRUE;'); - if TextShiftY <> 0 then - if (KF <> nil) and KF.FormCompact and SupportsFormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetTextShiftY', '' ); - KF.FormAddNumParameter( TextShiftY ); - end else - SL.Add( Prefix + AName + '.TextShiftY := ' + IntToStr( TextShiftY ) + ';' ); + if TextShiftX <> 0 then + SL.Add(Prefix + AName + '.TextShiftX := ' + IntToStr(TextShiftX) + ';'); + if TextShiftY <> 0 then + SL.Add(Prefix + AName + '.TextShiftY := ' + IntToStr(TextShiftY) + ';'); end; -function TKOLBitBtn.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -const Layouts: array[ TGlyphLayout ] of String = ( 'glyphLeft', 'glyphTop', - 'glyphRight', 'glyphBottom', 'glyphOver' ); +function TKOLBitBtn.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +const + Layouts: array[TGlyphLayout] of string = ('glyphLeft', 'glyphTop', + 'glyphRight', 'glyphBottom', 'glyphOver'); var - S, U: String; + S, U: string; {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetupParams', 0 + +@@e_signature: end; S := '0'; U := '0'; - if (GlyphBitmap <> nil) and - (GlyphBitmap.Width <> 0) and (GlyphBitmap.Height <> 0) then - begin - S := 'LoadBmp( hInstance, ' + String2Pascal(UpperCase( Name + '_BITMAP' ), '+') + - ', Result )'; - U := IntToStr( GlyphCount ); + if (GlyphBitmap <> nil) and (GlyphBitmap.Width <> 0) and (GlyphBitmap.Height <> 0) then begin + S := 'LoadBmp( hInstance, ' + String2Pascal(UpperCase(Name + '_BITMAP'), '+') + ', Result )'; + U := IntToStr(GlyphCount); end - else - if (ImageList <> nil) then - begin + else if (ImageList <> nil) then begin if ImageList.ParentFORM.Name = ParentForm.Name then S := 'Result.' + ImageList.Name + '.Handle' - else S := ImageList.ParentFORM.Name +'.'+ ImageList.Name + '.Handle'; - if GlyphCount > 0 then - U := '$' + Int2Hex( GlyphCount shl 16, 5 ) + ' + ' + IntToStr( ImageIndex ) else - U := IntToStr( ImageIndex ); + S := ImageList.ParentFORM.Name + '.' + ImageList.Name + '.Handle'; + if GlyphCount > 0 then + U := '$' + Int2Hex(GlyphCount shl 16, 5) + ' + ' + IntToStr(ImageIndex) + else + U := IntToStr(ImageIndex); end; - if (action = nil) and - (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - C := StringConstant('Caption', Caption) + if (action = nil) and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then + C := StringConstant('Caption', Caption) else - C := ''''''; + C := ''''''; {$IFDEF _D2009orHigher} - if C <> '''''' then - begin - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; - end; + if C <> '''''' then begin + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[i])); + C := C2; + end; {$ENDIF} - Result := AParent + ', ' + C + ', ' + - BitBtnOptions( Options ) + ', ' + - Layouts[ GlyphLayout ] + ', ' + S + ', ' + U; + Result := AParent + ', ' + C + ', ' + BitBtnOptions(Options) + ', ' + Layouts[GlyphLayout] + + ', ' + S + ', ' + U; end; -procedure TKOLBitBtn.SetupTextAlign(SL: TStrings; const AName: String); +procedure TKOLBitBtn.SetupTextAlign(SL: TStrings; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.SetupTextAlign', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.SetupTextAlign', 0 + +@@e_signature: end; - if TextAlign <> taCenter then - GenerateTextAlign( SL, AName ); + if TextAlign <> taCenter then + GenerateTextAlign(SL, AName); - if VerticalAlign <> vaCenter then - GenerateVerticalAlign( SL, AName ); -end; - -function TKOLBitBtn.SupportsFormCompact: Boolean; -begin - Result := ImageList = nil; + if VerticalAlign <> vaCenter then + GenerateVerticalAlign(SL, AName); end; function TKOLBitBtn.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; @@ -4461,15 +3579,18 @@ end; constructor TKOLGradientPanel.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.Create', 0 + +@@e_signature: end; inherited; - Width := 40; DefaultWidth := Width; - Height := 40; DefaultHeight := Height; - ControlStyle := ControlStyle + [ csAcceptsControls ]; + Width := 40; + DefaultWidth := Width; + Height := 40; + DefaultHeight := Height; + ControlStyle := ControlStyle + [csAcceptsControls]; FColor1 := clBlue; FColor2 := clNavy; //Transparent := TRUE; @@ -4480,209 +3601,203 @@ end; function TKOLGradientPanel.NoDrawFrame: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.NoDrawFrame', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.NoDrawFrame', 0 + +@@e_signature: end; Result := TRUE; end; procedure TKOLGradientPanel.Paint; - function Ceil( X: Double ): Integer; + function Ceil(X: Double): Integer; begin - Result := Round( X ); + Result := Round(X); end; + const SQRT2 = 1.4142135623730950488016887242097; - var // R:TRect; // Flag:DWord; // Delta: Integer; - CR:TRect; - W,H,WH,I:Integer; - BMP:TBitmap; - C:TColor; - R,G,B,R1,G1,B1:Byte; - + CR: TRect; + W, H, WH, I: Integer; + BMP: TBitmap; + C: TColor; + R, G, B, R1, G1, B1: Byte; RC, RF, R0: TRect; - C2: TColor; + C2: TColor; R2, G2, B2: Integer; DX1, DX2, DY1, DY2, DR, DG, DB, K: Double; // PaintStruct: TPaintStruct; Br: HBrush; Rgn: HRgn; - Poly: array[ 0..3 ] of TPoint; + Poly: array[0..3] of TPoint; // OldPaintDC: HDC; // RRR:TRect; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.Paint', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.Paint', 0 + +@@e_signature: end; - PrepareCanvasFontForWYSIWIGPaint( Canvas ); + PrepareCanvasFontForWYSIWIGPaint(Canvas); case fGradientStyle of - gsHorizontal,gsVertical: - begin - CR := ClientRect; - W := 1; - H := CR.Bottom; - WH := H; + gsHorizontal, gsVertical: + begin + CR := ClientRect; + W := 1; + H := CR.Bottom; + WH := H; //Bmp := nil; - if fGradientStyle = gsHorizontal then - begin - W := CR.Right; - H := 1; - WH := W; - end; - Bmp :=TBitmap.Create(); - Bmp.Width:=W; - Bmp.Height:=H; - C := Color2RGB( fColor1 ); - R := C shr 16; - G := (C shr 8) and $FF; - B := C and $FF; - C := Color2RGB( fColor2 ); - R1 := C shr 16; - G1 := (C shr 8) and $FF; - B1 := C and $FF; - for I := 0 to WH-1 do - begin - C := ((( R + (R1 - R) * I div WH ) and $FF) shl 16) or - ((( G + (G1 - G) * I div WH ) and $FF) shl 8) or - ( B + (B1 - B) * I div WH ) and $FF; + if fGradientStyle = gsHorizontal then begin + W := CR.Right; + H := 1; + WH := W; + end; + BMP := TBitmap.Create(); + BMP.Width := W; + BMP.Height := H; + C := Color2RGB(fColor1); + R := C shr 16; + G := (C shr 8) and $FF; + B := C and $FF; + C := Color2RGB(fColor2); + R1 := C shr 16; + G1 := (C shr 8) and $FF; + B1 := C and $FF; + for I := 0 to WH - 1 do begin + C := (((R + (R1 - R) * I div WH) and $FF) shl 16) or (((G + (G1 - G) * + I div WH) and $FF) shl 8) or (B + (B1 - B) * I div WH) and $FF; - if fGradientStyle = gsVertical then - Bmp.Canvas.Pixels[0,I]:=C - else - Bmp.Canvas.Pixels[I,0]:=C; - end; - Canvas.StretchDraw(CR,BMP); - Bmp.Free; {YS}//! Memory leak fix - end; + if fGradientStyle = gsVertical then + BMP.Canvas.Pixels[0, I] := C + else + BMP.Canvas.Pixels[I, 0] := C; + end; + Canvas.StretchDraw(CR, BMP); + BMP.Free; {YS}//! Memory leak fix + end; - gsRectangle, gsRombic, gsElliptic: - begin + gsRectangle, gsRombic, gsElliptic: + begin - C := Color2RGB( fColor2 ); - R2 := C and $FF; - G2 := (C shr 8) and $FF; - B2 := (C shr 16) and $FF; - C := Color2RGB( fColor1 ); - R1 := C and $FF; - G1 := (C shr 8) and $FF; - B1 := (C shr 16) and $FF; - DR := (R2 - R1) / 256; - DG := (G2 - G1) / 256; - DB := (B2 - B1) / 256; - {OldPaintDC :=} Canvas.handle;//fPaintDC; + C := Color2RGB(fColor2); + R2 := C and $FF; + G2 := (C shr 8) and $FF; + B2 := (C shr 16) and $FF; + C := Color2RGB(fColor1); + R1 := C and $FF; + G1 := (C shr 8) and $FF; + B1 := (C shr 16) and $FF; + DR := (R2 - R1) / 256; + DG := (G2 - G1) / 256; + DB := (B2 - B1) / 256; + {OldPaintDC :=} Canvas.handle; //fPaintDC; // Self_.fPaintDC := Msg.wParam; // if Self_.fPaintDC = 0 then // Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct ); - RC := ClientRect; - case fGradientStyle of - gsRombic: - RF := MakeRect( 0, 0, RC.Right div 128, RC.Bottom div 128 ); - gsElliptic: - RF := MakeRect( 0, 0, Ceil( RC.Right / 256 * SQRT2 ), Ceil( RC.Bottom / 256 * SQRT2 ) ); - else - RF := MakeRect( 0, 0, RC.Right div 256, RC.Bottom div 256 ); - end; - case fGradientStyle of - gsRectangle, gsRombic, gsElliptic: - begin - case FGradientLayout of - glCenter, glTop, glBottom: - OffsetRect( RF, (RC.Right - RF.Right) div 2, 0 ); - glTopRight, glBottomRight, glRight: - OffsetRect( RF, RC.Right - RF.Right div 2, 0 ); - glTopLeft, glBottomLeft, glLeft: - OffsetRect( RF, -RF.Right div 2, 0 ); - end; - case FGradientLayout of - glCenter, glLeft, glRight: - OffsetRect( RF, 0, (RC.Bottom - RF.Bottom) div 2 ); - glBottom, glBottomLeft, glBottomRight: - OffsetRect( RF, 0, RC.Bottom - RF.Bottom div 2 ); - glTop, glTopLeft, glTopRight: - OffsetRect( RF, 0, -RF.Bottom div 2 ); - end; - end; - end; - DX1 := (-RF.Left) / 255; - DY1 := (-RF.Top) / 255; - DX2 := (RC.Right - RF.Right) / 255; - DY2 := (RC.Bottom - RF.Bottom) / 255; - case fGradientStyle of - gsRombic, gsElliptic: - begin - if DX2 < -DX1 then DX2 := -DX1; - if DY2 < -DY1 then DY2 := -DY1; - K := 2; - if fGradientStyle = gsElliptic then K := SQRT2; - DX2 := DX2 * K; - DY2 := DY2 * K; - DX1 := -DX2; - DY1 := -DY2; - end; - end; - C2 := C; - for I := 0 to 255 do - begin - if (I < 255) then - begin - C2 := TColor( (( Ceil( B1 + DB * (I+1) ) and $FF) shl 16) or - (( Ceil( G1 + DG * (I+1) ) and $FF) shl 8) or - Ceil( R1 + DR * (I+1) ) and $FF ); - if (fGradientStyle in [gsRombic,gsElliptic,gsRectangle]) and - (C2 = C) then continue; - end; - Br := CreateSolidBrush( C ); - R0 := MakeRect( Ceil( RF.Left + DX1 * I ), - Ceil( RF.Top + DY1 * I ), - Ceil( RF.Right + DX2 * I ), - Ceil( RF.Bottom + DY2 * I ) ); - Rgn := 0; - case fGradientStyle of - gsRectangle: - Rgn := CreateRectRgnIndirect( R0 ); - gsRombic: - begin - Poly[ 0 ].x := R0.Left; - Poly[ 0 ].y := R0.Top + (R0.Bottom - R0.Top) div 2; - Poly[ 1 ].x := R0.Left + (R0.Right - R0.Left) div 2; - Poly[ 1 ].y := R0.Top; - Poly[ 2 ].x := R0.Right; - Poly[ 2 ].y := Poly[ 0 ].y; - Poly[ 3 ].x := Poly[ 1 ].x; - Poly[ 3 ].y := R0.Bottom; - Rgn := CreatePolygonRgn( Poly[ 0 ].x, 4, ALTERNATE ); - end; - gsElliptic: - Rgn := CreateEllipticRgnIndirect( R0 ); - end; - if Rgn <> 0 then - begin - if Rgn <> NULLREGION then - begin - Windows.FillRgn({ fPaintDC}Canvas.Handle, Rgn, Br ); - ExtSelectClipRgn( {fPaintDC}Canvas.Handle, Rgn, RGN_DIFF ); - end; - DeleteObject( Rgn ); - end; - DeleteObject( Br ); - C := C2; - end; + RC := ClientRect; + case fGradientStyle of + gsRombic: + RF := MakeRect(0, 0, RC.Right div 128, RC.Bottom div 128); + gsElliptic: + RF := MakeRect(0, 0, Ceil(RC.Right / 256 * SQRT2), Ceil(RC.Bottom / 256 * SQRT2)); + else + RF := MakeRect(0, 0, RC.Right div 256, RC.Bottom div 256); + end; + case fGradientStyle of + gsRectangle, gsRombic, gsElliptic: + begin + case FGradientLayout of + glCenter, glTop, glBottom: + OffsetRect(RF, (RC.Right - RF.Right) div 2, 0); + glTopRight, glBottomRight, glRight: + OffsetRect(RF, RC.Right - RF.Right div 2, 0); + glTopLeft, glBottomLeft, glLeft: + OffsetRect(RF, -RF.Right div 2, 0); + end; + case FGradientLayout of + glCenter, glLeft, glRight: + OffsetRect(RF, 0, (RC.Bottom - RF.Bottom) div 2); + glBottom, glBottomLeft, glBottomRight: + OffsetRect(RF, 0, RC.Bottom - RF.Bottom div 2); + glTop, glTopLeft, glTopRight: + OffsetRect(RF, 0, -RF.Bottom div 2); + end; + end; + end; + DX1 := (-RF.Left) / 255; + DY1 := (-RF.Top) / 255; + DX2 := (RC.Right - RF.Right) / 255; + DY2 := (RC.Bottom - RF.Bottom) / 255; + case fGradientStyle of + gsRombic, gsElliptic: + begin + if DX2 < -DX1 then + DX2 := -DX1; + if DY2 < -DY1 then + DY2 := -DY1; + K := 2; + if fGradientStyle = gsElliptic then + K := SQRT2; + DX2 := DX2 * K; + DY2 := DY2 * K; + DX1 := -DX2; + DY1 := -DY2; + end; + end; + C2 := C; + for I := 0 to 255 do begin + if (I < 255) then begin + C2 := TColor(((Ceil(B1 + DB * (I + 1)) and $FF) shl 16) or ((Ceil(G1 + + DG * (I + 1)) and $FF) shl 8) or Ceil(R1 + DR * (I + 1)) and $FF); + if (fGradientStyle in [gsRombic, gsElliptic, gsRectangle]) and (C2 = C) then + continue; + end; + Br := CreateSolidBrush(C); + R0 := MakeRect(Ceil(RF.Left + DX1 * I), Ceil(RF.Top + DY1 * I), Ceil(RF.Right + + DX2 * I), Ceil(RF.Bottom + DY2 * I)); + Rgn := 0; + case fGradientStyle of + gsRectangle: + Rgn := CreateRectRgnIndirect(R0); + gsRombic: + begin + Poly[0].X := R0.Left; + Poly[0].y := R0.Top + (R0.Bottom - R0.Top) div 2; + Poly[1].X := R0.Left + (R0.Right - R0.Left) div 2; + Poly[1].y := R0.Top; + Poly[2].X := R0.Right; + Poly[2].y := Poly[0].y; + Poly[3].X := Poly[1].X; + Poly[3].y := R0.Bottom; + Rgn := CreatePolygonRgn(Poly[0].X, 4, ALTERNATE); + end; + gsElliptic: + Rgn := CreateEllipticRgnIndirect(R0); + end; + if Rgn <> 0 then begin + if Rgn <> NULLREGION then begin + Windows.FillRgn({ fPaintDC}Canvas.Handle, Rgn, Br); + ExtSelectClipRgn( {fPaintDC}Canvas.Handle, Rgn, RGN_DIFF); + end; + DeleteObject(Rgn); + end; + DeleteObject(Br); + C := C2; + end; // if Self_.fPaintDC <> HDC( Msg.wParam ) then // EndPaint( Self_.fHandle, PaintStruct ); // Self_.fPaintDC := OldPaintDC; - end; + end; end; //case @@ -4690,69 +3805,20 @@ begin end; -function TKOLGradientPanel.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLGradientPanel.P_SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if GradientStyle = gsHorizontal then - //SL.Add( Prefix + AName + '.GradientStyle := gsHorizontal;' ); - {P}SL.Add( ' L(' + IntToStr( Integer( gsHorizontal ) ) + ') C1 ' + - 'TControl_.SetGradientStyle<2>' ); - if HasBorder then - //SL.Add( Prefix + AName + '.HasBorder := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetHasBorder<2>' ); -end; - const - GradientLayouts: array[ TGradientLayout ] of String = ( 'glTopLeft', - 'glTop', 'glTopRight', - 'glLeft', 'glCenter', 'glRight', - 'glBottomLeft', 'glBottom', 'glBottomRight' ); - GradientStyles: array[ TGradientStyle ] of String = ( - 'gsVertical', 'gsHorizontal', 'gsRectangle', 'gsElliptic', 'gsRombic', - 'gsTopToBottom', 'gsBottomToTop' ); -function TKOLGradientPanel.P_SetupParams(const AName, - AParent: String; var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.SetupParams', 0 - @@e_signature: - end; - nparams := 3; - Result := ''; - //Result := AParent + ', ' + Color2Str( FColor1 ) + ', ' + Color2Str( FColor2 ); - if TypeName <> 'GradientPanel' then - begin - {P}Result := ' L(' + IntToStr( Integer( GradientLayout ) ) + ')' + - ' L(' + IntToStr( Integer( GradientStyle ) ) + ')'; - nparams := 5; - end; - Result := Result + ' L($' + IntToHex( FColor2, 6 ) + ')' + - #13#10' L($' + IntToHex( FColor1, 6 ) + ')' + - #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - Remove_Result_dot( AParent ); -end; + GradientLayouts: array[TGradientLayout] of string = ('glTopLeft', 'glTop', + 'glTopRight', 'glLeft', 'glCenter', 'glRight', 'glBottomLeft', 'glBottom', 'glBottomRight'); + GradientStyles: array[TGradientStyle] of string = ('gsVertical', + 'gsHorizontal', 'gsRectangle', 'gsElliptic', 'gsRombic', 'gsTopToBottom', 'gsBottomToTop'); procedure TKOLGradientPanel.SetColor1(const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.SetColor1', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.SetColor1', 0 + +@@e_signature: end; FColor1 := Value; Invalidate; @@ -4762,24 +3828,25 @@ end; procedure TKOLGradientPanel.SetColor2(const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.SetColor2', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.SetColor2', 0 + +@@e_signature: end; FColor2 := Value; Invalidate; Change; end; -procedure TKOLGradientPanel.SetgradientLayout( - const Value: TGradientLayout); +procedure TKOLGradientPanel.SetgradientLayout(const Value: TGradientLayout); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.SetgradientLayout', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.SetgradientLayout', 0 + +@@e_signature: end; FgradientLayout := Value; Invalidate; @@ -4789,113 +3856,73 @@ end; procedure TKOLGradientPanel.SetgradientStyle(const Value: TGradientStyle); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.SetgradientStyle', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.SetgradientStyle', 0 + +@@e_signature: end; FgradientStyle := Value; Invalidate; Change; end; -procedure TKOLGradientPanel.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNew' + TypeName, TRUE, TRUE, '' ); - KF.FormAddNumParameter( Integer( (Color1 shl 1) or (Color1 shr 31) ) ); - KF.FormAddNumParameter( Integer( (Color2 shl 1) or (Color2 shr 31) ) ); - if TypeName = 'GradientPanelEx' then - begin - KF.FormAddNumParameter( Integer( GradientStyle ) ); - KF.FormAddNumParameter( Integer( GradientLayout ) ); - end; -end; - -procedure TKOLGradientPanel.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -var KF: TKOLForm; +procedure TKOLGradientPanel.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if TypeName = 'GradientPanel' then - if GradientStyle >= gsHorizontal then - if (KF <> nil) and KF.FormCompact then - begin - if Integer( GradientStyle ) = 1 then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetGradientStyle', '' ); - // Param = 1 - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetGradienStyle', '' ); - KF.FormAddNumParameter( Integer( GradientStyle ) ); - end; - end else - SL.Add( Prefix + AName + '.GradientStyle := KOL.' + - GradientStyles[ GradientStyle ] + ';' ); - if HasBorder then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetHasBorder', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.HasBorder := TRUE;' ); + if TypeName = 'GradientPanel' then + if GradientStyle >= gsHorizontal then + SL.Add(Prefix + AName + '.GradientStyle := KOL.' + GradientStyles[GradientStyle] + ';'); + if HasBorder then + SL.Add(Prefix + AName + '.HasBorder := TRUE;'); end; -function TKOLGradientPanel.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLGradientPanel.SetupParams(const AName, AParent: TDelphiString): TDelphiString; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.SetupParams', 0 + +@@e_signature: end; - Result := AParent + ', ' + Color2Str( FColor1 ) + ', ' + Color2Str( FColor2 ); + Result := AParent + ', ' + Color2Str(FColor1) + ', ' + Color2Str(FColor2); if TypeName <> 'GradientPanel' then //if GradientStyle >= gsHorizontal then - Result := Result + ', KOL.' + GradientStyles[ gradientStyle ] + ', ' + - GradientLayouts[ GradientLayout ]; -end; - -function TKOLGradientPanel.SupportsFormCompact: Boolean; -begin - Result := TRUE; + Result := Result + ', KOL.' + GradientStyles[gradientStyle] + ', ' + GradientLayouts[GradientLayout]; end; function TKOLGradientPanel.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; -function TKOLGradientPanel.TypeName: String; +function TKOLGradientPanel.TypeName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.TypeName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.TypeName', 0 + +@@e_signature: end; Result := inherited TypeName; - if (GradientStyle in [ gsRombic, gsElliptic ]) or - (gradientLayout <> glTop) and - not(GradientStyle in [ gsTopToBottom, gsBottomToTop ]) then + if (GradientStyle in [gsRombic, gsElliptic]) or (gradientLayout <> glTop) and + not (GradientStyle in [gsTopToBottom, gsBottomToTop]) then Result := 'GradientPanelEx'; end; @@ -4909,31 +3936,40 @@ end; function TKOLGroupBox.ClientMargins: TRect; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.ClientMargins', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGradientPanel.ClientMargins', 0 + +@@e_signature: end; - Result := Rect( 0, 0, 0, 0 ); + Result := Rect(0, 0, 0, 0); end; constructor TKOLGroupBox.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGroupBox.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGroupBox.Create', 0 + +@@e_signature: end; inherited; - Width := 100; DefaultWidth := Width; - Height := 100; DefaultHeight := 100; - ControlStyle := ControlStyle + [ csAcceptsControls ]; - DefaultMarginTop := 22; MarginTop := 22; - DefaultMarginLeft := 2; MarginLeft := 2; - DefaultMarginRight := 2; MarginRight := 2; - DefaultMarginBottom := 2; MarginBottom := 2; - FHasBorder := FALSE; FDefHasBorder := FALSE; + Width := 100; + DefaultWidth := Width; + Height := 100; + DefaultHeight := 100; + ControlStyle := ControlStyle + [csAcceptsControls]; + DefaultMarginTop := 22; + MarginTop := 22; + DefaultMarginLeft := 2; + MarginLeft := 2; + DefaultMarginRight := 2; + MarginRight := 2; + DefaultMarginBottom := 2; + MarginBottom := 2; + FHasBorder := FALSE; + FDefHasBorder := FALSE; AcceptChildren := TRUE; end; @@ -4948,24 +3984,26 @@ end; function TKOLGroupBox.DrawMargins: TRect; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGroupBox.DrawMargins', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGroupBox.DrawMargins', 0 + +@@e_signature: end; - Result := Rect( 4, 18, 4, 4 ); + Result := Rect(4, 18, 4, 4); if Font <> nil then - if Font.FontHeight > 0 then - Result.Top := Font.FontHeight; + if Font.FontHeight > 0 then + Result.Top := Font.FontHeight; end; procedure TKOLGroupBox.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGroupBox.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGroupBox.FirstCreate', 0 + +@@e_signature: end; Caption := Name; inherited; @@ -4980,127 +4018,67 @@ begin inherited; end; -function TKOLGroupBox.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLGroupBox.P_GenerateTransparentInits: String; -begin - Result := ' xySwap DelAnsiStr ' + inherited P_GenerateTransparentInits; -end; - -procedure TKOLGroupBox.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGroupBox.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if TextAlign <> taLeft then - //SL.Add( Prefix + AName + '.TextAlign := ' + TextAligns[ TextAlign ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( TextAlign ) ) + ') ' + - ' C1 TControl_.SetTextAlign<2>' ); -end; - -function TKOLGroupBox.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGroupBox.P_SetupParams', 0 - @@e_signature: - end; - //Result := AParent + ', ' + StringConstant('Caption',Caption); - nparams := 2; - {P}Result := P_StringConstant('Caption',Caption) + - //'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - //Remove_Result_dot( AParent ) - ' C2'; -end; - -procedure TKOLGroupBox.SetupConstruct_Compact; -var KF: TKOLForm; - C: String; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewGroupBox', TRUE, TRUE, '' ); - C := Caption; - if not KF.AssignTextToControls then - C := ''; - KF.FormAddStrParameter( C ); -end; - -procedure TKOLGroupBox.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); +procedure TKOLGroupBox.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); {const TextAligns: array[ TTextAlign ] of String = ( 'taLeft', 'taRight', 'taCenter' );} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGroupBox.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGroupBox.SetupFirst', 0 + +@@e_signature: end; inherited; {if TextAlign <> taLeft then SL.Add( Prefix + AName + '.TextAlign := ' + TextAligns[ TextAlign ] + ';' );} end; -function TKOLGroupBox.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLGroupBox.SetupParams(const AName, AParent: TDelphiString): TDelphiString; var {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGroupBox.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGroupBox.SetupParams', 0 + +@@e_signature: end; - if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - C := StringConstant('Caption', Caption) - else - C := ''''''; + if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then + C := StringConstant('Caption', Caption) + else + C := ''''''; {$IFDEF _D2009orHigher} - if C <> '''''' then - begin - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; - end; + if C <> '''''' then begin + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[i])); + C := C2; + end; {$ENDIF} Result := AParent + ', ' + C; end; -procedure TKOLGroupBox.SetupTextAlign(SL: TStrings; const AName: String); +procedure TKOLGroupBox.SetupTextAlign(SL: TStrings; const AName: string); begin - if TextAlign <> taLeft then - GenerateTextAlign( SL, AName ); -end; - -function TKOLGroupBox.SupportsFormCompact: Boolean; -begin - Result := TRUE; + if TextAlign <> taLeft then + GenerateTextAlign(SL, AName); end; function TKOLGroupBox.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGroupBox.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLGroupBox.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; @@ -5115,16 +4093,19 @@ end; constructor TKOLCheckBox.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCheckBox.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLCheckBox.Create', 0 + +@@e_signature: end; inherited; fTabstop := TRUE; fAutoSzX := 20; - Width := 72; DefaultWidth := Width; - Height := 22; DefaultHeight := 22; + Width := 72; + DefaultWidth := Width; + Height := 22; + DefaultHeight := 22; FHasBorder := FALSE; FDefHasBorder := FALSE; end; @@ -5133,18 +4114,19 @@ procedure TKOLCheckBox.CreateKOLControl(Recreating: boolean); begin inherited; if Auto3State then - FKOLCtrl:=NewCheckBox3State(KOLParentCtrl, '') + FKOLCtrl := NewCheckBox3State(KOLParentCtrl, '') else - FKOLCtrl:=NewCheckbox(KOLParentCtrl, ''); + FKOLCtrl := NewCheckbox(KOLParentCtrl, ''); end; procedure TKOLCheckBox.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCheckBox.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLCheckBox.FirstCreate', 0 + +@@e_signature: end; Caption := Name; inherited; @@ -5158,61 +4140,11 @@ end; procedure TKOLCheckBox.Paint; begin if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin - PrepareCanvasFontForWYSIWIGPaint( Canvas ); + PrepareCanvasFontForWYSIWIGPaint(Canvas); //dufa DrawCheckBox(Canvas.Handle, ClientRect, Enabled, Checked, HasBorder, Caption); - end; - inherited; -end; - -function TKOLCheckBox.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLCheckBox.P_GenerateTransparentInits: String; -begin - Result := ' xySwap DelAnsiStr ' + inherited P_GenerateTransparentInits; -end; - -procedure TKOLCheckBox.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCheckBox.P_SetupFirst', 0 - @@e_signature: end; inherited; - if Checked and (action = nil) then - //SL.Add( Prefix + AName + '.Checked := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetChecked<2>'); -end; - -function TKOLCheckBox.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCheckBox.P_SetupParams', 0 - @@e_signature: - end; - nparams := 2; - {if action = nil then - C := StringConstant('Caption',Caption) - else - C := '''''';} - if action = nil then - Result := P_StringConstant('Caption',Caption) - else - Result := ' LoadAnsiStr #0 '; - //Result := AParent + ', ' + C; - {P} Result := Result + - //'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - //Remove_Result_dot( AParent ); - #13#10' C2'; end; procedure TKOLCheckBox.SetAuto3State(const Value: Boolean); @@ -5224,107 +4156,87 @@ end; procedure TKOLCheckBox.SetChecked(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCheckBox.SetChecked', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLCheckBox.SetChecked', 0 + +@@e_signature: end; - if FChecked = Value then exit; + if FChecked = Value then + exit; if action = nil then FChecked := Value else FChecked := action.Checked; Change; if Assigned(FKOLCtrl) then - FKOLCtrl.Checked:=FChecked; + FKOLCtrl.Checked := FChecked; Invalidate; end; -procedure TKOLCheckBox.SetupConstruct_Compact; -var KF: TKOLForm; - C: String; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewCheckBox', TRUE, TRUE, '' ); - C := Caption; - if not KF.AssignTextToControls then - C := ''; - KF.FormAddStrParameter( C ); -end; - -procedure TKOLCheckBox.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLCheckBox.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCheckBox.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLCheckBox.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if Checked and (action = nil) then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetChecked', '' ); - end else - SL.Add( Prefix + AName + '.Checked := TRUE;' ); + if Checked and (action = nil) then + SL.Add(Prefix + AName + '.Checked := TRUE;'); end; -function TKOLCheckBox.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLCheckBox.SetupParams(const AName, AParent: TDelphiString): TDelphiString; var {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCheckBox.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLCheckBox.SetupParams', 0 + +@@e_signature: end; if (action = nil) and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - C := StringConstant('Caption', Caption) + C := StringConstant('Caption', Caption) else - C := ''''''; + C := ''''''; {$IFDEF _D2009orHigher} - if C <> '''''' then - begin - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; - end; + if C <> '''''' then begin + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[i])); + C := C2; + end; {$ENDIF} Result := AParent + ', ' + C; end; -function TKOLCheckBox.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - function TKOLCheckBox.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCheckBox.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLCheckBox.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; -function TKOLCheckBox.TypeName: String; +function TKOLCheckBox.TypeName: string; begin - if Auto3State and Windowed - then Result := 'CheckBox3State' - else Result := inherited TypeName; + if Auto3State and Windowed then + Result := 'CheckBox3State' + else + Result := inherited TypeName; end; function TKOLCheckBox.WYSIWIGPaintImplemented: Boolean; @@ -5337,16 +4249,19 @@ end; constructor TKOLRadioBox.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRadioBox.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRadioBox.Create', 0 + +@@e_signature: end; inherited; fTabstop := TRUE; fAutoSzX := 20; - Width := 72; DefaultWidth := Width; - Height := 22; DefaultHeight := 22; + Width := 72; + DefaultWidth := Width; + Height := 22; + DefaultHeight := 22; FHasBorder := FALSE; FDefHasBorder := FALSE; end; @@ -5354,10 +4269,11 @@ end; procedure TKOLRadioBox.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRadioBox.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRadioBox.FirstCreate', 0 + +@@e_signature: end; Caption := Name; inherited; @@ -5370,166 +4286,94 @@ end; procedure TKOLRadioBox.Paint; begin - PrepareCanvasFontForWYSIWIGPaint( Canvas ); - DrawRadioBox(True, Canvas.Handle, ClientRect, Enabled, Checked, HasBorder, Caption); + PrepareCanvasFontForWYSIWIGPaint(Canvas); + DrawRadioBox(True, Enabled, Checked, HasBorder, Canvas.Handle, ClientRect, Caption); inherited; end; -function TKOLRadioBox.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLRadioBox.P_GenerateTransparentInits: String; -begin - Result := ' xySwap DelAnsiStr ' + inherited P_GenerateTransparentInits; -end; - -procedure TKOLRadioBox.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -begin - inherited; - if Checked and (action = nil) then - begin - SL.add( ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + Name + - ' DUP TControl.CreateWindow<1>' ); - SL.add( ' TControl.SetRadioChecked<1>' ); - end; -end; - -function TKOLRadioBox.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRadioBox.P_SetupParams', 0 - @@e_signature: - end; - nparams := 2; - if (action = nil) and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - Result := P_StringConstant('Caption',Caption) - else - Result := ' LoadAnsiStr #0 '; - //Result := AParent + ', ' + C; - {P} Result := Result + - //'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - //Remove_Result_dot( AParent ); - #13#10' C2'; -end; - procedure TKOLRadioBox.SetChecked(const Value: Boolean); -var I: Integer; - C: TComponent; - K: TKOLCustomControl; +var + I: Integer; + C: TComponent; + K: TKOLCustomControl; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRadioBox.SetChecked', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRadioBox.SetChecked', 0 + +@@e_signature: end; - if FChecked = Value then exit; + if FChecked = Value then + exit; if action = nil then FChecked := Value else FChecked := action.Checked; Change; if FChecked then - if Parent <> nil then - begin - for I := 0 to ParentForm.ComponentCount - 1 do - begin - C := ParentForm.Components[ I ]; - if C <> Self then - if C is TKOLCustomControl then - begin - K := C as TKOLCustomControl; - if K.Parent = Parent then - if K is TKOLRadioBox then - (K as TKOLRadioBox).Checked := FALSE; + if Parent <> nil then begin + for I := 0 to ParentForm.ComponentCount - 1 do begin + C := ParentForm.Components[I]; + if C <> Self then + if C is TKOLCustomControl then begin + K := C as TKOLCustomControl; + if K.Parent = Parent then + if K is TKOLRadioBox then + (K as TKOLRadioBox).Checked := FALSE; + end; end; end; - end; end; -procedure TKOLRadioBox.SetupConstruct_Compact; -var KF: TKOLForm; - C: String; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewRadioBox', TRUE, TRUE, '' ); - C := Caption; - if not KF.AssignTextToControls then - C := ''; - KF.FormAddStrParameter( C ); -end; - -procedure TKOLRadioBox.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLRadioBox.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin inherited; - KF := ParentKOLForm; - if Checked and (action = nil) then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.CreateWindow', '' ); //'FormCreateWindow' ); - KF.FormAddCtlCommand( Name, 'TControl.SetRadioChecked', '' ); - end - else - begin - SL.add( Prefix + AName + '.CreateWindow;' ); - SL.add( Prefix + AName + '.SetRadioChecked;' ); - end; + if Checked and (action = nil) then begin + SL.add(Prefix + AName + '.CreateWindow;'); + SL.add(Prefix + AName + '.SetRadioChecked;'); end; end; -function TKOLRadioBox.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLRadioBox.SetupParams(const AName, AParent: TDelphiString): TDelphiString; var {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRadioBox.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRadioBox.SetupParams', 0 + +@@e_signature: end; if (action = nil) and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then C := StringConstant('Caption', Caption) else C := ''''''; {$IFDEF _D2009orHigher} - if C <> '''''' then - begin - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; + if C <> '''''' then begin + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[i])); + C := C2; end; {$ENDIF} Result := AParent + ', ' + C; end; -function TKOLRadioBox.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - function TKOLRadioBox.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRadioBox.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRadioBox.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; @@ -5541,7 +4385,7 @@ end; { TKOLEditBox } -function TKOLEditBox.BestEventName: String; +function TKOLEditBox.BestEventName: string; begin Result := 'OnChange'; end; @@ -5549,16 +4393,19 @@ end; constructor TKOLEditBox.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.Create', 0 + +@@e_signature: end; inherited; fNoAutoSizeX := TRUE; fAutoSzY := 6; - Width := 100; DefaultWidth := Width; - Height := 22; DefaultHeight := 22; + Width := 100; + DefaultWidth := Width; + Height := 22; + DefaultHeight := 22; TabStop := TRUE; FResetTabStopByStyle := TRUE; end; @@ -5566,10 +4413,11 @@ end; function TKOLEditBox.DefaultColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.DefaultColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.DefaultColor', 0 + +@@e_signature: end; Result := clWindow; end; @@ -5577,10 +4425,11 @@ end; procedure TKOLEditBox.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.FirstCreate', 0 + +@@e_signature: end; Text := Name; inherited; @@ -5589,10 +4438,11 @@ end; function TKOLEditBox.GetCaption: TDelphiString; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.GetCaption', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.GetCaption', 0 + +@@e_signature: end; Result := inherited Caption; end; @@ -5600,10 +4450,11 @@ end; function TKOLEditBox.GetText: TDelphiString; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.GetText', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.GetText', 0 + +@@e_signature: end; Result := Caption; end; @@ -5611,10 +4462,11 @@ end; function TKOLEditBox.NoDrawFrame: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.NoDrawFrame', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.NoDrawFrame', 0 + +@@e_signature: end; Result := HasBorder; end; @@ -5626,15 +4478,17 @@ procedure TKOLEditBox.Paint; Delta: Integer;} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.Paint', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.Paint', 0 + +@@e_signature: end; //dufa if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin - PrepareCanvasFontForWYSIWIGPaint(Canvas); - DrawEditbox(True, Canvas.Handle, ClientRect, Enabled, (eoPassword in Options), TextHFlags[KOL.TTextAlign(TextAlign)], Caption); + PrepareCanvasFontForWYSIWIGPaint(Canvas); + DrawEditbox(True, Enabled, (eoPassword in Options), Canvas.Handle, + ClientRect, TextHFlags[KOL.TTextAlign(TextAlign)], Caption); end; {PrepareCanvasFontForWYSIWIGPaint( Canvas ); @@ -5677,79 +4531,14 @@ begin end; -function TKOLEditBox.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLEditBox.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if Text <> '' then - begin - {P}SL.Add( 'LoadAnsiStr ' + P_String2Pascal( Text ) ); - {P}SL.Add( ' C2 TControl_.SetCaption<2>' ); - {P}SL.Add( ' DelAnsiStr' ); - end; - //if TextAlign <> taLeft then - // {P}SL.Add( ' L(' + IntToStr( Integer( TextAlign ) ) + ') ' + - // ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + Name + - // ' TControl_.SetTextAlign<2>' ); - if Transparent then - //SL.Add( Prefix + AName + '.Ed_Transparent := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.EdSetTransparent<2>' ); -end; - -function TKOLEditBox.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -var EO: KOL.TEditOptions; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.P_SetupParams', 0 - @@e_signature: - end; - nparams := 2; - //Result := AParent + ', [ ' + S + ' ]'; - EO := [ ]; - if eoLowercase in Options then EO := EO + [ KOL.eoLowercase ]; - if eoNoHideSel in Options then EO := EO + [ KOL.eoNoHideSel ]; - if eoOemConvert in Options then EO := EO + [ KOL.eoOemConvert ]; - if eoPassword in Options then EO := EO + [ KOL.eoPassword ]; - if eoReadonly in Options then EO := EO + [ KOL.eoReadonly ]; - if eoUpperCase in options then EO := EO + [ KOL.eoUpperCase ]; - if eoWantTab in options then EO := EO + [ KOL.eoWantTab ]; - {P}Result := ' L(' + IntToStr( PWord( @ EO )^ ) + ') '; - {P} Result := Result + - #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - Remove_Result_dot( AParent ); - //' C1'; -end; - -procedure TKOLEditBox.P_SetupTextAlign(SL: TStrings; const AName: String); -begin - inherited; - if TextAlign <> taLeft then - //SL.Add(' ' + AName + '.TextAlign := ' + TextAligns[TextAlign] + ';'); - {P}SL.Add( ' L(' + IntToStr( Integer( TextAlign ) ) + ') ' + - ' C1 TControl_.SetTextAlign<2>' ); -end; - procedure TKOLEditBox.SetEdTransparent(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.SetEdTransparent', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.SetEdTransparent', 0 + +@@e_signature: end; FEdTransparent := Value; Change; @@ -5758,10 +4547,11 @@ end; procedure TKOLEditBox.SetOptions(const Value: TKOLEditOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.SetOptions', 0 + +@@e_signature: end; FOptions := Value; Change; @@ -5770,17 +4560,19 @@ end; procedure TKOLEditBox.SetText(const Value: TDelphiString); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.SetText', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.SetText', 0 + +@@e_signature: end; - SetCaption( Value ); + SetCaption(Value); end; procedure TKOLEditBox.SetUnicode(const Value: Boolean); begin - if FUnicode = Value then Exit; + if FUnicode = Value then + Exit; FUnicode := Value; Change; end; @@ -5790,57 +4582,38 @@ begin Result := FALSE; end; -procedure TKOLEditBox.SetupConstruct_Compact; -var KF: TKOLForm; - b: PByte; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewEditBox', TRUE, TRUE, '' ); - b := @ Options; - KF.FormAddNumParameter( b^ ); -end; - -procedure TKOLEditBox.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); +procedure TKOLEditBox.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); //const // Aligns: array[ TTextAlign ] of String = ( 'taLeft', 'taRight', 'taCenter' ); -var KF: TKOLForm; +var + KF: TKOLForm; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.SetupFirst', 0 + +@@e_signature: end; inherited; KF := ParentKOLForm; - if (Text <> '') and ((KF = nil) or KF.AssignTextToControls) then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetCaption', '' ); - KF.FormAddStrParameter( Text ); - end else - AddLongTextField( SL, Prefix + AName + '.Text := ', Text, ';', ' + ' ); + if (Text <> '') and ((KF = nil) or KF.AssignTextToControls) then + AddLongTextField(SL, Prefix + AName + '.Text := ', Text, ';', ' + '); - if Transparent then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.EdSetTransparent', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.Ed_Transparent := TRUE;' ); + if Transparent then + SL.Add(Prefix + AName + '.Ed_Transparent := TRUE;'); end; -function TKOLEditBox.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var S: String; +function TKOLEditBox.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.SetupParams', 0 + +@@e_signature: end; S := ''; if eoLowercase in Options then @@ -5860,71 +4633,68 @@ begin if eoNumber in Options then S := S + ', eoNumber'; if S <> '' then - if S[ 1 ] = ',' then - S := Copy( S, 3, MaxInt ); + if S[1] = ',' then + S := Copy(S, 3, MaxInt); Result := AParent + ', [ ' + S + ' ]'; end; procedure TKOLEditBox.SetupSetUnicode; begin /// - if Unicode then - begin - SL.Add(' {$IFNDEF UNICODE_CTRLS}' + AName + '.SetUnicode( TRUE );{$ENDIF}' ); + if Unicode then begin + SL.Add(' {$IFNDEF UNICODE_CTRLS}' + AName + '.SetUnicode( TRUE );{$ENDIF}'); end; end; -procedure TKOLEditBox.SetupTextAlign(SL: TStrings; const AName: String); +procedure TKOLEditBox.SetupTextAlign(SL: TStrings; const AName: string); begin inherited; - if TextAlign <> taLeft then - GenerateTextAlign( SL, AName ); -end; - -function TKOLEditBox.SupportsFormCompact: Boolean; -begin - Result := TRUE; + if TextAlign <> taLeft then + GenerateTextAlign(SL, AName); end; function TKOLEditBox.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; -procedure TKOLEditBox.WantTabs( Want: Boolean ); +procedure TKOLEditBox.WantTabs(Want: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.WantTabs', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.WantTabs', 0 + +@@e_signature: end; if Want then - Options := Options + [ eoWantTab ] + Options := Options + [eoWantTab] else - Options := Options - [ eoWantTab ]; + Options := Options - [eoWantTab]; end; function TKOLEditBox.WYSIWIGPaintImplemented: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.WYSIWIGPaintImplemented', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLEditBox.WYSIWIGPaintImplemented', 0 + +@@e_signature: end; Result := TRUE; end; { TKOLMemo } -function TKOLMemo.BestEventName: String; +function TKOLMemo.BestEventName: string; begin Result := 'OnChange'; end; @@ -5932,17 +4702,20 @@ end; constructor TKOLMemo.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.Create', 0 + +@@e_signature: end; FLines := TStringList.Create; inherited; FDefIgnoreDefault := TRUE; FIgnoreDefault := TRUE; - Width := 200; DefaultWidth := Width; - Height := 222; DefaultHeight := Height; + Width := 200; + DefaultWidth := Width; + Height := 222; + DefaultHeight := Height; TabStop := TRUE; FHasScrollbarsToOverride := TRUE; end; @@ -5952,7 +4725,7 @@ var opts: kol.TEditOptions; begin inherited; - opts:=[eoMultiline]; + opts := [eoMultiline]; if eo_Lowercase in FOptions then Include(opts, kol.eoLowercase); if eo_NoHScroll in FOptions then @@ -5961,18 +4734,19 @@ begin Include(opts, kol.eoNoVScroll); if eo_UpperCase in FOptions then Include(opts, kol.eoUpperCase); - FKOLCtrl:=NewEditbox(KOLParentCtrl, opts); - if Recreating then - FKOLCtrl.TextAlign:=kol.TTextAlign(TextAlign); + FKOLCtrl := NewEditbox(KOLParentCtrl, opts); + if Recreating then + FKOLCtrl.TextAlign := kol.TTextAlign(TextAlign); end; function TKOLMemo.DefaultColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.DefaultColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.DefaultColor', 0 + +@@e_signature: end; Result := clWindow; end; @@ -5980,10 +4754,11 @@ end; destructor TKOLMemo.Destroy; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.Destroy', 0 + +@@e_signature: end; FLines.Free; inherited; @@ -5992,24 +4767,26 @@ end; procedure TKOLMemo.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.FirstCreate', 0 + +@@e_signature: end; FLines.Text := Name; if Assigned(FKOLCtrl) then - FKOLCtrl.Text:=FLines.Text; + FKOLCtrl.Text := FLines.Text; inherited; end; -function TKOLMemo.GetCaption: String; +function TKOLMemo.GetCaption: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.GetCaption', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.GetCaption', 0 + +@@e_signature: end; Result := inherited Caption; end; @@ -6017,10 +4794,11 @@ end; function TKOLMemo.GetText: TStrings; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.GetText', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.GetText', 0 + +@@e_signature: end; Result := FLines; end; @@ -6028,14 +4806,14 @@ end; procedure TKOLMemo.KOLControlRecreated; begin inherited; - FKOLCtrl.Text:=FLines.Text; + FKOLCtrl.Text := FLines.Text; end; procedure TKOLMemo.Loaded; begin inherited; if Assigned(FKOLCtrl) then - FKOLCtrl.Text:=FLines.Text; + FKOLCtrl.Text := FLines.Text; end; function TKOLMemo.NoDrawFrame: Boolean; @@ -6064,85 +4842,20 @@ procedure TKOLMemo.Paint; begin if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin PrepareCanvasFontForWYSIWIGPaint(Canvas); - DrawMemo(True, Canvas.Handle, ClientRect, Color, Enabled, KOLMemoOptions2ScrollStyle(Options), TextHFlags[KOL.TTextAlign(TextAlign)], Text.Text); + DrawMemo(True, Enabled, Canvas.Handle, ClientRect, Color, + KOLMemoOptions2ScrollStyle(Options), TextHFlags[KOL.TTextAlign(TextAlign)], Text.Text); end; inherited; end; -function TKOLMemo.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLMemo.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLEditBox.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if FLines.Text <> '' then - begin - {P}SL.Add( 'LoadAnsiStr ' + P_String2Pascal( FLines.Text ) ); - {P}SL.Add( ' C2 TControl_.SetCaption<2>' ); - {P}SL.Add( ' DelAnsiStr' ); - end; - //if TextAlign <> taLeft then - // {P}SL.Add( ' L(' + IntToStr( Integer( TextAlign ) ) + ') ' + - // ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + Name + - // ' TControl_.SetTextAlign<2>' ); - if Transparent then - //SL.Add( Prefix + AName + '.Ed_Transparent := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.EdSetTransparent<2>' ); -end; - -function TKOLMemo.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -var EO: KOL.TEditOptions; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.P_SetupParams', 0 - @@e_signature: - end; - nparams := 2; - //Result := AParent + ', [ ' + S + ' ]'; - EO := [ KOL.eoMultiline ]; - if eo_NoHScroll in Options then EO := EO + [ KOL.eoNoHScroll ]; - if eo_NoVScroll in Options then EO := EO + [ KOL.eoNoVScroll ]; - if eo_Lowercase in Options then EO := EO + [ KOL.eoLowercase ]; - if eo_NoHideSel in Options then EO := EO + [ KOL.eoNoHideSel ]; - if eo_OemConvert in Options then EO := EO + [ KOL.eoOemConvert ]; - if eo_Password in Options then EO := EO + [ KOL.eoPassword ]; - if eo_Readonly in Options then EO := EO + [ KOL.eoReadonly ]; - if eo_UpperCase in options then EO := EO + [ KOL.eoUpperCase ]; - if eo_WantReturn in options then EO := EO + [ KOL.eoWantReturn ]; - if eo_WantTab in options then EO := EO + [ KOL.eoWantTab ]; - {P}Result := ' L(' + IntToStr( PWord( @ EO )^ ) + ') '; - {P} Result := Result + - #13#10' C1'; -end; - -procedure TKOLMemo.P_SetupTextAlign(SL: TStrings; const AName: String); -begin - inherited; - if TextAlign <> taLeft then - //SL.Add(' ' + AName + '.TextAlign := ' + TextAligns[TextAlign] + ';'); - {P}SL.Add( ' L(' + IntToStr( Integer( TextAlign ) ) + ') ' + - ' C1 TControl_.SetTextAlign<2>' ); -end; - procedure TKOLMemo.SetEdTransparent(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.SetEdTransparent', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.SetEdTransparent', 0 + +@@e_signature: end; FEdTransparent := Value; Change; @@ -6151,10 +4864,11 @@ end; procedure TKOLMemo.SetOptions(const Value: TKOLMemoOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.SetOptions', 0 + +@@e_signature: end; FOptions := Value; if Assigned(FKOLCtrl) then @@ -6167,14 +4881,15 @@ end; procedure TKOLMemo.SetText(const Value: TStrings); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.SetText', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.SetText', 0 + +@@e_signature: end; FLines.Text := Value.Text; if Assigned(FKOLCtrl) then - FKOLCtrl.Text:=Value.Text; + FKOLCtrl.Text := Value.Text; Change; end; @@ -6187,89 +4902,48 @@ end; procedure TKOLMemo.SetUnicode(const Value: Boolean); begin - if Funicode = Value then Exit; + if Funicode = Value then + Exit; FUnicode := Value; Change; end; function TKOLMemo.SetupColorFirst: Boolean; begin - Result := FALSE; + Result := FALSE; end; -procedure TKOLMemo.SetupConstruct_Compact; -var KF: TKOLForm; - O: TEditOptions; - b: PWord; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewEditBox', TRUE, TRUE, '' ); - O := [eoMultiline]; - if eo_NoHScroll in Options then - O := O + [KOL.eoNoHScroll]; - if eo_NoVScroll in Options then - O := O + [KOL.eoNoVScroll]; - if eo_Lowercase in Options then - O := O + [KOL.eoLowercase]; - if eo_NoHideSel in Options then - O := O + [KOL.eoNoHideSel]; - if eo_OemConvert in Options then - O := O + [KOL.eoOemConvert]; - if eo_Password in Options then - O := O + [KOL.eoPassword]; - if eo_Readonly in Options then - O := O + [KOL.eoReadonly]; - if eo_UpperCase in Options then - O := O + [KOL.eoUpperCase]; - if eo_WantReturn in Options then - O := O + [KOL.eoWantReturn]; - if eo_WantTab in Options then - O := O + [KOL.eoWantTab]; - b := @ O; - KF.FormAddNumParameter( b^ ); -end; - -procedure TKOLMemo.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -var KF: TKOLForm; +procedure TKOLMemo.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +var + KF: TKOLForm; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.SetupFirst', 0 + +@@e_signature: end; inherited; KF := ParentKOLForm; - if (FLines.Text <> '') and (Kf <> nil) and KF.AssignTextToControls then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetCaption', '' ); - KF.FormAddStrParameter( FLines.Text ); - end else - AddLongTextField( SL, Prefix + AName + '.Text := ', FLines.Text, ';', ' + ' ); + if (FLines.Text <> '') and (KF <> nil) and KF.AssignTextToControls then begin + AddLongTextField(SL, Prefix + AName + '.Text := ', FLines.Text, ';', ' + '); end; - if Transparent then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.EdSetTransparent', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.Ed_Transparent := TRUE;' ); + if Transparent then + SL.Add(Prefix + AName + '.Ed_Transparent := TRUE;'); end; -function TKOLMemo.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var S: String; +function TKOLMemo.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.SetupParams', 0 + +@@e_signature: end; S := 'eoMultiline'; if eo_NoHScroll in Options then @@ -6293,65 +4967,62 @@ begin if eo_WantTab in Options then S := S + ', eoWantTab'; if S <> '' then - if S[ 1 ] = ',' then - S := Copy( S, 3, MaxInt ); + if S[1] = ',' then + S := Copy(S, 3, MaxInt); Result := AParent + ', [ ' + S + ' ]'; end; -procedure TKOLMemo.SetupSetUnicode(SL: TStringList; const AName: String); +procedure TKOLMemo.SetupSetUnicode(SL: TStringList; const AName: string); begin // - if Unicode then - SL.Add( ' {$IFNDEF UNICODE_CTRLS}' + AName + - '.SetUnicode( TRUE );{$ENDIF}' ); + if Unicode then + SL.Add(' {$IFNDEF UNICODE_CTRLS}' + AName + '.SetUnicode( TRUE );{$ENDIF}'); end; -procedure TKOLMemo.SetupTextAlign(SL: TStrings; const AName: String); +procedure TKOLMemo.SetupTextAlign(SL: TStrings; const AName: string); begin inherited; - if TextAlign <> taLeft then - GenerateTextAlign( SL, AName ); -end; - -function TKOLMemo.SupportsFormCompact: Boolean; -begin - Result := TRUE; + if TextAlign <> taLeft then + GenerateTextAlign(SL, AName); end; function TKOLMemo.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; -function TKOLMemo.TypeName: String; +function TKOLMemo.TypeName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.TypeName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.TypeName', 0 + +@@e_signature: end; Result := 'EditBox'; end; -procedure TKOLMemo.WantTabs( Want: Boolean ); +procedure TKOLMemo.WantTabs(Want: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.WantTabs', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMemo.WantTabs', 0 + +@@e_signature: end; if Want then - Options := Options + [ eo_WantTab ] + Options := Options + [eo_WantTab] else - Options := Options - [ eo_WantTab ]; + Options := Options - [eo_WantTab]; end; { TKOLListBox } @@ -6359,17 +5030,20 @@ end; constructor TKOLListBox.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.Create', 0 + +@@e_signature: end; FItems := TStringList.Create; inherited; - Width := 164; DefaultWidth := Width; - Height := 200; DefaultHeight := Height; + Width := 164; + DefaultWidth := Width; + Height := 200; + DefaultHeight := Height; TabStop := TRUE; - Options := [ loNoIntegralHeight ]; + Options := [loNoIntegralHeight]; FHasScrollbarsToOverride := TRUE; end; @@ -6378,21 +5052,22 @@ var opts: kol.TListOptions; begin inherited; - opts:=[]; + opts := []; if loNoHideScroll in FOptions then Include(opts, kol.loNoHideScroll); if loMultiColumn in FOptions then Include(opts, kol.loMultiColumn); - FKOLCtrl:=NewListbox(KOLParentCtrl, opts + [kol.loNoIntegralHeight]); + FKOLCtrl := NewListbox(KOLParentCtrl, opts + [kol.loNoIntegralHeight]); end; function TKOLListBox.DefaultColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.DefaultColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.DefaultColor', 0 + +@@e_signature: end; Result := clWindow; end; @@ -6400,10 +5075,11 @@ end; destructor TKOLListBox.Destroy; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.Destroy', 0 + +@@e_signature: end; inherited; FItems.Free; @@ -6412,10 +5088,11 @@ end; procedure TKOLListBox.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.FirstCreate', 0 + +@@e_signature: end; //FItems.Text := Name; FCurIndex := 0; @@ -6423,34 +5100,24 @@ begin end; { +ecm } -function TKOLListBox.GenerateTransparentInits: String; +function TKOLListBox.GenerateTransparentInits: string; begin - if fLBItemHeight > 0 then Result := '.SetLVItemHeight('+IntToStr(fLBItemHeight)+')' - else Result := ''; + if fLBItemHeight > 0 then + Result := '.SetLVItemHeight(' + IntToStr(fLBItemHeight) + ')' + else + Result := ''; Result := Result + inherited GenerateTransparentInits(); end; { /+ecm } -procedure TKOLListBox.GenerateTransparentInits_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - if fLBItemHeight > 0 then - begin - KF.FormAddCtlCommand( Name, 'FormSetLVItemHeight', '' ); - KF.FormAddNumParameter( fLBItemHeight ); - end; -end; - -function TKOLListBox.GetCaption: String; +function TKOLListBox.GetCaption: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.GetCaption', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.GetCaption', 0 + +@@e_signature: end; Result := inherited Caption; end; @@ -6469,101 +5136,22 @@ end; function TKOLListBox.NoDrawFrame: Boolean; begin - Result:=HasBorder; + Result := HasBorder; end; procedure TKOLListBox.Paint; begin if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin PrepareCanvasFontForWYSIWIGPaint(Canvas); - DrawListBox(True, Canvas.Handle, ClientRect, Enabled, Items.Text); + DrawListBox(True, Enabled, Canvas.Handle, ClientRect, Items.Text); end; inherited; end; -function TKOLListBox.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLListBox.P_GenerateTransparentInits: String; -begin - if fLBItemHeight > 0 then - //Result := '.SetLVItemHeight('+IntToStr(fLBItemHeight)+')' - {P}Result := ' L(' + IntToStr( fLBItemHeight ) + - ') C1 TControl_.SetLVItemHeight<2>' - else Result := ''; - Result := Result + inherited P_GenerateTransparentInits(); -end; - -procedure TKOLListBox.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var I: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if FItems.Text <> '' then - begin - for I := 0 to FItems.Count - 1 do - //SL.Add( Prefix + AName + '.Items[ ' + IntToStr( I ) + ' ] := ' + - // StringConstant( 'Item' + IntToStr( I ), FItems[ I ] ) + ';' ); - {P}SL.Add( P_StringConstant( 'Item' + IntToStr( I ), FItems[ I ] ) + - ' L(' + IntToStr( I ) + ') C3 TControl_.SetItems<3>' + - ' DelAnsiStr' ); - end; - if FCurIndex >= 0 then - //SL.Add( Prefix + AName + '.CurIndex := ' + IntToStr( FCurIndex ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( FCurIndex ) + ')' + - ' C1 TControl_.SetCurIndex<2>' ); -end; - -procedure TKOLListBox.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.SetupLast', 0 - @@e_signature: - end; - inherited; - if loNoData in Options then - if Count > 0 then - //SL.Add( Prefix + AName + '.Count := ' + IntToStr( Count ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( Count ) + ')' ); - {P}SL.Add( - ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name + - ' TControl_.SetItemsCount<2>' ); - end; -end; - -function TKOLListBox.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -var O: TKOLListboxOptions; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.P_SetupParams', 0 - @@e_signature: - end; - nparams := 2; - O := Options; - {P}Result := ' L(' + IntToStr( PWord( @ O )^ ) + ')' + - #13#10' C1'; - //примечание: здесь можно так поступить, т.к. TKOLListboxOptions - // точно соответствуют KOL.TListOptions -end; - procedure TKOLListBox.SetAlwaysAssignItems(const Value: Boolean); begin - if FAlwaysAssignItems = Value then Exit; + if FAlwaysAssignItems = Value then + Exit; FAlwaysAssignItems := Value; Change; end; @@ -6571,10 +5159,11 @@ end; procedure TKOLListBox.SetCount(Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.SetCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.SetCount', 0 + +@@e_signature: end; if Value < 0 then Value := 0; @@ -6585,10 +5174,11 @@ end; procedure TKOLListBox.SetCurIndex(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.SetCurIndex', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.SetCurIndex', 0 + +@@e_signature: end; FCurIndex := Value; Change; @@ -6597,10 +5187,11 @@ end; procedure TKOLListBox.SetItems(const Value: TStrings); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.SetItems', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.SetItems', 0 + +@@e_signature: end; FItems.Text := Value.Text; UpdateItems; @@ -6620,10 +5211,11 @@ end; procedure TKOLListBox.SetOptions(const Value: TKOLListboxOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.SetOptions', 0 + +@@e_signature: end; FOptions := Value; if Assigned(FKOLCtrl) then @@ -6631,126 +5223,77 @@ begin Change; end; -procedure TKOLListBox.SetupConstruct_Compact; -var KF: TKOLForm; - W: PWord; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewListBox', TRUE, TRUE, '' ); - W := @ Options; - KF.FormAddNumParameter( W^ ); -end; - -procedure TKOLListBox.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); +procedure TKOLListBox.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); var {$IFDEF _D2009orHigher} C, C2: WideString; - j : integer; + j: integer; {$ELSE} - C: String; + C: string; {$ENDIF} I: Integer; KF: TKOLForm; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.SetupFirst', 0 + +@@e_signature: end; inherited; KF := ParentKOLForm; - if FItems.Text <> '' then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetListItems', '' ); - KF.FormAddNumParameter( FItems.Count ); - for I := 0 to FItems.Count-1 do - if (KF <> nil) and KF.AssignTextToControls or AlwaysAssignItems then - KF.FormAddStrParameter( FItems[I] ) - else - KF.FormAddStrParameter( '' ); - end else - for I := 0 to FItems.Count - 1 do - begin - {$IFDEF _D2009orHigher} - if (KF <> nil) and KF.AssignTextToControls then - C := StringConstant( 'Item' + IntToStr( I ), FItems[ I ] ) - else - C := ''''''; - C2 := ''; - for j := 2 to Length(C)-1 do C2 := C2 + '#'+int2str(ord(C[j])); - C := C2; - SL.Add( Prefix + AName + '.Items[ ' + IntToStr( I ) + ' ] := ' + C + ';' ); - {$ELSE} - if (KF <> nil) and KF.AssignTextToControls or AlwaysAssignItems then - C := StringConstant( 'Item' + IntToStr( I ), FItems[ I ] ) - else - C := ''''''; - SL.Add( Prefix + AName + '.Items[ ' + IntToStr( I ) + ' ] := ' + - C + ';' ); - {$ENDIF} - end; + if FItems.Text <> '' then begin + for I := 0 to FItems.Count - 1 do begin + {$IFDEF _D2009orHigher} + if (KF <> nil) and KF.AssignTextToControls then + C := StringConstant('Item' + IntToStr(I), FItems[I]) + else + C := ''''''; + C2 := ''; + for j := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[j])); + C := C2; + SL.Add(Prefix + AName + '.Items[ ' + IntToStr(I) + ' ] := ' + C + ';'); + {$ELSE} + if (KF <> nil) and KF.AssignTextToControls or AlwaysAssignItems then + C := StringConstant('Item' + IntToStr(I), FItems[I]) + else + C := ''''''; + SL.Add(Prefix + AName + '.Items[ ' + IntToStr(I) + ' ] := ' + C + ';'); + {$ENDIF} + end; end; - if (FCurIndex >= 0) and (Items.Count > 0) then - if (KF <> nil) and KF.FormCompact then - begin - if FCurIndex = 1 then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetCurIdx', '' ); - // param = 1 - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetCurIdx', '' ); - KF.FormAddNumParameter( FCurIndex ); - end; - end else - SL.Add( Prefix + AName + '.CurIndex := ' + IntToStr( FCurIndex ) + ';' ); + if (FCurIndex >= 0) and (Items.Count > 0) then + SL.Add(Prefix + AName + '.CurIndex := ' + IntToStr(FCurIndex) + ';'); end; -procedure TKOLListBox.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLListBox.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.SetupLast', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.SetupLast', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if loNoData in Options then - if Count > 0 then - if (KF <> nil) and KF.FormCompact then - begin - if Count = 1 then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetItemsCount', '' ); - // param = 1 - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetCount', '' ); - KF.FormAddNumParameter( Count ); - end; - end else - SL.Add( Prefix + AName + '.Count := ' + IntToStr( Count ) + ';' ); + + if loNoData in Options then + if Count > 0 then + SL.Add(Prefix + AName + '.Count := ' + IntToStr(Count) + ';'); end; -function TKOLListBox.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var S: String; +function TKOLListBox.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.SetupParams', 0 + +@@e_signature: end; if loNoHideScroll in Options then S := S + 'loNoHideScroll'; @@ -6779,23 +5322,19 @@ begin if loHScroll in Options then S := S + ', loHScroll'; if S <> '' then - if S[ 1 ] = ',' then - S := Copy( S, 3, MaxInt ); + if S[1] = ',' then + S := Copy(S, 3, MaxInt); Result := AParent + ', [ ' + S + ' ]'; end; -function TKOLListBox.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - function TKOLListBox.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListBox.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; @@ -6809,8 +5348,8 @@ begin try FKOLCtrl.Clear; if [loOwnerDrawFixed, loOwnerDrawVariable] * FOptions = [] then - for i:=0 to FItems.Count - 1 do - FKOLCtrl.Items[i]:=FItems[i]; + for i := 0 to FItems.Count - 1 do + FKOLCtrl.Items[i] := FItems[i]; finally FKOLCtrl.EndUpdate; end; @@ -6829,39 +5368,43 @@ begin if coSimple in Options then Result := Height else - Result := inherited AutoHeight( Canvas ); + Result := inherited AutoHeight(Canvas); end; function TKOLComboBox.AutoSizeRunTime: Boolean; begin - Result := not( coSimple in Options ); + Result := not (coSimple in Options); end; constructor TKOLComboBox.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.Create', 0 + +@@e_signature: end; FItems := TStringList.Create; inherited; fNoAutoSizeX := TRUE; fAutoSzY := 6; - Width := 100; DefaultWidth := Width; - Height := 22; DefaultHeight := Height; + Width := 100; + DefaultWidth := Width; + Height := 22; + DefaultHeight := Height; TabStop := TRUE; - Options := [ coNoIntegralHeight ]; + Options := [coNoIntegralHeight]; end; function TKOLComboBox.DefaultColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.DefaultColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.DefaultColor', 0 + +@@e_signature: end; Result := clWhite; // !!! in Windows, default color for combobox really is clWhite end; @@ -6869,10 +5412,11 @@ end; function TKOLComboBox.DefaultInitialColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.DefaultInitialColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.DefaultInitialColor', 0 + +@@e_signature: end; Result := clWindow; end; @@ -6880,10 +5424,11 @@ end; destructor TKOLComboBox.Destroy; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.Destroy', 0 + +@@e_signature: end; inherited; FItems.Free; @@ -6892,37 +5437,26 @@ end; procedure TKOLComboBox.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.FirstCreate', 0 + +@@e_signature: end; FItems.Text := Name; FCurIndex := 0; inherited; end; -function TKOLComboBox.GenerateTransparentInits: String; +function TKOLComboBox.GenerateTransparentInits: string; begin - if fCBItemHeight > 0 then Result := '.SetLVItemHeight('+IntToStr(fCBItemHeight)+')' - else Result := ''; + if fCBItemHeight > 0 then + Result := '.SetLVItemHeight(' + IntToStr(fCBItemHeight) + ')' + else + Result := ''; Result := Result + inherited GenerateTransparentInits(); end; -procedure TKOLComboBox.GenerateTransparentInits_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - if not KF.FormCompact then Exit; - if fCBItemHeight > 0 then - begin - KF.FormAddCtlCommand( Name, 'FormSetLVItemHeight', '' ); - KF.FormAddNumParameter( fCBItemHeight ); - end; -end; - function TKOLComboBox.NoDrawFrame: Boolean; begin Result := HasBorder; @@ -6930,97 +5464,38 @@ end; procedure TKOLComboBox.Paint; var - s: String; + s: string; begin if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin - PrepareCanvasFontForWYSIWIGPaint( Canvas ); + PrepareCanvasFontForWYSIWIGPaint(Canvas); if (CurIndex > -1) and (Items.Count > 0) then s := Items.Strings[CurIndex] else s := ''; DrawCombobox(Canvas.Handle, ClientRect, Enabled, s); - end; - inherited; -end; - -function TKOLComboBox.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLComboBox.P_GenerateTransparentInits: String; -begin - if fCBItemHeight > 0 then - //Result := '.SetLVItemHeight('+IntToStr(fCBItemHeight)+')' - {P}Result := Result + ' L(' + IntToStr( fCBItemHeight ) + ')' + - ' C1 TControl_.SetLVItemHeight<2>' - else Result := ''; - Result := Result + inherited P_GenerateTransparentInits(); -end; - -procedure TKOLComboBox.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var I: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.P_SetupFirst', 0 - @@e_signature: end; inherited; - if FItems.Text <> '' then - begin - for I := 0 to FItems.Count - 1 do - //SL.Add( Prefix + AName + '.Items[ ' + IntToStr( I ) + ' ] := ' + - // StringConstant( 'Item' + IntToStr( I ), FItems[ I ] ) + ';' ); - {P}SL.Add( P_StringConstant( 'Item' + IntToStr( I ), FItems[ I ] ) + - ' L(' + IntToStr( I ) + ') C3 TControl_.SetItems<3>' + - ' DelAnsiStr' ); - end; - if FCurIndex >= 0 then - //SL.Add( Prefix + AName + '.CurIndex := ' + IntToStr( FCurIndex ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( FCurIndex ) + ') C1 TControl_.SetCurIndex<2>' ); - if (FDroppedWidth <> Width) and (FDroppedWidth <> 0) then - //SL.Add( Prefix + AName + '.DroppedWidth := ' + IntToStr( FDroppedWidth ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( FDroppedWidth ) + ') ' + - ' C1 TControl_.SetDroppedWidth<2>' ); -end; - -function TKOLComboBox.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListBox.P_SetupParams', 0 - @@e_signature: - end; - nparams := 2; - {P}Result := ' L(' + IntToStr( PWord( @ Options )^ ) + ')' + - #13#10' C1'; end; procedure TKOLComboBox.SetAlign(const Value: TKOLAlign); begin inherited; - if Value in [ caLeft, caRight, caClient ] then - if not (csLoading in ComponentState) then - ShowMessage( 'Aligning combobox to left, right or client ' + - 'can get undesirable results at run time!' ); + if Value in [caLeft, caRight, caClient] then + if not (csLoading in ComponentState) then + ShowMessage('Aligning combobox to left, right or client ' + 'can get undesirable results at run time!'); end; procedure TKOLComboBox.SetAlwaysAssignItems(const Value: Boolean); begin - if FAlwaysAssignItems = Value then Exit; + if FAlwaysAssignItems = Value then + Exit; FAlwaysAssignItems := Value; Change; end; procedure TKOLComboBox.SetCBItemHeight(const Value: Integer); begin - if fCBItemHeight <> Value then - begin + if fCBItemHeight <> Value then begin fCBItemHeight := Value; Change; end; @@ -7029,10 +5504,11 @@ end; procedure TKOLComboBox.SetCurIndex(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.SetCurIndex', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.SetCurIndex', 0 + +@@e_signature: end; FCurIndex := Value; Change; @@ -7041,10 +5517,11 @@ end; procedure TKOLComboBox.SetDroppedWidth(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.SetDroppedWidth', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.SetDroppedWidth', 0 + +@@e_signature: end; FDroppedWidth := Value; Change; @@ -7053,10 +5530,11 @@ end; procedure TKOLComboBox.SetItems(const Value: TStrings); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.SetItems', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.SetItems', 0 + +@@e_signature: end; FItems.Text := Value.Text; Change; @@ -7065,10 +5543,11 @@ end; procedure TKOLComboBox.SetOptions(const Value: TKOLComboOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.SetOptions', 0 + +@@e_signature: end; FOptions := Value; Change; @@ -7077,105 +5556,65 @@ begin Invalidate; end; -procedure TKOLComboBox.SetupConstruct_Compact; -var KF: TKOLForm; - W: PWord; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewComboBox', TRUE, TRUE, '' ); - W := @ Options; - KF.FormAddNumParameter( W^ ); -end; - -procedure TKOLComboBox.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); +procedure TKOLComboBox.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); var {$IFDEF _D2009orHigher} C, C2: WideString; - j : integer; + j: integer; {$ELSE} - C: String; + C: string; {$ENDIF} - I: Integer; - KF: TKOLForm; + I: Integer; + KF: TKOLForm; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.SetupFirst', 0 + +@@e_signature: end; inherited; KF := ParentKOLForm; - if FItems.Text <> '' then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetListItems', '' ); - KF.FormAddNumParameter( FItems.Count ); - for I := 0 to FItems.Count-1 do - if (KF <> nil) and KF.AssignTextToControls or AlwaysAssignItems then - KF.FormAddStrParameter( FItems[I] ) - else - KF.FormAddStrParameter( '' ); - end else - for I := 0 to FItems.Count - 1 do - begin + if FItems.Text <> '' then begin + for I := 0 to FItems.Count - 1 do begin {$IFDEF _D2009orHigher} - if (KF <> nil) and KF.AssignTextToControls or AlwaysAssignItems then - C := StringConstant( 'Item' + IntToStr( I ), FItems[ I ] ) - else - C := ''''''; - C2 := ''; - for j := 2 to Length(C)-1 do C2 := C2 + '#'+int2str(ord(C[j])); - C := C2; - SL.Add( Prefix + AName + '.Items[ ' + IntToStr( I ) + ' ] := ' + C + ';' ); + if (KF <> nil) and KF.AssignTextToControls or AlwaysAssignItems then + C := StringConstant('Item' + IntToStr(I), FItems[I]) + else + C := ''''''; + C2 := ''; + for j := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[j])); + C := C2; + SL.Add(Prefix + AName + '.Items[ ' + IntToStr(I) + ' ] := ' + C + ';'); {$ELSE} - if (KF <> nil) and KF.AssignTextToControls then - C := StringConstant( 'Item' + IntToStr( I ), FItems[ I ] ) - else - C := ''''''; - SL.Add( Prefix + AName + '.Items[ ' + IntToStr( I ) + ' ] := ' + - C + ';' ); + if (KF <> nil) and KF.AssignTextToControls then + C := StringConstant('Item' + IntToStr(I), FItems[I]) + else + C := ''''''; + SL.Add(Prefix + AName + '.Items[ ' + IntToStr(I) + ' ] := ' + C + ';'); {$ENDIF} - end; + end; end; - if (FCurIndex >= 0) and (Items.Count > 0) then - if (KF <> nil) and KF.FormCompact then - begin - if FCurIndex = 1 then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetCurIdx', '' ); - // param = 1 - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetCurIdx', '' ); - KF.FormAddNumParameter( FCurIndex ); - end; - end else - SL.Add( Prefix + AName + '.CurIndex := ' + IntToStr( FCurIndex ) + ';' ); + if (FCurIndex >= 0) and (Items.Count > 0) then + SL.Add(Prefix + AName + '.CurIndex := ' + IntToStr(FCurIndex) + ';'); - if (FDroppedWidth <> Width) and (FDroppedWidth <> 0) then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetDroppedWidth', '' ); - KF.FormAddNumParameter( FDroppedWidth ); - end else - SL.Add( Prefix + AName + '.DroppedWidth := ' + IntToStr( FDroppedWidth ) + ';' ); + if (FDroppedWidth <> Width) and (FDroppedWidth <> 0) then + SL.Add(Prefix + AName + '.DroppedWidth := ' + IntToStr(FDroppedWidth) + ';'); end; -function TKOLComboBox.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var S: String; +function TKOLComboBox.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.SetupParams', 0 + +@@e_signature: end; if coReadOnly in Options then S := S + 'coReadOnly'; @@ -7200,23 +5639,19 @@ begin if coSimple in Options then S := S + ', coSimple'; if S <> '' then - if S[ 1 ] = ',' then - S := Copy( S, 3, MaxInt ); + if S[1] = ',' then + S := Copy(S, 3, MaxInt); Result := AParent + ', [ ' + S + ' ]'; end; -function TKOLComboBox.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - function TKOLComboBox.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLComboBox.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLComboBox.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; @@ -7228,19 +5663,20 @@ end; { TKOLSplitter } -procedure TKOLSplitter.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLSplitter.AssignEvents(SL: TStringList; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.AssignEvents', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLSplitter.AssignEvents', 0 + +@@e_signature: end; inherited; - DoAssignEvents( SL, AName, [ 'OnSplit' ], [ @OnSplit ] ); + DoAssignEvents(SL, AName, ['OnSplit'], [@OnSplit]); end; -function TKOLSplitter.BestEventName: String; +function TKOLSplitter.BestEventName: string; begin Result := 'OnSplit'; end; @@ -7248,14 +5684,16 @@ end; constructor TKOLSplitter.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLSplitter.Create', 0 + +@@e_signature: end; inherited; Align := caLeft; - Width := 4; DefaultWidth := Width; + Width := 4; + DefaultWidth := Width; DefaultHeight := 4; MinSizePrev := 0; MinSizeNext := 0; @@ -7269,76 +5707,44 @@ var begin inherited; if Recreating then - es:=FEdgeStyle + es := FEdgeStyle else - es:=esLowered; - FKOLCtrl:=NewSplitterEx(KOLParentCtrl, 0, 0, es); + es := esLowered; + FKOLCtrl := NewSplitterEx(KOLParentCtrl, 0, 0, es); end; function TKOLSplitter.IsCursorDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.IsCursorDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLSplitter.IsCursorDefault', 0 + +@@e_signature: end; case Align of - caLeft, caRight: Result := (Trim(Cursor_)='') or (Trim(Cursor_)='IDC_SIZEWE'); - caTop, caBottom: Result := (Trim(Cursor_)='') or (Trim(Cursor_)='IDC_SIZENS'); - else Result := inherited IsCursorDefault; + caLeft, caRight: + Result := (Trim(Cursor_) = '') or (Trim(Cursor_) = 'IDC_SIZEWE'); + caTop, caBottom: + Result := (Trim(Cursor_) = '') or (Trim(Cursor_) = 'IDC_SIZENS'); + else + Result := inherited IsCursorDefault; end; end; function TKOLSplitter.NoDrawFrame: Boolean; begin - Result:=(FEdgeStyle < esNone); -end; - -function TKOLSplitter.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLSplitter.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.P_SetupFirst', 0 - @@e_signature: - end; - inherited; -end; - -function TKOLSplitter.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLGradientPanel.P_SetupParams', 0 - @@e_signature: - end; - nparams := 3; - Result := ''; - if EdgeStyle <> esLowered then - {P}Result := ' L( ' + IntToStr( Integer( EdgeStyle ) ) + ')'; - {P}Result := Result + - ' L( ' + IntToStr( MinSizeNext ) + ')' + - #13#10' L( ' + IntToStr( MinSizePrev ) + ') ' + - #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - Remove_Result_dot( AParent ); + Result := (FEdgeStyle < esNone); end; procedure TKOLSplitter.SetEdgeStyle(const Value: TEdgeStyle); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.SetEdgeStyle', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLSplitter.SetEdgeStyle', 0 + +@@e_signature: end; FEdgeStyle := Value; if Assigned(FKOLCtrl) then @@ -7349,10 +5755,11 @@ end; procedure TKOLSplitter.SetMinSizeNext(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.SetMinSizeNext', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLSplitter.SetMinSizeNext', 0 + +@@e_signature: end; FMinSizeNext := Value; Change; @@ -7361,65 +5768,52 @@ end; procedure TKOLSplitter.SetMinSizePrev(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.SetMinSizePrev', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLSplitter.SetMinSizePrev', 0 + +@@e_signature: end; FMinSizePrev := Value; Change; end; -procedure TKOLSplitter.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewSplitter', TRUE, TRUE, '' ); - KF.FormAddNumParameter( Integer( MinSizePrev ) ); - KF.FormAddNumParameter( Integer( MinSizeNext ) ); -end; - -procedure TKOLSplitter.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); +procedure TKOLSplitter.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLSplitter.SetupFirst', 0 + +@@e_signature: end; inherited; end; -function TKOLSplitter.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -const Styles: array[ TEdgeStyle ] of String = - ( 'esRaised', 'esLowered', 'esNone', 'esTransparent', 'esSolid' ); +function TKOLSplitter.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +const + Styles: array[TEdgeStyle] of string = ('esRaised', 'esLowered', 'esNone', 'esTransparent', 'esSolid'); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLSplitter.SetupParams', 0 + +@@e_signature: end; - Result := AParent + ', ' + IntToStr( MinSizePrev ) + ', ' + IntToStr( MinSizeNext ); + Result := AParent + ', ' + IntToStr(MinSizePrev) + ', ' + IntToStr(MinSizeNext); if EdgeStyle <> esLowered then - Result := Result + ', ' + Styles[ EdgeStyle ]; + Result := Result + ', ' + Styles[EdgeStyle]; end; -function TKOLSplitter.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - -function TKOLSplitter.TypeName: String; +function TKOLSplitter.TypeName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLSplitter.TypeName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLSplitter.TypeName', 0 + +@@e_signature: end; Result := inherited TypeName; if EdgeStyle <> esLowered then @@ -7428,7 +5822,7 @@ end; { TKOLPaintBox } -function TKOLPaintBox.BestEventName: String; +function TKOLPaintBox.BestEventName: string; begin Result := 'OnPaint'; end; @@ -7436,82 +5830,57 @@ end; constructor TKOLPaintBox.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPaintBox.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPaintBox.Create', 0 + +@@e_signature: end; inherited; - Width := 64; DefaultWidth := Width; - Height := 64; DefaultHeight := Height; - ControlStyle := ControlStyle + [ csAcceptsControls ]; + Width := 64; + DefaultWidth := Width; + Height := 64; + DefaultHeight := Height; + ControlStyle := ControlStyle + [csAcceptsControls]; end; -function TKOLPaintBox.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLPaintBox.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; +function TKOLPaintBox.SetupParams(const AName, AParent: TDelphiString): TDelphiString; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPaintBox.P_SetupParams', 0 - @@e_signature: - end; - nparams := 1; - Result := ' DUP'; -end; + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLPaintBox.SetupParams', 0 -procedure TKOLPaintBox.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewPaintBox', TRUE, TRUE, '' ); -end; - -function TKOLPaintBox.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPaintBox.SetupParams', 0 - @@e_signature: +@@e_signature: end; Result := AParent; end; -function TKOLPaintBox.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - { TKOLListView } -procedure TKOLListView.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLListView.AssignEvents(SL: TStringList; const AName: string); begin inherited; - DoAssignEvents( SL, AName, [ 'OnDeleteLVItem', 'OnLVCustomDraw', 'OnLVSubitemDraw'], - [ @ OnDeleteLVItem, @ OnLVCustomDraw, @ OnLVSubitemDraw] ); + DoAssignEvents(SL, AName, ['OnDeleteLVItem', 'OnLVCustomDraw', + 'OnLVSubitemDraw'], [@OnDeleteLVItem, @OnLVCustomDraw, @OnLVSubitemDraw]); end; constructor TKOLListView.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.Create', 0 + +@@e_signature: end; inherited; FCols := TList.Create; FGenerateColIdxConst := TRUE; - Width := 200; DefaultWidth := Width; - Height := 150; DefaultHeight := Height; + Width := 200; + DefaultWidth := Width; + Height := 150; + DefaultHeight := Height; FCurIndex := 0; FLVBkColor := clWindow; FLVTextBkColor := clWindow; @@ -7522,66 +5891,70 @@ end; function TKOLListView.DefaultColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.DefaultColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.DefaultColor', 0 + +@@e_signature: end; Result := clWindow; end; procedure TKOLListView.DefineProperties(Filer: TFiler); -var I: Integer; - Col: TKOLListViewColumn; +var + I: Integer; + Col: TKOLListViewColumn; begin inherited; - Filer.DefineProperty( 'ColCount', LoadColCount, SaveColCount, TRUE ); - for I := 0 to FColCount-1 do - begin + Filer.DefineProperty('ColCount', LoadColCount, SaveColCount, TRUE); + for I := 0 to FColCount - 1 do begin if FCols.Count <= I then - Col := TKOLListViewColumn.Create( Self ) + Col := TKOLListViewColumn.Create(Self) else - Col := FCols[ I ]; - Col.DefProps( 'Column' + IntToStr( I ), Filer ); + Col := FCols[I]; + Col.DefProps('Column' + IntToStr(I), Filer); end; end; destructor TKOLListView.Destroy; -var I: Integer; +var + I: Integer; begin ActiveDesign.Free; if ImageListNormal <> nil then - ImageListNormal.NotifyLinkedComponent( Self, noRemoved ); + ImageListNormal.NotifyLinkedComponent(Self, noRemoved); if ImageListSmall <> nil then - ImageListSmall.NotifyLinkedComponent( Self, noRemoved ); + ImageListSmall.NotifyLinkedComponent(Self, noRemoved); if ImageListState <> nil then - ImageListState.NotifyLinkedComponent( Self, noRemoved ); - for I := FCols.Count-1 downto 0 do - TObject( FCols[ I ] ).Free; + ImageListState.NotifyLinkedComponent(Self, noRemoved); + for I := FCols.Count - 1 downto 0 do + TObject(FCols[I]).Free; FCols.Free; inherited; end; procedure TKOLListView.DoGenerateConstants(SL: TStringList); -var I: Integer; - Col: TKOLListViewColumn; +var + I: Integer; + Col: TKOLListViewColumn; begin - if not generateConstants then Exit; - for I := 0 to Cols.Count-1 do - begin - Col := Cols[ I ]; + if not generateConstants then + Exit; + for I := 0 to Cols.Count - 1 do begin + Col := Cols[I]; if Col.Name <> '' then - SL.Add( 'const ' + Col.Name + ' = ' + IntToStr( I ) + ';' ); + SL.Add('const ' + Col.Name + ' = ' + IntToStr(I) + ';'); end; end; -function TKOLListView.GetCaption: String; +function TKOLListView.GetCaption: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.GetCaption', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.GetCaption', 0 + +@@e_signature: end; Result := inherited Caption; end; @@ -7589,20 +5962,21 @@ end; function TKOLListView.GetColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.GetColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.GetColor', 0 + +@@e_signature: end; Result := inherited Color; end; -function TKOLListView.GetColumns: String; +function TKOLListView.GetColumns: string; //var I: Integer; begin Result := ''; if Cols.Count > 0 then - Result := IntToStr( Cols.Count ) + ' columns'; + Result := IntToStr(Cols.Count) + ' columns'; {for I := 0 to Cols.Count-1 do begin if Result <> '' then Result := Result + ';'; @@ -7611,15 +5985,14 @@ begin end; function TKOLListView.HasOrderedColumns: Boolean; -var I: Integer; - C: TKOLListViewColumn; +var + I: Integer; + C: TKOLListViewColumn; begin Result := FALSE; - for I := 0 to Cols.Count-1 do - begin - C := Cols[ I ]; - if C.FLVColOrder >= 0 then - begin + for I := 0 to Cols.Count - 1 do begin + C := Cols[I]; + if C.FLVColOrder >= 0 then begin Result := TRUE; break; end; @@ -7643,23 +6016,23 @@ begin UpdateColumns; end; {YS} + procedure TKOLListView.LoadColCount(Reader: TReader); begin FColCount := Reader.ReadInteger; end; -procedure TKOLListView.NotifyLinkedComponent(Sender: TObject; - Operation: TNotifyOperation); +procedure TKOLListView.NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.NotifyLinkedComponent', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.NotifyLinkedComponent', 0 + +@@e_signature: end; inherited; - if Operation = noRemoved then - begin + if Operation = noRemoved then begin if Sender = FImageListNormal then ImageListNormal := nil; if Sender = FImageListSmall then @@ -7672,21 +6045,22 @@ end; procedure TKOLListView.SaveColCount(Writer: TWriter); begin FColCount := FCols.Count; - Writer.WriteInteger( FColCount ); + Writer.WriteInteger(FColCount); end; procedure TKOLListView.SetColor(const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetColor', 0 + +@@e_signature: end; inherited Color := Value; end; -procedure TKOLListView.SetColumns(const Value: String); +procedure TKOLListView.SetColumns(const Value: string); begin // end; @@ -7700,58 +6074,62 @@ end; procedure TKOLListView.SetImageListNormal(const Value: TKOLImageList); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetImageListNormal', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetImageListNormal', 0 + +@@e_signature: end; if FImageListNormal <> nil then - FImageListNormal.NotifyLinkedComponent( Self, noRemoved ); + FImageListNormal.NotifyLinkedComponent(Self, noRemoved); FImageListNormal := Value; if Value <> nil then - Value.AddToNotifyList( Self ); + Value.AddToNotifyList(Self); Change; end; procedure TKOLListView.SetImageListSmall(const Value: TKOLImageList); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetImageListSmall', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetImageListSmall', 0 + +@@e_signature: end; if FImageListSmall <> nil then - FImageListSmall.NotifyLinkedComponent( Self, noRemoved ); + FImageListSmall.NotifyLinkedComponent(Self, noRemoved); FImageListSmall := Value; if Value <> nil then - Value.AddToNotifyList( Self ); + Value.AddToNotifyList(Self); Change; end; procedure TKOLListView.SetImageListState(const Value: TKOLImageList); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetImageListState', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetImageListState', 0 + +@@e_signature: end; if FImageListState <> nil then - FImageListState.NotifyLinkedComponent( Self, noRemoved ); + FImageListState.NotifyLinkedComponent(Self, noRemoved); FImageListState := Value; if Value <> nil then - Value.AddToNotifyList( Self ); + Value.AddToNotifyList(Self); Change; end; procedure TKOLListView.SetLVCount(Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetLVCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetLVCount', 0 + +@@e_signature: end; if Value < 0 then Value := 0; @@ -7762,10 +6140,11 @@ end; procedure TKOLListView.SetLVTextBkColor(const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetLVTextBkColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetLVTextBkColor', 0 + +@@e_signature: end; FLVTextBkColor := Value; Change; @@ -7795,10 +6174,11 @@ var OldOpts: TKOLListViewOptions; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetOptions', 0 + +@@e_signature: end; OldOpts := FOptions; FOptions := Value; @@ -7806,12 +6186,12 @@ begin if ([lvoNoScroll, lvoNoSortHeader] * OldOpts <> []) or ([lvoNoScroll, lvoNoSortHeader] * Value <> []) then RecreateWnd else begin - Opts:=[]; + Opts := []; if lvoGridLines in FOptions then Include(Opts, kol.lvoGridLines); if lvoFlatsb in FOptions then Include(Opts, kol.lvoFlatsb); - FKOLCtrl.LVOptions:=Opts; + FKOLCtrl.LVOptions := Opts; UpdateAllowSelfPaint; end; end; @@ -7821,206 +6201,137 @@ end; procedure TKOLListView.SetStyle(const Value: TKOLListViewStyle); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetStyle', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetStyle', 0 + +@@e_signature: end; FStyle := Value; {YS} {$IFDEF _KOLCtrlWrapper_} - if Assigned( FKOLCtrl ) then - FKOLCtrl.LVStyle:=TListViewStyle(Value); + if Assigned(FKOLCtrl) then + FKOLCtrl.LVStyle := TListViewStyle(Value); UpdateAllowSelfPaint; {$ENDIF} {YS} Change; end; -procedure TKOLListView.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var I: Integer; - Col: TKOLListViewColumn; - KF: TKOLForm; - W: Integer; +procedure TKOLListView.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +var + I: Integer; + Col: TKOLListViewColumn; + KF: TKOLForm; + W: Integer; {$IFDEF _D2009orHigher} C, C2: WideString; - j : integer; + j: integer; {$ELSE} - C: String; + C: string; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetupFirst', 0 + +@@e_signature: end; inherited; KF := ParentKOLForm; - if (Font.Color <> clWindowText) and (Font.Color <> clNone) and (Font.Color <> clDefault) then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetLVTextColor', '' ); - KF.FormAddNumParameter( (Font.Color shl 1) or (Font.Color shr 31) ); - end else - SL.Add( Prefix + AName + '.LVTextColor := ' + Color2Str( Font.Color ) + ';' ); + if (Font.Color <> clWindowText) and (Font.Color <> clNone) and (Font.Color <> clDefault) then + SL.Add(Prefix + AName + '.LVTextColor := ' + Color2Str(Font.Color) + ';'); - if (LVTextBkColor <> clDefault) and (LVTextBkColor <> clNone) and (LVTextBkColor <> clWindow) then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetLVTextBkColor', '' ); - KF.FormAddNumParameter( (LVTextBkColor shl 1) or (LVTextBkColor shr 31) ); - end else - SL.Add( Prefix + AName + '.LVTextBkColor := ' + Color2Str( LVTextBkColor ) + ';' ); + if (LVTextBkColor <> clDefault) and (LVTextBkColor <> clNone) and (LVTextBkColor <> clWindow) then + SL.Add(Prefix + AName + '.LVTextBkColor := ' + Color2Str(LVTextBkColor) + ';'); - if (LVBkColor <> clDefault) and (LVBkColor <> clNone) and (LVBkColor <> clWindow) then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetLVBkColor', '' ); - KF.FormAddNumParameter( (LVBkColor shl 1) or (LVBkColor shr 31) ); - end else - SL.Add( Prefix + AName + '.LVBkColor := ' + Color2Str( LVBkColor ) + ';' ); + if (LVBkColor <> clDefault) and (LVBkColor <> clNone) and (LVBkColor <> clWindow) then + SL.Add(Prefix + AName + '.LVBkColor := ' + Color2Str(LVBkColor) + ';'); - if (KF <> nil) and KF.FormCompact and (Cols.Count > 0) then + for I := 0 to Cols.Count - 1 do begin + Col := Cols[I]; + W := Col.Width; + if Col.FLVColRightImg then + W := -W; begin - KF.FormAddCtlCommand( Name, 'FormLVColumsAdd', '' ); - KF.FormAddNumParameter( Cols.Count ); - for I := 0 to Cols.Count-1 do - begin - Col := Cols[ I ]; - W := Col.Width; - if Col.FLVColRightImg then - W := -W; - KF.FormAddNumParameter( W ); - KF.FormAddStrParameter( Col.Caption ); - end; - for I := 0 to Cols.Count-1 do - begin - Col := Cols[ I ]; - if Col.LVColImage >= 0 then - begin - KF.FormAddCtlCommand( Name, 'FormSetLVColImage', '' ); - KF.FormAddNumParameter( I ); - KF.FormAddNumParameter( Col.LVColImage ); - end; - if Col.LVColOrder >= 0 then - if Col.LVColOrder <> I then - begin - KF.FormAddCtlCommand( Name, 'FormSetLVColOrder', '' ); - KF.FormAddNumParameter( I ); - KF.FormAddNumParameter( Col.LVColOrder ); - end; - end; - end - else - begin - for I := 0 to Cols.Count-1 do - begin - Col := Cols[ I ]; - W := Col.Width; - if Col.FLVColRightImg then - W := -W; - begin {$IFDEF _D2009orHigher} - if (KF <> nil) and KF.AssignTextToControls then - C := StringConstant( 'Column' + IntToStr( I ) + 'Caption', Col.Caption ) - else - C := ''''''; - if C <> '''''' then - begin - C2 := ''; - for j := 2 to Length(C)-1 do - C2 := C2 + '#'+int2str(ord(C[j])); - C := C2; - end; - SL.Add( Prefix + AName + '.LVColAdd( ' + - C + ', ' + - TextAligns[ Col.TextAlign ] + ', ' + IntToStr( W ) + ');' ); + if (KF <> nil) and KF.AssignTextToControls then + C := StringConstant('Column' + IntToStr(I) + 'Caption', Col.Caption) + else + C := ''''''; + if C <> '''''' then begin + C2 := ''; + for j := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[j])); + C := C2; + end; + SL.Add(Prefix + AName + '.LVColAdd( ' + C + ', ' + TextAligns[Col.TextAlign] + + ', ' + IntToStr(W) + ');'); {$ELSE} - if (KF <> nil) and KF.AssignTextToControls then - C := Col.Caption - else - C := ''; - SL.Add( Prefix + AName + '.LVColAdd' + '( ' + - StringConstant( 'Column' + IntToStr( I ) + 'Caption', - C ) + ', ' + - TextAligns[ Col.TextAlign ] + ', ' + IntToStr( W ) + ');' ); + if (KF <> nil) and KF.AssignTextToControls then + C := Col.Caption + else + C := ''; + SL.Add(Prefix + AName + '.LVColAdd' + '( ' + StringConstant('Column' + + IntToStr(I) + 'Caption', C) + ', ' + TextAligns[Col.TextAlign] + ', ' + IntToStr(W) + ');'); {$ENDIF} - if Col.LVColImage >= 0 then - SL.Add( Prefix + AName + '.LVColImage[ ' + IntToStr( I ) + ' ] := ' + - IntToStr( Col.LVColImage ) + ';' ); - end; - end; - for I := 0 to Cols.Count-1 do - begin - Col := Cols[ I ]; - if Col.LVColOrder >= 0 then - if Col.LVColOrder <> I then - SL.Add( Prefix + AName + '.LVColOrder[ ' + IntToStr( I ) + ' ] := ' + - IntToStr( Col.LVColOrder ) + ';' ); - end; - //+++++++++++++++++++++++++++++ 2.93 + if Col.LVColImage >= 0 then + SL.Add(Prefix + AName + '.LVColImage[ ' + IntToStr(I) + ' ] := ' + IntToStr(Col.LVColImage) + ';'); end; + end; + for I := 0 to Cols.Count - 1 do begin + Col := Cols[I]; + if Col.LVColOrder >= 0 then + if Col.LVColOrder <> I then + SL.Add(Prefix + AName + '.LVColOrder[ ' + IntToStr(I) + ' ] := ' + IntToStr(Col.LVColOrder) + ';'); + end; + //+++++++++++++++++++++++++++++ 2.93 end; -procedure TKOLListView.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLListView.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetupLast', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetupLast', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if LVCount > 0 then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetCount', '' ); - KF.FormAddNumParameter( LVCount ); - end else - SL.Add( Prefix + AName + '.LVCount := ' + IntToStr( LVCount ) + ';' ); - if (KF <> nil) and KF.FormCompact then - begin - if ImageListNormal <> nil then - SL.Add( ' Result.' + Name + '.ImageListNormal := ' + - 'Result.' + ImageListNormal.Name + ';' ); - if ImageListSmall <> nil then - SL.Add( ' Result.' + Name + '.ImageListSmall := ' + - 'Result.' + ImageListSmall.Name + ';' ); - if ImageListState <> nil then - SL.Add( ' Result.' + Name + '.ImageListState := ' + - 'Result.' + ImageListState.Name + ';' ); - end; - if (lvoEditLabel in Options) and (TMethod(fOnEndEditLVItem).Code = nil) then - begin + if LVCount > 0 then + SL.Add(Prefix + AName + '.LVCount := ' + IntToStr(LVCount) + ';'); + + if (lvoEditLabel in Options) and (TMethod(fOnEndEditLVItem).Code = nil) then begin //(SL as TFormStringList).OnAdd := nil; //SL.Add( Prefix + AName + '.OnEndEditLVItem := nil;' ); //dufa fix crash - SL.Add(Prefix + AName + '.AttachProc(WndProcEndLabelEdit);'); //dufa fix crash - //if KF <> nil then - // (SL as TFormStringList).OnAdd := KF.DoFlushFormCompact; + SL.Add(Prefix + AName + '.AttachProc(WndProcEndLabelEdit);'); //dufa fix crash end; end; -function TKOLListView.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var S, O, ILSm, ILNr, ILSt: String; +function TKOLListView.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + S, O, ILSm, ILNr, ILSt: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.SetupParams', 0 + +@@e_signature: end; case Style of - lvsIcon: S := 'lvsIcon'; - lvsSmallIcon: S := 'lvsSmallIcon'; - lvsList: S := 'lvsList'; - lvsDetail: S := 'lvsDetail'; - lvsDetailNoHeader: S := 'lvsDetailNoHeader'; + lvsIcon: + S := 'lvsIcon'; + lvsSmallIcon: + S := 'lvsSmallIcon'; + lvsList: + S := 'lvsList'; + lvsDetail: + S := 'lvsDetail'; + lvsDetailNoHeader: + S := 'lvsDetailNoHeader'; end; O := ''; if lvoIconLeft in Options then @@ -8064,7 +6375,7 @@ begin if lvoFlatsb in Options then O := O + ', lvoFlatsb'; if lvoRegional in Options then - O := O + ', lvoRegional'; + O := O + ', lvoRegional'; if lvoInfoTip in Options then O := O + ', lvoInfoTip'; if lvoUnderlineHot in Options then @@ -8076,47 +6387,45 @@ begin if lvoOwnerDrawFixed in Options then O := O + ', lvoOwnerDrawFixed'; if O <> '' then - if O[ 1 ] = ',' then - O := Copy( O, 3, MaxInt ); + if O[1] = ',' then + O := Copy(O, 3, MaxInt); ILSm := 'nil'; - if ImageListSmall <> nil then - begin + if ImageListSmall <> nil then begin if ImageListSmall.ParentFORM.Name = ParentForm.Name then ILSm := 'Result.' + ImageListSmall.Name else - ILSm := ImageListSmall.ParentFORM.Name +'.'+ ImageListSmall.Name; + ILSm := ImageListSmall.ParentFORM.Name + '.' + ImageListSmall.Name; end; ILNr := 'nil'; - if ImageListNormal <> nil then - begin + if ImageListNormal <> nil then begin if ImageListNormal.ParentFORM.Name = ParentForm.Name then ILNr := 'Result.' + ImageListNormal.Name else - ILNr := ImageListNormal.ParentFORM.Name +'.'+ ImageListNormal.Name; + ILNr := ImageListNormal.ParentFORM.Name + '.' + ImageListNormal.Name; end; ILSt := 'nil'; - if ImageListState <> nil then - begin + if ImageListState <> nil then begin if ImageListState.ParentFORM.Name = ParentForm.Name then ILSt := 'Result.' + ImageListState.Name else - ILSt := ImageListState.ParentFORM.Name +'.'+ ImageListState.Name; + ILSt := ImageListState.ParentFORM.Name + '.' + ImageListState.Name; end; - Result := AParent + ', ' + S + ', [ ' + O + ' ], ' + ILSm + ', ' + ILNr - + ', ' + ILSt; + Result := AParent + ', ' + S + ', [ ' + O + ' ], ' + ILSm + ', ' + ILNr + ', ' + ILSt; end; function TKOLListView.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLListView.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; {YS} + procedure TKOLListView.UpdateColumns; {$IFDEF _KOLCtrlWrapper_} var @@ -8126,20 +6435,20 @@ var begin {$IFDEF _KOLCtrlWrapper_} if Assigned(FKOLCtrl) then - with FKOLCtrl^ do begin - BeginUpdate; - try - while LVColCount > 0 do - LVColDelete(0); - for i:=0 to FCols.Count - 1 do begin - col:=FCols[i]; - LVColAdd(col.Caption, KOL.TTextAlign(col.TextAlign), col.Width) + with FKOLCtrl^ do begin + BeginUpdate; + try + while LVColCount > 0 do + LVColDelete(0); + for i := 0 to FCols.Count - 1 do begin + col := FCols[i]; + LVColAdd(col.Caption, KOL.TTextAlign(col.TextAlign), col.Width) + end; + finally + EndUpdate; end; - finally - EndUpdate; + UpdateAllowSelfPaint; end; - UpdateAllowSelfPaint; - end; {$ENDIF} end; @@ -8152,7 +6461,7 @@ procedure TKOLListView.CreateKOLControl(Recreating: boolean); var Opts: kol.TListViewOptions; begin - Opts:=[]; + Opts := []; if lvoGridLines in FOptions then Include(Opts, kol.lvoGridLines); if lvoFlatsb in FOptions then @@ -8161,12 +6470,12 @@ begin Include(Opts, kol.lvoNoScroll); if lvoNoSortHeader in FOptions then Include(Opts, kol.lvoNoSortHeader); - FKOLCtrl := NewListView(KOLParentCtrl, TListViewStyle(Style), opts, nil, nil, nil); + FKOLCtrl := NewListView(KOLParentCtrl, TListViewStyle(Style), Opts, nil, nil, nil); end; function TKOLListView.NoDrawFrame: Boolean; begin - Result:=HasBorder; + Result := HasBorder; end; {YS} @@ -8178,7 +6487,7 @@ end; function TKOLListView.GetDefaultControlFont: HFONT; begin - Result:=GetStockObject(DEFAULT_GUI_FONT); + Result := GetStockObject(DEFAULT_GUI_FONT); end; procedure TKOLListView.SetLVItemHeight(const Value: Integer); @@ -8189,300 +6498,51 @@ begin end; end; -function TKOLListView.GenerateTransparentInits: String; -begin - if fLVItemHeight > 0 then Result := '.SetLVItemHeight('+IntToStr(fLVItemHeight)+')' - else Result := ''; - Result := Result + inherited GenerateTransparentInits(); -end; - -procedure TKOLListView.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.P_SetupLast', 0 - @@e_signature: - end; - inherited; - if LVCount > 0 then - //SL.Add( Prefix + AName + '.LVCount := ' + IntToStr( LVCount ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( LVCount ) + ')' ); - {P}SL.Add( ' ' + - 'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name + - ' TControl_.SetItemsCount<2>' ); - end; -end; - -procedure TKOLListView.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var I: Integer; - Col: TKOLListViewColumn; - KF: TKOLForm; - W: Integer; - WifUnicode: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - KF := ParentKOLForm; - if (KF <> nil) and KF.Unicode then WifUnicode := 'W' else WifUnicode := ''; - if (Font.Color <> clWindowText) and (Font.Color <> clNone) and (Font.Color <> clDefault) then - //SL.Add( Prefix + AName + '.LVTextColor := ' + Color2Str( Font.Color ) + ';' ); - {P}SL.Add( ' L($' + IntToHex( Font.Color, 6 ) + ')' + - ' L(' + IntToStr( LVM_GETTEXTCOLOR ) + ')' + - ' C2 TControl_.LVSetColorByIdx<3>' ); - if (LVTextBkColor <> clDefault) and (LVTextBkColor <> clNone) and (LVTextBkColor <> clWindow) then - //SL.Add( Prefix + AName + '.LVTextBkColor := ' + Color2Str( LVTextBkColor ) + ';' ); - {P}SL.Add( ' L($' + IntToHex( LVTextBkColor, 6 ) + ')' + - ' L(' + IntToStr(LVM_GETTEXTBKCOLOR) + ')' + - ' C2 TControl_.LVSetColorByIdx<3>' ); - if (LVBkColor <> clDefault) and (LVBkColor <> clNone) and (LVBkColor <> clWindow) then - //SL.Add( Prefix + AName + '.LVBkColor := ' + Color2Str( LVBkColor ) + ';' ); - {P}SL.Add( ' L($' + IntToHex( LVBkColor, 6 ) + ')' + - ' C1 TControl_.SetCtlColor<2>' ); - for I := 0 to Cols.Count-1 do - begin - Col := Cols[ I ]; - W := Col.Width; - if Col.FLVColRightImg then - W := -W; - {SL.Add( Prefix + AName + '.LVColAdd' + WifUnicode + '( ' + - StringConstant( 'Column' + IntToStr( I ) + 'Caption', - Col.Caption ) + ', ' + - TextAligns[ Col.TextAlign ] + ', ' + IntToStr( W ) + ');' );} - {P}SL.Add( P_StringConstant( 'Column' + IntToStr( I ) + 'Caption', Col.Caption ) + - ' L(' + IntToStr( W ) + ')' + - ' L(' + IntToStr( Integer( Col.TextAlign ) ) + ') ' + - ' C2 ' + - ' C5 TControl_.LVColAdd' + WifUnicode + '<3>' + - ' DEL DelAnsiStr' ); - if Col.LVColImage >= 0 then - //SL.Add( Prefix + AName + '.LVColImage[ ' + IntToStr( I ) + ' ] := ' + - // IntToStr( Col.LVColImage ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( Col.LVColImage ) + ')' + - ' L(' + IntToStr( I ) + ')' + - ' L(' + IntToStr( LVCF_IMAGE or (24 shl 16) ) + ')' + - ' C3 TControl_.SetLVColEx<3>' ); - end; - for I := 0 to Cols.Count-1 do - begin - Col := Cols[ I ]; - if Col.LVColOrder >= 0 then - if Col.LVColOrder <> I then - //SL.Add( Prefix + AName + '.LVColOrder[ ' + IntToStr( I ) + ' ] := ' + - // IntToStr( Col.LVColOrder ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( Col.LVColOrder ) + ')' + - ' L(' + IntToStr( I ) + ')' + - ' L(' + IntToStr( LVCF_ORDER or (28 shl 16) ) + ')' + - ' C3 TControl_.SetLVColEx<3>' ); - end; -end; - -function TKOLListView.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; - function P_LVLoadImageList( IL: TKOLImageList ): String; - begin - if IL = nil then Result := ' L(0)' - else if IL.ParentFORM.Name = ParentForm.Name then - Result := ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - IL.Name - else Result := ' LoadDWORD ####' + IL.ParentFORM.Name + - ' AddWord_LoadRef ##T' + IL.ParentFORM.Name + '.' + IL.Name; - end; -//var S, O, ILSm, ILNr, ILSt: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLListView.P_SetupParams', 0 - @@e_signature: - end; - {case Style of - lvsIcon: S := 'lvsIcon'; - lvsSmallIcon: S := 'lvsSmallIcon'; - lvsList: S := 'lvsList'; - lvsDetail: S := 'lvsDetail'; - lvsDetailNoHeader: S := 'lvsDetailNoHeader'; - end; - O := ''; - if lvoIconLeft in Options then - O := 'lvoIconLeft'; - if lvoAutoArrange in Options then - O := O + ', lvoAutoArrange'; - if lvoButton in Options then - O := O + ', lvoButton'; - if lvoEditLabel in Options then - O := O + ', lvoEditLabel'; - if lvoNoLabelWrap in Options then - O := O + ', lvoNoLabelWrap'; - if lvoNoScroll in Options then - O := O + ', lvoNoScroll'; - if lvoNoSortHeader in Options then - O := O + ', lvoNoSortHeader'; - if lvoHideSel in Options then - O := O + ', lvoHideSel'; - if lvoMultiselect in Options then - O := O + ', lvoMultiselect'; - if lvoSortAscending in Options then - O := O + ', lvoSortAscending'; - if lvoSortDescending in Options then - O := O + ', lvoSortDescending'; - if lvoGridLines in Options then - O := O + ', lvoGridLines'; - if lvoSubItemImages in Options then - O := O + ', lvoSubItemImages'; - if lvoCheckBoxes in Options then - O := O + ', lvoCheckBoxes'; - if lvoTrackSelect in Options then - O := O + ', lvoTrackSelect'; - if lvoHeaderDragDrop in Options then - O := O + ', lvoHeaderDragDrop'; - if lvoRowSelect in Options then - O := O + ', lvoRowSelect'; - if lvoOneClickActivate in Options then - O := O + ', lvoOneClickActivate'; - if lvoTwoClickActivate in Options then - O := O + ', lvoTwoClickActivate'; - if lvoFlatsb in Options then - O := O + ', lvoFlatsb'; - if lvoRegional in Options then - O := O + ', lvoRegional'; - if lvoInfoTip in Options then - O := O + ', lvoInfoTip'; - if lvoUnderlineHot in Options then - O := O + ', lvoUnderlineHot'; - if lvoMultiWorkares in Options then - O := O + ', lvoMultiWorkares'; - if lvoOwnerData in Options then - O := O + ', lvoOwnerData'; - if lvoOwnerDrawFixed in Options then - O := O + ', lvoOwnerDrawFixed'; - if O <> '' then - if O[ 1 ] = ',' then - O := Copy( O, 3, MaxInt ); - ILSm := 'nil'; - if ImageListSmall <> nil then - begin - if ImageListSmall.ParentFORM.Name = ParentForm.Name then - ILSm := 'Result.' + ImageListSmall.Name - else - ILSm := ImageListSmall.ParentFORM.Name +'.'+ ImageListSmall.Name; - end; - ILNr := 'nil'; - if ImageListNormal <> nil then - begin - if ImageListNormal.ParentFORM.Name = ParentForm.Name then - ILNr := 'Result.' + ImageListNormal.Name - else - ILNr := ImageListNormal.ParentFORM.Name +'.'+ ImageListNormal.Name; - end; - ILSt := 'nil'; - if ImageListState <> nil then - begin - if ImageListState.ParentFORM.Name = ParentForm.Name then - ILSt := 'Result.' + ImageListState.Name - else - ILSt := ImageListState.ParentFORM.Name +'.'+ ImageListState.Name; - end; - Result := AParent + ', ' + S + ', [ ' + O + ' ], ' + ILSm + ', ' + ILNr - + ', ' + ILSt;} - - {P}//-----------------------------------------------------------------------// - nparams := 3; - Result := P_LVLoadImageList( ImageListSmall ) + - #13#10 + P_LVLoadImageList( ImageListNormal ) + - #13#10 + P_LVLoadImageList( ImageListState ) + - #13#10' L(' + IntToStr( PInteger( @ Options )^ ) + ')' + - #13#10' L(' + IntToStr( Integer( Style ) ) + ')' + - #13#10' C5'; -end; - -function TKOLListView.P_GenerateTransparentInits: String; +function TKOLListView.GenerateTransparentInits: string; begin if fLVItemHeight > 0 then - //Result := '.SetLVItemHeight('+IntToStr(fLVItemHeight)+')' - {P}Result := ' L(' + IntToStr( fLVItemHeight ) + ')' + - ' C1 TControl_.SetLVItemHeight<2>' - else Result := ''; - Result := Result + inherited P_GenerateTransparentInits(); + Result := '.SetLVItemHeight(' + IntToStr(fLVItemHeight) + ')' + else + Result := ''; + Result := Result + inherited GenerateTransparentInits(); end; procedure TKOLListView.Paint; var I: Integer; - w: WideString; + C: ArrayTCDLVColumn; begin if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin PrepareCanvasFontForWYSIWIGPaint(Canvas); // cols - w := ''; - if (Style = lvsDetail) then begin - for I := 0 to Pred(Cols.Count) do - w := w + Trim(TKOLListViewColumn(Cols[I]).Caption) + #13; + SetLength(C, Cols.Count); + for I := 0 to High(C) do begin + C[I].Caption := TKOLListViewColumn(Cols[I]).Caption; + C[I].TextAlign := KOL.TTextAlign(TKOLListViewColumn(Cols[I]).TextAlign); + C[I].Width := TKOLListViewColumn(Cols[I]).Width; end; // draw - DrawListView(True, Canvas.Handle, ClientRect, Enabled, w); + DrawListView(True, Enabled, Canvas.Handle, ClientRect, C); end; inherited; end; -function TKOLListView.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLListView.P_AssignEvents(SL: TStringList; - const AName: String; CheckOnly: Boolean): Boolean; -begin - Result := inherited P_AssignEvents( SL, AName, CheckOnly ); - if Result and CheckOnly then Exit; - Result := Result or - P_DoAssignEvents( SL, AName, [ 'OnDeleteLVItem', 'OnLVCustomDraw', 'OnLVSubitemDraw'], - [ @ OnDeleteLVItem, @ OnLVCustomDraw, @ OnLVSubitemDraw], - [ TRUE, TRUE, TRUE ], CheckOnly ); -end; - -procedure TKOLListView.GenerateTransparentInits_Compact; -begin - inherited; -end; - -procedure TKOLListView.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewListView', TRUE, TRUE, '' ); - KF.FormAddNumParameter( Integer( Style ) ); - KF.FormAddNumParameter( PInteger( @ Options )^ ); -end; - -function TKOLListView.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - { TKOLTreeView } constructor TKOLTreeView.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.Create', 0 + +@@e_signature: end; inherited; - Width := 150; DefaultWidth := Width; - Height := 200; DefaultHeight := Height; + Width := 150; + DefaultWidth := Width; + Height := 200; + DefaultHeight := Height; FCurIndex := 0; TabStop := TRUE; FHasScrollbarsToOverride := TRUE; @@ -8490,16 +6550,17 @@ end; procedure TKOLTreeView.CreateKOLControl(Recreating: boolean); begin - FKOLCtrl:=NewTreeView(KOLParentCtrl, [], nil, nil); + FKOLCtrl := NewTreeView(KOLParentCtrl, [], nil, nil); end; function TKOLTreeView.DefaultColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.DefaultColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.DefaultColor', 0 + +@@e_signature: end; Result := clWindow; end; @@ -8507,29 +6568,28 @@ end; destructor TKOLTreeView.Destroy; begin if ImageListNormal <> nil then - ImageListNormal.NotifyLinkedComponent( Self, noRemoved ); + ImageListNormal.NotifyLinkedComponent(Self, noRemoved); if ImageListState <> nil then - ImageListState.NotifyLinkedComponent( Self, noRemoved ); + ImageListState.NotifyLinkedComponent(Self, noRemoved); inherited; end; function TKOLTreeView.NoDrawFrame: Boolean; begin - Result:=HasBorder; + Result := HasBorder; end; -procedure TKOLTreeView.NotifyLinkedComponent(Sender: TObject; - Operation: TNotifyOperation); +procedure TKOLTreeView.NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.NotifyLinkedComponent', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.NotifyLinkedComponent', 0 + +@@e_signature: end; inherited; - if Operation = noRemoved then - begin + if Operation = noRemoved then begin if Sender = FImageListNormal then ImageListNormal := nil; if Sender = FImageListState then @@ -8541,121 +6601,19 @@ procedure TKOLTreeView.Paint; begin if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin PrepareCanvasFontForWYSIWIGPaint(Canvas); - DrawTreeView(True, Canvas.Handle, ClientRect, Enabled, Name); + DrawTreeView(True, Enabled, Canvas.Handle, ClientRect, Name); end; inherited; end; -function TKOLTreeView.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLTreeView.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if TVRightClickSelect then - //SL.Add( Prefix + AName + '.TVRightClickSelect := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetTVRightClickSelect<2>' ); - if TVIndent > 0 then - //SL.Add( Prefix + AName + '.TVIndent := ' + IntToStr( TVIndent ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( TVIndent ) + ')' + - ' L(' + IntToStr( TVM_GETINDENT ) + ')' + - ' C2 TControl_.SetIntVal<3>' ); -end; - -function TKOLTreeView.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; - function P_TVImageList( IL: TKOLImageList ): String; - begin - if IL = nil then Result := ' L(0)' - else if IL.ParentFORM.Name = ParentForm.Name then - Result := ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - IL.Name - else Result := ' LoadDWORD ####' + IL.ParentFORM.Name + - ' AddWord_LoadRef ##T' + IL.ParentFORM.Name + '.' + IL.Name; - end; -//var O, ILNr, ILSt: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.P_SetupParams', 0 - @@e_signature: - end; - { - O := ''; - if tvoNoLines in Options then - O := 'tvoNoLines'; - if tvoLinesRoot in Options then - O := O + ', tvoLinesRoot'; - if tvoNoButtons in Options then - O := O + ', tvoNoButtons'; - if tvoEditLabels in Options then - O := O + ', tvoEditLabels'; - if tvoHideSel in Options then - O := O + ', tvoHideSel'; - if tvoDragDrop in Options then - O := O + ', tvoDragDrop'; - if tvoNoTooltips in Options then - O := O + ', tvoNoTooltips'; - if tvoCheckBoxes in Options then - O := O + ', tvoCheckBoxes'; - if tvoTrackSelect in Options then - O := O + ', tvoTrackSelect'; - if tvoSingleExpand in Options then - O := O + ', tvoSingleExpand'; - if tvoInfoTip in Options then - O := O + ', tvoInfoTip'; - if tvoFullRowSelect in Options then - O := O + ', tvoFullRowSelect'; - if tvoNoScroll in Options then - O := O + ', tvoNoScroll'; - if tvoNonEvenHeight in Options then - O := O + ', tvoNonEvenHeight'; - if O <> '' then - if O[ 1 ] = ',' then - O := Copy( O, 3, MaxInt ); - ILNr := 'nil'; - if ImageListNormal <> nil then - begin - if ImageListNormal.ParentFORM.Name = ParentForm.Name then - ILNr := 'Result.' + ImageListNormal.Name - else - ILNr := ImageListNormal.ParentFORM.Name +'.'+ ImageListNormal.Name; - end; - ILSt := 'nil'; - if ImageListState <> nil then - begin - if ImageListState.ParentFORM.Name = ParentForm.Name then - ILSt := 'Result.' + ImageListState.Name - else - ILSt := ImageListState.ParentFORM.Name +'.'+ ImageListState.Name; - end; - Result := AParent + ', [ ' + O + ' ], ' + ILNr + ', ' + ILSt; - } - {P}//------------------------------------------------------------------------- - nparams := 3; - Result := P_TVImageList( ImageListState ) + - #13#10 + P_TVImageList( ImageListNormal ) + - #13#10' L(' + IntToStr( PWord( @ Options )^ ) + ')' + - #13#10' C3'; -end; - procedure TKOLTreeView.SetCurIndex(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.SetCurIndex', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.SetCurIndex', 0 + +@@e_signature: end; FCurIndex := Value; Change; @@ -8664,42 +6622,45 @@ end; procedure TKOLTreeView.SetImageListNormal(const Value: TKOLImageList); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.SetImageListNormal', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.SetImageListNormal', 0 + +@@e_signature: end; if FImageListNormal <> nil then - FImageListNormal.NotifyLinkedComponent( Self, noRemoved ); + FImageListNormal.NotifyLinkedComponent(Self, noRemoved); FImageListNormal := Value; if Value <> nil then - Value.AddToNotifyList( Self ); + Value.AddToNotifyList(Self); Change; end; procedure TKOLTreeView.SetImageListState(const Value: TKOLImageList); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.SetImageListState', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.SetImageListState', 0 + +@@e_signature: end; if FImageListState <> nil then - FImageListState.NotifyLinkedComponent( Self, noRemoved ); + FImageListState.NotifyLinkedComponent(Self, noRemoved); FImageListState := Value; if Value <> nil then - Value.AddToNotifyList( Self ); + Value.AddToNotifyList(Self); Change; end; procedure TKOLTreeView.SetOptions(const Value: TKOLTreeViewOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.SetOptions', 0 + +@@e_signature: end; FOptions := Value; Change; @@ -8708,10 +6669,11 @@ end; procedure TKOLTreeView.SetTVIndent(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.SetTVIndent', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.SetTVIndent', 0 + +@@e_signature: end; FTVIndent := Value; Change; @@ -8720,79 +6682,49 @@ end; procedure TKOLTreeView.SetTVRightClickSelect(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView,SetTVRightClickSelect', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView,SetTVRightClickSelect', 0 + +@@e_signature: end; FTVRightClickSelect := Value; Change; end; -procedure TKOLTreeView.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewTreeView', TRUE, TRUE, '' ); - KF.FormAddNumParameter( PInteger( @ Options )^ ); -end; - -procedure TKOLTreeView.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLTreeView.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if TVRightClickSelect then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TKOLControl.SetTVRightClickSelect', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.TVRightClickSelect := TRUE;' ); - if TVIndent > 0 then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetTVIndent', '' ); - KF.FormAddNumParameter( TVIndent ); - end else - SL.Add( Prefix + AName + '.TVIndent := ' + IntToStr( TVIndent ) + ';' ); + if TVRightClickSelect then + SL.Add(Prefix + AName + '.TVRightClickSelect := TRUE;'); + + if TVIndent > 0 then + SL.Add(Prefix + AName + '.TVIndent := ' + IntToStr(TVIndent) + ';'); end; -procedure TKOLTreeView.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLTreeView.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin inherited; - KF := ParentKOLForm; - if (KF <> nil) and KF.FormCompact then - begin - if ImageListNormal <> nil then - SL.Add( ' Result.' + Name + '.ImageListNormal := ' + - 'Result.' + ImageListNormal.Name + ';' ); - if ImageListState <> nil then - SL.Add( ' Result.' + Name + '.ImageListState := ' + - 'Result.' + ImageListState.Name + ';' ); - end; end; -function TKOLTreeView.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var O, ILNr, ILSt: String; +function TKOLTreeView.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + O, ILNr, ILSt: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.SetupParams', 0 + +@@e_signature: end; O := ''; if tvoNoLines in Options then @@ -8824,39 +6756,33 @@ begin if tvoNonEvenHeight in Options then O := O + ', tvoNonEvenHeight'; if O <> '' then - if O[ 1 ] = ',' then - O := Copy( O, 3, MaxInt ); + if O[1] = ',' then + O := Copy(O, 3, MaxInt); ILNr := 'nil'; - if ImageListNormal <> nil then - begin + if ImageListNormal <> nil then begin if ImageListNormal.ParentFORM.Name = ParentForm.Name then ILNr := 'Result.' + ImageListNormal.Name else - ILNr := ImageListNormal.ParentFORM.Name +'.'+ ImageListNormal.Name; + ILNr := ImageListNormal.ParentFORM.Name + '.' + ImageListNormal.Name; end; ILSt := 'nil'; - if ImageListState <> nil then - begin + if ImageListState <> nil then begin if ImageListState.ParentFORM.Name = ParentForm.Name then ILSt := 'Result.' + ImageListState.Name else - ILSt := ImageListState.ParentFORM.Name +'.'+ ImageListState.Name; + ILSt := ImageListState.ParentFORM.Name + '.' + ImageListState.Name; end; Result := AParent + ', [ ' + O + ' ], ' + ILNr + ', ' + ILSt; end; -function TKOLTreeView.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - function TKOLTreeView.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTreeView.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTreeView.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; @@ -8868,36 +6794,38 @@ end; { TKOLRichEdit } -function TKOLRichEdit.AdditionalUnits: String; +function TKOLRichEdit.AdditionalUnits: string; begin Result := inherited AdditionalUnits; if OLESupport then Result := Result + ', KOLOLERE'; end; -procedure TKOLRichEdit.AfterFontChange( SL: TStrings; const AName, Prefix: String ); +procedure TKOLRichEdit.AfterFontChange(SL: TStrings; const AName, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.AfterFontChange', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.AfterFontChange', 0 + +@@e_signature: end; - SL.Add( Prefix + AName + '.RE_CharFmtArea := raSelection;' ); + SL.Add(Prefix + AName + '.RE_CharFmtArea := raSelection;'); end; -procedure TKOLRichEdit.BeforeFontChange( SL: TStrings; const AName, Prefix: String ); +procedure TKOLRichEdit.BeforeFontChange(SL: TStrings; const AName, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.BeforeFontChange', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.BeforeFontChange', 0 + +@@e_signature: end; - SL.Add( Prefix + AName + '.RE_CharFmtArea := raAll;' ); + SL.Add(Prefix + AName + '.RE_CharFmtArea := raAll;'); end; -function TKOLRichEdit.BestEventName: String; +function TKOLRichEdit.BestEventName: string; begin Result := 'OnChange'; end; @@ -8905,10 +6833,11 @@ end; constructor TKOLRichEdit.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.Create', 0 + +@@e_signature: end; FLines := TStringList.Create; inherited; @@ -8916,8 +6845,10 @@ begin FRE_AutoFontSizeAdjust := TRUE; FDefIgnoreDefault := TRUE; FIgnoreDefault := TRUE; - Width := 164; DefaultWidth := 100; - Height := 200; DefaultHeight := Height; + Width := 164; + DefaultWidth := 100; + Height := 200; + DefaultHeight := Height; TabStop := TRUE; version := ver3; FMaxTextSize := 32767; @@ -8928,10 +6859,10 @@ procedure TKOLRichEdit.CreateKOLControl(Recreating: boolean); var opts: kol.TEditOptions; begin - Log( '->TKOLRichEdit.CreateKOLControl' ); - TRY + Log('->TKOLRichEdit.CreateKOLControl'); + try inherited; - opts:=[]; + opts := []; if eo_Lowercase in FOptions then Include(opts, kol.eoLowercase); if eo_NoHScroll in FOptions then @@ -8942,18 +6873,19 @@ begin Include(opts, kol.eoUpperCase); FKOLCtrl := NewRichEdit(KOLParentCtrl, opts); LogOK; - FINALLY - Log( '<-TKOLRichEdit.CreateKOLControl' ); - END; + finally + Log('<-TKOLRichEdit.CreateKOLControl'); + end; end; function TKOLRichEdit.DefaultColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.DefaultColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.DefaultColor', 0 + +@@e_signature: end; Result := clWindow; end; @@ -8961,10 +6893,11 @@ end; destructor TKOLRichEdit.Destroy; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.Destroy', 0 + +@@e_signature: end; FLines.Free; inherited; @@ -8973,56 +6906,50 @@ end; procedure TKOLRichEdit.FirstCreate; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.FirstCreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.FirstCreate', 0 + +@@e_signature: end; FLines.Text := Name; inherited; end; -function TKOLRichEdit.FontPropName: String; +function TKOLRichEdit.FontPropName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.FontPropName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.FontPropName', 0 + +@@e_signature: end; Result := 'RE_Font'; end; -function TKOLRichEdit.GenerateTransparentInits: String; +function TKOLRichEdit.GenerateTransparentInits: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.GenerateTransparentInits', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.GenerateTransparentInits', 0 + +@@e_signature: end; Result := inherited GenerateTransparentInits; if RE_FmtStandard then Result := Result + '.RE_FmtStandard'; end; -procedure TKOLRichEdit.GenerateTransparentInits_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - if RE_FmtStandard then - KF.FormAddCtlCommand( Name, 'TControl.RE_FmtStandard', '' ); -end; - -function TKOLRichEdit.GetCaption: String; +function TKOLRichEdit.GetCaption: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.GetCaption', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.GetCaption', 0 + +@@e_signature: end; Result := FLines.Text; end; @@ -9030,10 +6957,11 @@ end; function TKOLRichEdit.GetText: TStrings; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.GetText', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.GetText', 0 + +@@e_signature: end; Result := FLines; end; @@ -9042,171 +6970,39 @@ procedure TKOLRichEdit.KOLControlRecreated; begin inherited; if Assigned(FKOLCtrl) then - FKOLCtrl.Text:=FLines.Text; + FKOLCtrl.Text := FLines.Text; end; procedure TKOLRichEdit.Loaded; begin inherited; if Assigned(FKOLCtrl) then - FKOLCtrl.Text:=FLines.Text; + FKOLCtrl.Text := FLines.Text; end; function TKOLRichEdit.NoDrawFrame: Boolean; begin - Result:=HasBorder; + Result := HasBorder; end; procedure TKOLRichEdit.Paint; begin if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin PrepareCanvasFontForWYSIWIGPaint(Canvas); - DrawMemo(True, Canvas.Handle, ClientRect, Color, Enabled, KOLMemoOptions2ScrollStyle(Options), TextHFlags[KOL.TTextAlign(TextAlign)], Text.Text); + DrawMemo(True, Enabled, Canvas.Handle, ClientRect, Color, + KOLMemoOptions2ScrollStyle(Options), TextHFlags[KOL.TTextAlign(TextAlign)], Text.Text); end; inherited; end; -function TKOLRichEdit.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLRichEdit.P_AfterFontChange(SL: TStrings; const AName, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.P_AfterFontChange', 0 - @@e_signature: - end; - //SL.Add( Prefix + AName + '.RE_CharFmtArea := raSelection;' ); - {P}SL.Add( ' L(' + IntToStr( Integer( raSelection ) ) + ') ' + - ' C1 AddWord_StoreB ##TControl_.fRECharArea' ); -end; - -procedure TKOLRichEdit.P_BeforeFontChange(SL: TStrings; const AName, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.P_BeforeFontChange', 0 - @@e_signature: - end; - //SL.Add( Prefix + AName + '.RE_CharFmtArea := raAll;' ); - {P}SL.Add( ' L(' + IntToStr( Integer( raAll ) ) + ') ' + - ' C1 AddWord_StoreB ##TControl_.fRECharArea' ); - -end; - -function TKOLRichEdit.P_GenerateTransparentInits: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.P_GenerateTransparentInits', 0 - @@e_signature: - end; - Result := inherited P_GenerateTransparentInits; - if RE_FmtStandard then - //Result := Result + '.RE_FmtStandard'; - {P}Result := Result + ' DUP TControl.RE_FmtStandard<1>'; -end; - -procedure TKOLRichEdit.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if RE_AutoURLDetect then - //SL.Add( Prefix + AName + '.RE_AutoURLDetect := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetRE_AutoURLDetect<2>' ); - if not RE_AutoFont then - {P}SL.Add( ' L(0) L(2) C2 TControl_.RESetLangOptions<3>' ); - if not RE_AutoFontSizeAdjust then - {P}SL.Add( ' L(0) L(16) C2 TControl_.RESetLangOptions<3>' ); - if RE_DualFont then - {P}SL.Add( ' L(1) L(128) C2 TControl_.RESetLangOptions<3>' ); - if RE_UIFonts then - {P}SL.Add( ' L(1) L(32) C2 TControl_.RESetLangOptions<3>' ); - if RE_IMECancelComplete then - {P}SL.Add( ' L(1) L(4) C2 TControl_.RESetLangOptions<3>' ); - if RE_IMEAlwaysSendNotify then - {P}SL.Add( ' L(1) L(8) C2 TControl_.RESetLangOptions<3>' ); - if MaxTextSize <> 32767 then - if MaxTextSize > $7FFFffff then - //SL.Add( Prefix + AName + '.MaxTextSize := $' + IntToHex( MaxTextSize, 8 ) + ';' ) - {P}SL.Add( ' L($' + Int2Hex( MaxTextSize, 8 ) + ')' + - ' C1 TControl_.SetMaxTextSize<2>' ) - else - //SL.Add( Prefix + AName + '.MaxTextSize := ' + IntToStr( MaxTextSize ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( MaxTextSize ) + ')' + - ' C1 TControl_.SetMaxTextSize<2>' ); - if (FRE_ZoomNumerator <> 0) and (FRE_ZoomDenominator <> 0) then - //SL.Add( Prefix + AName + '.RE_Zoom := MakeSmallPoint( ' + IntToStr( FRE_ZoomNumerator ) + - // ', ' + IntToStr( FRE_ZoomDenominator ) + ' );' ); - {P}SL.Add( ' L( ' + IntToStr( FRE_ZoomDenominator or (FRE_ZoomNumerator shl 16) ) + ') ' + - ' C1 TControl_.RESetZoom<2>' ); - if FLines.Text <> '' then - begin - {P}SL.Add( 'LoadAnsiStr ' + P_String2Pascal( FLines.Text ) ); - {P}SL.Add( //' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + Name + - ' C2' + - ' TControl_.SetCaption<2>' ); - {P}SL.Add( ' DelAnsiStr' ); - end; - if RE_AutoKeybdSet then - //SL.Add( Prefix + AName + '.RE_AutoKeyboard := ' + BoolVal[ RE_AutoKeyboard ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( RE_AutoKeyboard ) ) + ') L(1) ' + - ' C2 TControl_.RESetLangOptions<3>' ); - if RE_DisableOverwriteChange then - //SL.Add( Prefix + AName + '.RE_DisableOverwriteChange := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetRE_DisableOverwriteChange<2>' ); - if RE_Transparent then - //SL.Add( Prefix + AName + '.RE_Transparent := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetRE_Transparent<2>' ); -end; - -function TKOLRichEdit.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -var EO: KOL.TEditOptions; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMemo.P_SetupParams', 0 - @@e_signature: - end; - nparams := 2; - EO := [ KOL.eoMultiline ]; - if eo_NoHScroll in Options then EO := EO + [ KOL.eoNoHScroll ]; - if eo_NoVScroll in Options then EO := EO + [ KOL.eoNoVScroll ]; - if eo_Lowercase in Options then EO := EO + [ KOL.eoLowercase ]; - if eo_NoHideSel in Options then EO := EO + [ KOL.eoNoHideSel ]; - if eo_OemConvert in Options then EO := EO + [ KOL.eoOemConvert ]; - if eo_Password in Options then EO := EO + [ KOL.eoPassword ]; - if eo_Readonly in Options then EO := EO + [ KOL.eoReadonly ]; - if eo_UpperCase in options then EO := EO + [ KOL.eoUpperCase ]; - if eo_WantReturn in options then EO := EO + [ KOL.eoWantReturn ]; - if eo_WantTab in options then EO := EO + [ KOL.eoWantTab ]; - {P}Result := ' L(' + IntToStr( PWord( @ EO )^ ) + ') '; - {P} Result := Result + - #13#10' C1'; -end; - procedure TKOLRichEdit.SetMaxTextSize(const Value: DWORD); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetMaxTextSize', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetMaxTextSize', 0 + +@@e_signature: end; FMaxTextSize := Value; Change; @@ -9221,14 +7017,16 @@ end; procedure TKOLRichEdit.SetOptions(const Value: TKOLMemoOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetOptions', 0 + +@@e_signature: end; - if FOptions = Value then exit; + if FOptions = Value then + exit; FOptions := Value; - if Assigned(FKOLCtrl) then + if Assigned(FKOLCtrl) then RecreateWnd; Change; //dufa @@ -9237,14 +7035,16 @@ end; procedure TKOLRichEdit.SetRE_AutoFont(const Value: Boolean); begin - if FRE_AutoFont = Value then Exit; + if FRE_AutoFont = Value then + Exit; FRE_AutoFont := Value; Change; end; procedure TKOLRichEdit.SetRE_AutoFontSizeAdjust(const Value: Boolean); begin - if FRE_AutoFontSizeAdjust = Value then Exit; + if FRE_AutoFontSizeAdjust = Value then + Exit; FRE_AutoFontSizeAdjust := Value; Change; end; @@ -9252,10 +7052,11 @@ end; procedure TKOLRichEdit.SetRE_AutoKeybdSet(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetRE_AutoKeybdSet', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetRE_AutoKeybdSet', 0 + +@@e_signature: end; FRE_AutoKeybdSet := Value; Change; @@ -9264,10 +7065,11 @@ end; procedure TKOLRichEdit.SetRE_AutoKeyboard(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetRE_AutoKeyboard', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetRE_AutoKeyboard', 0 + +@@e_signature: end; FRE_AutoKeyboard := Value; Change; @@ -9276,10 +7078,11 @@ end; procedure TKOLRichEdit.SetRE_AutoURLDetect(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetRE_AutoURLDetect', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetRE_AutoURLDetect', 0 + +@@e_signature: end; FRE_AutoURLDetect := Value; Change; @@ -9288,10 +7091,11 @@ end; procedure TKOLRichEdit.SetRE_DisableOverwriteChange(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetRE_DisableOverwriteChange', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetRE_DisableOverwriteChange', 0 + +@@e_signature: end; FRE_DisableOverwriteChange := Value; Change; @@ -9299,7 +7103,8 @@ end; procedure TKOLRichEdit.SetRE_DualFont(const Value: Boolean); begin - if FRE_DualFont = Value then Exit; + if FRE_DualFont = Value then + Exit; FRE_DualFont := Value; Change; end; @@ -9307,10 +7112,11 @@ end; procedure TKOLRichEdit.SetRE_FmtStandard(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetRE_FmtStandard', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetRE_FmtStandard', 0 + +@@e_signature: end; FRE_FmtStandard := Value; Change; @@ -9318,14 +7124,16 @@ end; procedure TKOLRichEdit.SetRE_IMEAlwaysSendNotify(const Value: Boolean); begin - if FRE_IMEAlwaysSendNotify = Value then Exit; + if FRE_IMEAlwaysSendNotify = Value then + Exit; FRE_IMEAlwaysSendNotify := Value; Change; end; procedure TKOLRichEdit.SetRE_IMECancelComplete(const Value: Boolean); begin - if FRE_IMECancelComplete = Value then Exit; + if FRE_IMECancelComplete = Value then + Exit; FRE_IMECancelComplete := Value; Change; end; @@ -9333,10 +7141,11 @@ end; procedure TKOLRichEdit.SetRE_Transparent(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetRE_Transparent', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetRE_Transparent', 0 + +@@e_signature: end; FRE_Transparent := Value; Change; @@ -9344,20 +7153,23 @@ end; procedure TKOLRichEdit.SetRE_UIFonts(const Value: Boolean); begin - if FRE_UIFonts = Value then Exit; + if FRE_UIFonts = Value then + Exit; FRE_UIFonts := Value; end; procedure TKOLRichEdit.SetRE_ZoomDenominator(const Value: Integer); begin - if FRE_ZoomDenominator = Value then Exit; + if FRE_ZoomDenominator = Value then + Exit; FRE_ZoomDenominator := Value; Change; end; procedure TKOLRichEdit.SetRE_ZoomNumerator(const Value: Integer); begin - if FRE_ZoomNumerator = Value then Exit; + if FRE_ZoomNumerator = Value then + Exit; FRE_ZoomNumerator := Value; Change; end; @@ -9365,14 +7177,15 @@ end; procedure TKOLRichEdit.SetText(const Value: TStrings); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetText', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetText', 0 + +@@e_signature: end; FLines.Text := Value.Text; if Assigned(FKOLCtrl) then - FKOLCtrl.Text:=Value.Text; + FKOLCtrl.Text := Value.Text; Change; end; @@ -9381,166 +7194,76 @@ begin Result := FALSE; end; -procedure TKOLRichEdit.SetupConstruct_Compact; -var KF: TKOLForm; - O: TEditOptions; - b: PWord; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewRichEdit', TRUE, TRUE, '' ); - O := [eoMultiline]; - if eo_NoHScroll in Options then - O := O + [KOL.eoNoHScroll]; - if eo_NoVScroll in Options then - O := O + [KOL.eoNoVScroll]; - if eo_Lowercase in Options then - O := O + [KOL.eoLowercase]; - if eo_NoHideSel in Options then - O := O + [KOL.eoNoHideSel]; - if eo_OemConvert in Options then - O := O + [KOL.eoOemConvert]; - if eo_Password in Options then - O := O + [KOL.eoPassword]; - if eo_Readonly in Options then - O := O + [KOL.eoReadonly]; - if eo_UpperCase in Options then - O := O + [KOL.eoUpperCase]; - if eo_WantReturn in Options then - O := O + [KOL.eoWantReturn]; - if eo_WantTab in Options then - O := O + [KOL.eoWantTab]; - b := @ O; - KF.FormAddNumParameter( b^ ); -end; - -procedure TKOLRichEdit.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); +procedure TKOLRichEdit.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); const - BoolVal: array[ Boolean ] of String = ( 'FALSE', 'TRUE' ); -var KF: TKOLForm; + BoolVal: array[Boolean] of string = ('FALSE', 'TRUE'); +var + KF: TKOLForm; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetupFirst', 0 + +@@e_signature: end; inherited; KF := ParentKOLForm; - if RE_AutoURLDetect then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.RESetAutoURLDetect', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.RE_AutoURLDetect := TRUE;' ); + if RE_AutoURLDetect then + SL.Add(Prefix + AName + '.RE_AutoURLDetect := TRUE;'); - if not RE_AutoFont then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRE_AutoFontFalse', '' ); - end else - SL.Add( Prefix + AName + '.RE_AutoFont := FALSE;' ); + if not RE_AutoFont then + SL.Add(Prefix + AName + '.RE_AutoFont := FALSE;'); - if not RE_AutoFontSizeAdjust then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRE_AutoFontSizeAdjustFalse', '' ); - end else - SL.Add( Prefix + AName + '.RE_AutoFontSizeAdjust := FALSE;' ); + if not RE_AutoFontSizeAdjust then + SL.Add(Prefix + AName + '.RE_AutoFontSizeAdjust := FALSE;'); - if RE_DualFont then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRE_DualFontTrue', '' ); - end else - SL.Add( Prefix + AName + '.RE_DualFont := TRUE;' ); + if RE_DualFont then + SL.Add(Prefix + AName + '.RE_DualFont := TRUE;'); - if RE_UIFonts then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRE_UIFontsTrue', '' ); - end else - SL.Add( Prefix + AName + '.RE_UIFonts := TRUE;' ); + if RE_UIFonts then + SL.Add(Prefix + AName + '.RE_UIFonts := TRUE;'); - if RE_IMECancelComplete then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRE_IMECancelCompleteTrue', '' ); - end else - SL.Add( Prefix + AName + '.RE_IMECancelComplete := TRUE;' ); + if RE_IMECancelComplete then + SL.Add(Prefix + AName + '.RE_IMECancelComplete := TRUE;'); - if RE_IMEAlwaysSendNotify then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRE_IMEAlwaysSendNotifyTrue', '' ); - end else - SL.Add( Prefix + AName + '.RE_IMEAlwaysSendNotify := TRUE;' ); + if RE_IMEAlwaysSendNotify then + SL.Add(Prefix + AName + '.RE_IMEAlwaysSendNotify := TRUE;'); - if MaxTextSize <> 32767 then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetMaxTextSize', '' ); - KF.FormAddNumParameter( MaxTextSize ); - end else - if MaxTextSize > $7FFFffff then - SL.Add( Prefix + AName + '.MaxTextSize := $' + Int2Hex( MaxTextSize, 8 ) + ';' ) - else - SL.Add( Prefix + AName + '.MaxTextSize := ' + IntToStr( MaxTextSize ) + ';' ); + if MaxTextSize <> 32767 then + if MaxTextSize > $7FFFffff then + SL.Add(Prefix + AName + '.MaxTextSize := $' + Int2Hex(MaxTextSize, 8) + ';') + else + SL.Add(Prefix + AName + '.MaxTextSize := ' + IntToStr(MaxTextSize) + ';'); - if (FLines.Text <> '') and (KF <> nil) and KF.AssignTextToControls then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetCaption', '' ); - KF.FormAddStrParameter( FLines.Text ); - end else - AddLongTextField( SL, Prefix + AName + '.Text := ', FLines.Text, ';', ' + ' ); + if (FLines.Text <> '') and (KF <> nil) and KF.AssignTextToControls then begin + AddLongTextField(SL, Prefix + AName + '.Text := ', FLines.Text, ';', ' + '); end; - if RE_AutoKeybdSet then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRE_AutoKeyboardTrue', '' ); - end else - SL.Add( Prefix + AName + '.RE_AutoKeyboard := ' + BoolVal[ RE_AutoKeyboard ] + ';' ); + if RE_AutoKeybdSet then + SL.Add(Prefix + AName + '.RE_AutoKeyboard := ' + BoolVal[RE_AutoKeyboard] + ';'); - if RE_DisableOverwriteChange then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRE_DisableOverwriteChangeTrue', '' ); - end else - SL.Add( Prefix + AName + '.RE_DisableOverwriteChange := TRUE;' ); + if RE_DisableOverwriteChange then + SL.Add(Prefix + AName + '.RE_DisableOverwriteChange := TRUE;'); - if RE_Transparent then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.ReSetTransparent', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.RE_Transparent := TRUE;' ); + if RE_Transparent then + SL.Add(Prefix + AName + '.RE_Transparent := TRUE;'); - if (FRE_ZoomNumerator <> 0) and (FRE_ZoomDenominator <> 0) then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetRe_Zoom' , ''); - KF.FormAddNumParameter( FRE_ZoomNumerator ); - KF.FormAddNumParameter( FRE_ZoomDenominator ); - end else - SL.Add( Prefix + AName + '.RE_Zoom := MakeSmallPoint( ' + IntToStr( FRE_ZoomNumerator ) + - ', ' + IntToStr( FRE_ZoomDenominator ) + ' );' ); + if (FRE_ZoomNumerator <> 0) and (FRE_ZoomDenominator <> 0) then + SL.Add(Prefix + AName + '.RE_Zoom := MakeSmallPoint( ' + IntToStr(FRE_ZoomNumerator) + + ', ' + IntToStr(FRE_ZoomDenominator) + ' );'); end; -function TKOLRichEdit.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var S: String; +function TKOLRichEdit.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.SetupParams', 0 + +@@e_signature: end; S := 'eoMultiline'; if eo_NoHScroll in Options then @@ -9564,46 +7287,44 @@ begin if eo_WantTab in Options then S := S + ', eoWantTab'; if S <> '' then - if S[ 1 ] = ',' then - S := Copy( S, 3, MaxInt ); + if S[1] = ',' then + S := Copy(S, 3, MaxInt); Result := AParent + ', [ ' + S + ' ]'; end; procedure TKOLRichEdit.Setversion(const Value: TKOLRichEditVersion); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.Setversion', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.Setversion', 0 + +@@e_signature: end; Fversion := Value; Change; end; -function TKOLRichEdit.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - function TKOLRichEdit.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; -function TKOLRichEdit.TypeName: String; +function TKOLRichEdit.TypeName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.TypeName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.TypeName', 0 + +@@e_signature: end; Result := inherited TypeName; if version = ver1 then @@ -9612,18 +7333,19 @@ begin Result := 'OLERichEdit'; end; -procedure TKOLRichEdit.WantTabs( Want: Boolean ); +procedure TKOLRichEdit.WantTabs(Want: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLRichEdit.WantTabs', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLRichEdit.WantTabs', 0 + +@@e_signature: end; if Want then - Options := Options + [ eo_WantTab ] + Options := Options + [eo_WantTab] else - Options := Options - [ eo_WantTab ]; + Options := Options - [eo_WantTab]; end; function TKOLRichEdit.WYSIWIGPaintImplemented: Boolean; @@ -9636,14 +7358,17 @@ end; constructor TKOLProgressBar.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.Create', 0 + +@@e_signature: end; inherited; - Width := 300; DefaultWidth := Width; - Height := 20; DefaultHeight := Height; + Width := 300; + DefaultWidth := Width; + Height := 20; + DefaultHeight := Height; MaxProgress := 100; ProgressColor := clHighLight; ProgressBkColor := clBtnFace; @@ -9654,21 +7379,22 @@ var opts: kol.TProgressbarOptions; begin inherited; - opts:=[]; + opts := []; if Smooth then Include(opts, kol.pboSmooth); if Vertical then Include(opts, kol.pboVertical); - FKOLCtrl:=NewProgressbarEx(KOLParentCtrl, opts); + FKOLCtrl := NewProgressbarEx(KOLParentCtrl, opts); end; function TKOLProgressBar.GetColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.GetColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.GetColor', 0 + +@@e_signature: end; Result := inherited Color; end; @@ -9676,14 +7402,14 @@ end; procedure TKOLProgressBar.KOLControlRecreated; begin inherited; - FKOLCtrl.Progress:=Progress; - FKOLCtrl.MaxProgress:=MaxProgress; - FKOLCtrl.ProgressBkColor:=ProgressBkColor; + FKOLCtrl.Progress := Progress; + FKOLCtrl.MaxProgress := MaxProgress; + FKOLCtrl.ProgressBkColor := ProgressBkColor; end; function TKOLProgressBar.NoDrawFrame: Boolean; begin - Result:=True; + Result := True; end; procedure TKOLProgressBar.Paint; @@ -9695,74 +7421,14 @@ begin inherited; end; -function TKOLProgressBar.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLProgressBar.P_SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - TRY - if MaxProgress <> 100 then - //SL.Add( Prefix + AName + '.MaxProgress := ' + IntToStr( MaxProgress ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( MaxProgress ) + ')' + - ' L(' + IntToStr( ((PBM_SETRANGE32 or $8000) shl 16) or PBM_GETRANGE ) + ')' + - ' C2 TControl_.SetMaxProgress<3>' ); - if Progress <> 0 then - //SL.Add( Prefix + AName + '.Progress := ' + IntToStr( Progress ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( Progress ) + ') L($84020000)' + - ' C2 TControl_.SetIntVal<3>' ); - if ProgressColor <> clHighLight then - //SL.Add( Prefix + AName + '.ProgressColor := ' + Color2Str( ProgressColor ) + ';' ); - {P}SL.Add( ' L($' + IntToHex( ProgressColor, 6 ) + ')' + - ' C1 TControl_.SetProgressColor<2>' ); - EXCEPT on E: Exception do - begin - Rpt( 'exception in TKOLProgressBar.P_SetupFirst: ' + - E.message, RED ); - end; - END; -end; - -function TKOLProgressBar.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -var i: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.P_SetupParams', 0 - @@e_signature: - end; - TRY - nparams := 2; - i := 0; - if Vertical then i := 1; - if Smooth then i := i or 2; - {P}Result := ' L(' + IntToStr( i ) + ') C1 '; - EXCEPT on E: Exception do - begin - Rpt( 'exception in TKOLProgressBar.P_SetupParams: ' + - E.message, RED ); - end; - END; -end; - procedure TKOLProgressBar.SetColor(const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.SetColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.SetColor', 0 + +@@e_signature: end; inherited Color := Value; end; @@ -9770,18 +7436,20 @@ end; procedure TKOLProgressBar.SetMaxProgress(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.SetMaxProgress', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.SetMaxProgress', 0 + +@@e_signature: end; - if Value < 1 then Exit; + if Value < 1 then + Exit; FMaxProgress := Value; if Value < Progress then FProgress := Value; if Assigned(FKOLCtrl) then begin - FKOLCtrl.MaxProgress:=FMaxProgress; - FKOLCtrl.Progress:=FProgress; + FKOLCtrl.MaxProgress := FMaxProgress; + FKOLCtrl.Progress := FProgress; end; Change; end; @@ -9789,18 +7457,20 @@ end; procedure TKOLProgressBar.SetProgress(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.SetProgress', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.SetProgress', 0 + +@@e_signature: end; - if Value < 0 then Exit; + if Value < 0 then + Exit; FProgress := Value; if Value > MaxProgress then FMaxProgress := Value; if Assigned(FKOLCtrl) then begin - FKOLCtrl.MaxProgress:=FMaxProgress; - FKOLCtrl.Progress:=FProgress; + FKOLCtrl.MaxProgress := FMaxProgress; + FKOLCtrl.Progress := FProgress; end; Change; end; @@ -9808,24 +7478,26 @@ end; procedure TKOLProgressBar.SetProgressColor(const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.SetProgressColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.SetProgressColor', 0 + +@@e_signature: end; FProgressColor := Value; if Assigned(FKOLCtrl) then - FKOLCtrl.ProgressColor:=Value; + FKOLCtrl.ProgressColor := Value; Change; end; procedure TKOLProgressBar.SetSmooth(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.SetSmooth', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.SetSmooth', 0 + +@@e_signature: end; FSmooth := Value; if Assigned(FKOLCtrl) then @@ -9833,77 +7505,48 @@ begin Change; end; -procedure TKOLProgressBar.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - if Smooth or Vertical then - begin - KF.FormAddAlphabet( 'FormNewProgressBarEx', TRUE, TRUE, '' ); - KF.FormAddNumParameter( Integer(Smooth) or Integer(Vertical) shl 1 ); - end else - KF.FormAddAlphabet( 'FormNewProgressBar', TRUE, TRUE, '' ); -end; - -procedure TKOLProgressBar.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLProgressBar.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if MaxProgress <> 100 then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetMaxProgress', '' ); - KF.FormAddNumParameter( MaxProgress ); - end else - SL.Add( Prefix + AName + '.MaxProgress := ' + IntToStr( MaxProgress ) + ';' ); - if Progress <> 0 then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetProgress', '' ); - KF.FormAddNumParameter( Progress ); - end else - SL.Add( Prefix + AName + '.Progress := ' + IntToStr( Progress ) + ';' ); + if MaxProgress <> 100 then + SL.Add(Prefix + AName + '.MaxProgress := ' + IntToStr(MaxProgress) + ';'); - if ProgressColor <> clHighLight then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetProgressColor', '' ); - KF.FormAddNumParameter( (ProgressColor shl 1) or (ProgressColor shr 31) ); - end else - SL.Add( Prefix + AName + '.ProgressColor := ' + Color2Str( ProgressColor ) + ';' ); + if Progress <> 0 then + SL.Add(Prefix + AName + '.Progress := ' + IntToStr(Progress) + ';'); + + if ProgressColor <> clHighLight then + SL.Add(Prefix + AName + '.ProgressColor := ' + Color2Str(ProgressColor) + ';'); end; -function TKOLProgressBar.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var S: String; +function TKOLProgressBar.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.SetupParams', 0 + +@@e_signature: end; Result := AParent; - if Smooth or Vertical then - begin + if Smooth or Vertical then begin S := ''; if Smooth then S := 'pboSmooth'; if Vertical then S := S + ', pboVertical'; if S <> '' then - if S[ 1 ] = ',' then - S := Copy( S, 3, MaxInt ); + if S[1] = ',' then + S := Copy(S, 3, MaxInt); Result := Result + ', [ ' + S + ' ]'; end; end; @@ -9911,10 +7554,11 @@ end; procedure TKOLProgressBar.SetVertical(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.SetVertical', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.SetVertical', 0 + +@@e_signature: end; FVertical := Value; if Assigned(FKOLCtrl) then @@ -9922,18 +7566,14 @@ begin Change; end; -function TKOLProgressBar.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - -function TKOLProgressBar.TypeName: String; +function TKOLProgressBar.TypeName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLProgressBar.TypeName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLProgressBar.TypeName', 0 + +@@e_signature: end; Result := inherited TypeName; if Smooth or Vertical then @@ -9948,77 +7588,78 @@ end; { TKOLTabControl } procedure TKOLTabControl.AdjustPages; -var R: TRect; - Dx, Dy: Integer; - I: Integer; +var + R: TRect; + Dx, Dy: Integer; + I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.AdjustPages', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.AdjustPages', 0 + +@@e_signature: end; if Parent = nil then Exit; R := ClientRect; - Inc( R.Left, 4 ); - Inc( R.Top, 4 ); - Dec( R.Right, 4 ); - Dec( R.Bottom, 4 ); + Inc(R.Left, 4); + Inc(R.Top, 4); + Dec(R.Right, 4); + Dec(R.Bottom, 4); Dx := 0; Dy := 22; - if tcoVertical in Options then - begin + if tcoVertical in Options then begin Dx := 22; Dy := 0; end; - if tcoBottom in Options then - begin - Dec( R.Right, Dx ); - Dec( R.Bottom, Dy ); + if tcoBottom in Options then begin + Dec(R.Right, Dx); + Dec(R.Bottom, Dy); end - else - begin - Inc( R.Left, Dx ); - Inc( R.Top, Dy ); + else begin + Inc(R.Left, Dx); + Inc(R.Top, Dy); end; FAdjustingPages := TRUE; - for I := 0 to Count-1 do - begin - Pages[ I ].FOnSetBounds := AttemptToChangePageBounds; - Pages[ I ].BoundsRect := R; + for I := 0 to Count - 1 do begin + Pages[I].FOnSetBounds := AttemptToChangePageBounds; + Pages[I].BoundsRect := R; end; FAdjustingPages := FALSE; end; -procedure TKOLTabControl.AttemptToChangePageBounds(Sender: TObject; - var NewBounds: TRect); +procedure TKOLTabControl.AttemptToChangePageBounds(Sender: TObject; var NewBounds: TRect); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.AttemptToChangePageBounds', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.AttemptToChangePageBounds', 0 + +@@e_signature: end; - if FAdjustingPages then Exit; - if Count > 0 then - begin + if FAdjustingPages then + Exit; + if Count > 0 then begin AdjustPages; - NewBounds := Pages[ 0 ].BoundsRect; + NewBounds := Pages[0].BoundsRect; end; end; constructor TKOLTabControl.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.Create', 0 + +@@e_signature: end; inherited; - Width := 100; DefaultWidth := Width; - Height := 100; DefaultHeight := Height; + Width := 100; + DefaultWidth := Width; + Height := 100; + DefaultHeight := Height; FTabs := TList.Create; FedgeType := esNone; FgenerateConstants := TRUE; @@ -10044,207 +7685,225 @@ begin end;} destructor TKOLTabControl.Destroy; -var I: Integer; +var + I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.Destroy', 0 + +@@e_signature: end; fDestroyingTabControl := TRUE; - for I := FTabs.Count-1 downto 0 do - FreeMem( FTabs[ I ] ); + for I := FTabs.Count - 1 downto 0 do + FreeMem(FTabs[I]); FTabs.Free; inherited; end; -function CompareTabPages( L: TList; e1, e2: DWORD ): Integer; -var P1, P2: TKOLPanel; +function CompareTabPages(L: TList; e1, e2: DWORD): Integer; +var + P1, P2: TKOLPanel; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'CompareTabPages', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'CompareTabPages', 0 + +@@e_signature: end; - P1 := L[ e1 ]; - P2 := L[ e2 ]; - if P1.TabOrder < P2.TabOrder then Result := -1 + P1 := L[e1]; + P2 := L[e2]; + if P1.TabOrder < P2.TabOrder then + Result := -1 + else if P1.TabOrder > P2.TabOrder then + Result := 1 else - if P1.TabOrder > P2.TabOrder then Result := 1 - else - Result := 0; + Result := 0; end; -procedure SwapTabPages( L: TList; e1, e2: DWORD ); -var P: Pointer; +procedure SwapTabPages(L: TList; e1, e2: DWORD); +var + P: Pointer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'SwapTabPages', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'SwapTabPages', 0 + +@@e_signature: end; - P := L[ e1 ]; - L[ e1 ] := L[ e2 ]; - L[ e2 ] := P; + P := L[e1]; + L[e1] := L[e2]; + L[e2] := P; end; procedure TKOLTabControl.DoGenerateConstants(SL: TStringList); -var I: Integer; - C: TComponent; - K: TKOLPanel; - Pages: TList; - F: TForm; +var + I: Integer; + C: TComponent; + K: TKOLPanel; + Pages: TList; + F: TForm; begin - if not generateConstants then Exit; - if Owner = nil then Exit; - if not( Owner is TForm ) then Exit; + if not generateConstants then + Exit; + if Owner = nil then + Exit; + if not (Owner is TForm) then + Exit; F := Owner as TForm; Pages := TList.Create; - TRY - for I := 0 to F.ComponentCount-1 do - begin - C := F.Components[ I ]; - if not ( C is TKOLPanel ) then CONTINUE; + try + for I := 0 to F.ComponentCount - 1 do begin + C := F.Components[I]; + if not (C is TKOLPanel) then + CONTINUE; K := C as TKOLPanel; - if K.Parent <> Self then CONTINUE; - Pages.Add( K ); + if K.Parent <> Self then + CONTINUE; + Pages.Add(K); end; - SortData( Pages, Pages.Count, @ CompareTabPages, @ SwapTabPages ); - for I := 0 to Pages.Count-1 do - begin - K := Pages[ I ]; - SL.Add( 'const _' + K.Name + ' = ' + IntToStr( I ) + ';' ); + SortData(Pages, Pages.Count, @CompareTabPages, @SwapTabPages); + for I := 0 to Pages.Count - 1 do begin + K := Pages[I]; + SL.Add('const _' + K.Name + ' = ' + IntToStr(I) + ';'); end; - FINALLY + finally Pages.Free; - END; + end; end; function TKOLTabControl.GetCount: Integer; -var I: Integer; - C: TComponent; - K: TKOLPanel; - F: TForm; +var + I: Integer; + C: TComponent; + K: TKOLPanel; + F: TForm; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.GetCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.GetCount', 0 + +@@e_signature: end; Result := 0; - if Owner = nil then Exit; - if not( Owner is TForm ) then Exit; + if Owner = nil then + Exit; + if not (Owner is TForm) then + Exit; F := Owner as TForm; - for I := 0 to F.ComponentCount-1 do - begin - C := F.Components[ I ]; - if not ( C is TKOLPanel ) then CONTINUE; + for I := 0 to F.ComponentCount - 1 do begin + C := F.Components[I]; + if not (C is TKOLPanel) then + CONTINUE; K := C as TKOLPanel; - if K.Parent <> Self then CONTINUE; - Inc( Result ); + if K.Parent <> Self then + CONTINUE; + Inc(Result); end; end; function TKOLTabControl.GetCurIndex: Integer; -var I: Integer; - CurPage: TKOLPanel; +var + I: Integer; + CurPage: TKOLPanel; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.GetCurIndex', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.GetCurIndex', 0 + +@@e_signature: end; Result := -1; CurPage := GetCurrentPage; - if CurPage = nil then Exit; - for I := 0 to Count-1 do - if CurPage = Pages[ I ] then - begin + if CurPage = nil then + Exit; + for I := 0 to Count - 1 do + if CurPage = Pages[I] then begin Result := I; break; end; end; function TKOLTabControl.GetCurrentPage: TKOLPanel; -var W: HWnd; - C: TWinControl; +var + W: HWnd; + C: TWinControl; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.GetCurrentPage', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.GetCurrentPage', 0 + +@@e_signature: end; Result := FCurPage; - if Result = nil then - begin - W := GetWindow( Handle, GW_CHILD ); - if W = 0 then Exit; - C := FindControl( W ); - if C is TKOLPanel then - begin + if Result = nil then begin + W := GetWindow(Handle, GW_CHILD); + if W = 0 then + Exit; + C := FindControl(W); + if C is TKOLPanel then begin Result := C as TKOLPanel; - FCurPage:=Result; + FCurPage := Result; end; end; end; function TKOLTabControl.GetPages(Idx: Integer): TKOLPanel; -var I: Integer; - C: TComponent; - K: TKOLPanel; - F: TForm; - L: TList; +var + I: Integer; + C: TComponent; + K: TKOLPanel; + F: TForm; + L: TList; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.GetPages', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.GetPages', 0 + +@@e_signature: end; Result := nil; L := TList.Create; try - if Owner = nil then Exit; - if not( Owner is TForm ) then Exit; + if Owner = nil then + Exit; + if not (Owner is TForm) then + Exit; F := Owner as TForm; - for I := 0 to F.ComponentCount-1 do - begin - C := F.Components[ I ]; - if {not ( C is TKOLTabPage ) and} not ( C is TKOLPanel ) then CONTINUE; + for I := 0 to F.ComponentCount - 1 do begin + C := F.Components[I]; + if {not ( C is TKOLTabPage ) and} not (C is TKOLPanel) then + CONTINUE; K := C as TKOLPanel; - if K.Parent <> Self then CONTINUE; - L.Add( K ); + if K.Parent <> Self then + CONTINUE; + L.Add(K); end; - SortData( L, L.Count, @CompareTabPages, @SwapTabPages ); - Result := L.Items[ Idx ]; + SortData(L, L.Count, @CompareTabPages, @SwapTabPages); + Result := L.Items[Idx]; finally L.Free; end; end; -function TKOLTabControl.HasCompactConstructor: Boolean; +function TKOLTabControl.IndexOfPage(const page_name: string): Integer; +var + i: Integer; begin - Result := TRUE; -end; - -function TKOLTabControl.IndexOfPage(const page_name: String): Integer; -var i: Integer; -begin - for i := 0 to Count-1 do - begin - if Pages[i].Name = page_name then - begin - Result := i; - Exit; - end; + for i := 0 to Count - 1 do begin + if Pages[i].Name = page_name then begin + Result := i; + Exit; end; - Result := -1; + end; + Result := -1; end; {procedure TKOLTabControl.Loaded; @@ -10254,121 +7913,114 @@ begin end;} procedure TKOLTabControl.Loaded; -var i, j: Integer; - P: TKOLPanel; - P2: TKOLTabPage; - n: String; - L0, L, L2: TList; - C: TControl; +var + i, j: Integer; + P: TKOLPanel; + P2: TKOLTabPage; + n: string; + L0, L, L2: TList; + C: TControl; begin inherited; L := TList.Create; L0 := TList.Create; //{}ShowMessage( 'KOLTabPage ' + Name + ' loaded!' ); - TRY - for i := 0 to Count-1 do - begin - if Pages[i] is TKOLPanel then - L0.Add( Pages[i] ); - end; - for i := 0 to L0.Count-1 do - begin - P := TKOLPanel( L0[i] ); - if (P is TKOLPanel) and not(P is TKOLTabPage) then - begin + try + for i := 0 to Count - 1 do begin + if Pages[i] is TKOLPanel then + L0.Add(Pages[i]); + end; + for i := 0 to L0.Count - 1 do begin + P := TKOLPanel(L0[i]); + if (P is TKOLPanel) and not (P is TKOLTabPage) then begin //{}ShowMessage( 'Page ' + IntToStr( i ) + ' will be converted to TKOLTabPage' ); - P2 := TKOLTabPage.Create( P.Owner ); - P2.Parent := Self; + P2 := TKOLTabPage.Create(P.Owner); + P2.Parent := Self; //{}ShowMessage( 'Page ' + IntToStr( i ) + ' is converting to TKOLTabPage (1) - P2 created ' ); - n := P.Name; - P.Name := ''; - P2.Name := n; /////////////////////////////////////// + n := P.Name; + P.Name := ''; + P2.Name := n; /////////////////////////////////////// //{}ShowMessage( 'Page ' + IntToStr( i ) + ' is converting to TKOLTabPage (2) - name assigned' ); - P2.BoundsRect := P.BoundsRect; ////////////////////// - P2.TabOrder := P.TabOrder; ////////////////////////// + P2.BoundsRect := P.BoundsRect; ////////////////////// + P2.TabOrder := P.TabOrder; ////////////////////////// //{}ShowMessage( 'Page ' + IntToStr( i ) + ' is converting to TKOLTabPage (3) - TabOrder assigned' ); - P2.Align := P.Align; //////////////////////////////// - P2.Tag := P.Tag; //////////////////////////////////// - P2.IgnoreDefault := P.IgnoreDefault; - P2.AnchorLeft := P.AnchorLeft; - P2.AnchorTop := P.AnchorTop; - P2.AnchorRight := P.AnchorTop; - P2.AnchorBottom := P.AnchorBottom; - P2.AcceptChildren := TRUE; - P2.MouseTransparent := P.MouseTransparent; - P2.MinWidth := P.MinWidth; - P2.MinHeight := P.MinHeight; - P2.MaxWidth := P.MaxWidth; - P2.MaxHeight := P.MaxHeight; - P2.Visible := P.Visible; - P2.Enabled := P.Enabled; - P2.DoubleBuffered := P.DoubleBuffered; - P2.CenterOnParent := P.CenterOnParent; + P2.Align := P.Align; //////////////////////////////// + P2.Tag := P.Tag; //////////////////////////////////// + P2.IgnoreDefault := P.IgnoreDefault; + P2.AnchorLeft := P.AnchorLeft; + P2.AnchorTop := P.AnchorTop; + P2.AnchorRight := P.AnchorTop; + P2.AnchorBottom := P.AnchorBottom; + P2.AcceptChildren := TRUE; + P2.MouseTransparent := P.MouseTransparent; + P2.MinWidth := P.MinWidth; + P2.MinHeight := P.MinHeight; + P2.MaxWidth := P.MaxWidth; + P2.MaxHeight := P.MaxHeight; + P2.Visible := P.Visible; + P2.Enabled := P.Enabled; + P2.DoubleBuffered := P.DoubleBuffered; + P2.CenterOnParent := P.CenterOnParent; //{}ShowMessage( 'Page ' + IntToStr( i ) + ' is converting to TKOLTabPage (4) - something assigned' ); - P2.Caption := P.Caption; //////////////////////////// + P2.Caption := P.Caption; //////////////////////////// //{}ShowMessage( 'Page ' + IntToStr( i ) + ' is converting to TKOLTabPage (5) - Caption assigned' ); - P2.Ctl3D := P.Ctl3D; //////////////////////////////// - P2.Color := P.Color; //////////////////////////////// - P2.parentColor := P.parentColor; //////////////////// - P2.Font.Assign( P.Font ); - P2.parentFont := P.parentFont; - P2.EraseBackground := P.EraseBackground; - P2.Localizy := P.Localizy; - P2.Transparent := P.Transparent; - P2.TextAlign := P.TextAlign; - P2.edgeStyle := P.edgeStyle; - P2.VerticalAlign := P.VerticalAlign; - P2.Border := P.Border; - P2.MarginTop := P.MarginTop; - P2.MarginBottom := P.MarginBottom; - P2.MarginLeft := P.MarginLeft; - P2.MarginRight := P.MarginRight; - P2.Brush.Assign( P.Brush ); - P2.ShowAccelChar := P.ShowAccelChar; + P2.Ctl3D := P.Ctl3D; //////////////////////////////// + P2.Color := P.Color; //////////////////////////////// + P2.parentColor := P.parentColor; //////////////////// + P2.Font.Assign(P.Font); + P2.parentFont := P.parentFont; + P2.EraseBackground := P.EraseBackground; + P2.Localizy := P.Localizy; + P2.Transparent := P.Transparent; + P2.TextAlign := P.TextAlign; + P2.edgeStyle := P.edgeStyle; + P2.VerticalAlign := P.VerticalAlign; + P2.Border := P.Border; + P2.MarginTop := P.MarginTop; + P2.MarginBottom := P.MarginBottom; + P2.MarginLeft := P.MarginLeft; + P2.MarginRight := P.MarginRight; + P2.Brush.Assign(P.Brush); + P2.ShowAccelChar := P.ShowAccelChar; //{}ShowMessage( 'Page ' + IntToStr( i ) + ' is converting to TKOLTabPage (6) - more props assigned' ); - L2 := TList.Create; - TRY - for j := 0 to P.ControlCount-1 do - begin - C := P.Controls[j]; - L2.Add( C ); - end; - for j := 0 to L2.Count-1 do - begin - C := TControl( L2[j] ); - C.Parent := P2; - end; - FINALLY - L2.Free; - END; - //{}ShowMessage( 'Page ' + IntToStr( i ) + ' was converted to TKOLTabPage' ); - L.Add( P ); + L2 := TList.Create; + try + for j := 0 to P.ControlCount - 1 do begin + C := P.Controls[j]; + L2.Add(C); end; + for j := 0 to L2.Count - 1 do begin + C := TControl(L2[j]); + C.Parent := P2; + end; + finally + L2.Free; + end; + //{}ShowMessage( 'Page ' + IntToStr( i ) + ' was converted to TKOLTabPage' ); + L.Add(P); end; - if L.Count > 0 then - ShowMessage( 'Please note that TKOLTabControl component ' + Name + - ' was created in elder version of MCK so its pages (' + IntToStr( L.Count ) + - ') was converted from TKOLPanel to TKOLTabPage.' + #13#10#13#10 + - 'To finish converting it remove empty duplicated pages manually ' + - '(select it clicking by mouse and delete pressing DELETE key, to ' + - 'switch pages use double click on tabs as usual). Then' + - ' save the form (Ctrl+S) and' + - ' answer Yes to a request' + - ' for correcting tabs declaration (this should be safe). ' + - 'Such question will be answered for each tab in the Tab control.' + - #13#10#13#10 + - '----- translation to Russian -----'#13#10#13#10 + - 'Обратите внимание, что компонент ' + Name + ' класса TKOLTabControl ' + - 'был создан в ранних версиях MCK и его страницы отконвертированы ' + - 'из класса TKOLPanel в TKOLTabPage.' + #13#10#13#10 + - 'Для завершения конвертирования вручную удалите с табулированного контрола ' + - 'лишние пустые страницы (выделяя их кликом мыши и нажимая DELETE, для ' + - 'переключения страниц мспользуйте двойной клик по закладке как обычно). ' + - 'Затем сохраните форму ' + - '(Ctrl+S) и ответьте Yes на запрос с заголовком Error и с текстом вида '#13#10 + - '"Field Form1.TabControl1_Tab0 should be of type TKOLTabPage but it is ' + - 'declared as TKOLPanel. Correct the declaration?". Такой вопрос будет задан ' + - 'для каждой страницы табулированного контрола отдельно.' ); + end; + if L.Count > 0 then + ShowMessage('Please note that TKOLTabControl component ' + Name + + ' was created in elder version of MCK so its pages (' + IntToStr(L.Count) + + ') was converted from TKOLPanel to TKOLTabPage.' + #13#10#13#10 + + 'To finish converting it remove empty duplicated pages manually ' + + '(select it clicking by mouse and delete pressing DELETE key, to ' + + 'switch pages use double click on tabs as usual). Then' + + ' save the form (Ctrl+S) and' + ' answer Yes to a request' + + ' for correcting tabs declaration (this should be safe). ' + + 'Such question will be answered for each tab in the Tab control.' + + #13#10#13#10 + '----- translation to Russian -----'#13#10#13#10 + + 'Обратите внимание, что компонент ' + Name + ' класса TKOLTabControl ' + + 'был создан в ранних версиях MCK и его страницы отконвертированы ' + + 'из класса TKOLPanel в TKOLTabPage.' + #13#10#13#10 + + 'Для завершения конвертирования вручную удалите с табулированного контрола ' + + 'лишние пустые страницы (выделяя их кликом мыши и нажимая DELETE, для ' + + 'переключения страниц мспользуйте двойной клик по закладке как обычно). ' + + 'Затем сохраните форму ' + '(Ctrl+S) и ответьте Yes на запрос с заголовком Error и с текстом вида '#13#10 + + '"Field Form1.TabControl1_Tab0 should be of type TKOLTabPage but it is ' + + 'declared as TKOLPanel. Correct the declaration?". Такой вопрос будет задан ' + + 'для каждой страницы табулированного контрола отдельно.'); (*for j := 0 to L0.Count-1 do begin P := TKOLPanel( L[j] ); @@ -10381,10 +8033,10 @@ begin //{}ShowMessage( 'Old Page ' + IntToStr( j ) + ' freed' ); end; end;*) - FINALLY - L.Free; - L0.Free; - END; + finally + L.Free; + L0.Free; + end; end; function TKOLTabControl.NoDrawFrame: Boolean; @@ -10396,428 +8048,292 @@ procedure TKOLTabControl.Paint; var R, CurR: TRect; I, Tw, Sx, Sy, W, H: Integer; - S : String; + S: string; CurPage: TKOLPanel; M: PRect; - DirXX_YY,DirXY_YX:SmallInt; + DirXX_YY, DirXY_YX: SmallInt; O_V, O_B, O_BTN, O_F, O_BRD: Boolean; - P:TPoint; + P: TPoint; Col: array[0..3] of TColor; Fnt: HFont; - procedure _MoveTo(const x,y:integer); - begin - p.x:=x; - p.y:=y; - canvas.moveto(x,y); - end; + procedure _MoveTo(const x, y: integer); + begin + P.x := x; + P.y := y; + Canvas.moveto(x, y); + end; - procedure MoveRel(const dx,dy:integer); - begin - p.x:=p.x+dirxx_yy*dx+dirxy_yx*dy; - p.y:=p.y+dirxx_yy*dy+dirxy_yx*dx; - canvas.moveto(p.x,p.y); - end; + procedure MoveRel(const dx, dy: integer); + begin + P.x := P.x + DirXX_YY * dx + DirXY_YX * dy; + P.y := P.y + DirXX_YY * dy + DirXY_YX * dx; + Canvas.moveto(P.x, P.y); + end; - procedure LineRel(const dx,dy:integer); - begin - p.x:=p.x+dirxx_yy*dx+dirxy_yx*dy; - p.y:=p.y+dirxx_yy*dy+dirxy_yx*dx; - canvas.lineto(p.x,p.y); - end; + procedure LineRel(const dx, dy: integer); + begin + P.x := P.x + DirXX_YY * dx + DirXY_YX * dy; + P.y := P.y + DirXX_YY * dy + DirXY_YX * dx; + Canvas.lineto(P.x, P.y); + end; - procedure prepare(const r:trect); - begin - if o_v xor o_b then - begin - sy:=r.top; - sx:=r.right; - end else - begin - sy:=r.bottom; - sx:=r.left; - end; - if o_v then - begin - h:=r.right-r.left; - w:=r.bottom-r.top; - end else - begin - w:=r.right-r.left; - h:=r.bottom-r.top; - end; - if o_b then - begin - dec(sx); - dec(sy); - end; - dec(h,2); - end; + procedure prepare(const r: trect); + begin + if O_V xor O_B then begin + Sy := r.top; + Sx := r.right; + end + else begin + Sy := r.bottom; + Sx := r.left; + end; + if O_V then begin + H := r.right - r.left; + W := r.bottom - r.top; + end + else begin + W := r.right - r.left; + H := r.bottom - r.top; + end; + if O_B then begin + dec(Sx); + dec(Sy); + end; + dec(H, 2); + end; - procedure DrawTab(r:trect; const cur:boolean); - begin - inflaterect(r,2,2); - if o_btn then - begin - if not cur and o_f - then drawedge(canvas.handle,r,BDR_RAISEDOUTER,BF_RECT or BF_SOFT) - else drawedge(canvas.handle,r,EDGE_RAISED*succ(ord(cur)),BF_RECT or BF_SOFT); - if cur then - begin - inflaterect(r,-2,-2); - drawcaption(findwindow('Shell_TrayWnd',nil),canvas.handle,r, - DC_TEXT or DC_ACTIVE or DC_INBUTTON); - end; - end else - begin - if cur then - begin - inflaterect(r,2,2); - if o_b - then if o_v then inc(r.left,2) else inc(r.top,2) - else if o_v then dec(r.right,2) else dec(r.bottom,2); - end; - prepare(r); - with canvas,r do - begin - if cur then - begin - _moveto(sx,sy); - moverel(0,-2); - pen.color:=clbtnface; - linerel(w-3,0); - linerel(0,1); - linerel(4-w,0); - end; - _moveto(sx,sy); - moverel(0,-2); - pen.color:=col[0]; - linerel(0,2-h); - linerel(2,-2); - linerel(w-4,0); - moverel(0,1); - pen.color:=col[1]; - linerel(1,1); - linerel(0,h-1); - _moveto(sx,sy); - moverel(1,-2); - pen.color:=col[2]; - linerel(0,2-h); - linerel(1,-1); - linerel(w-4,0); - moverel(0,1); - pen.color:=col[3]; - linerel(0,h-1); - end; - end; - end; + procedure DrawTab(r: trect; const cur: boolean); + begin + inflaterect(r, 2, 2); + if O_BTN then begin + if not cur and O_F then + drawedge(Canvas.handle, r, BDR_RAISEDOUTER, BF_RECT or BF_SOFT) + else + drawedge(Canvas.handle, r, EDGE_RAISED * succ(ord(cur)), BF_RECT or BF_SOFT); + if cur then begin + inflaterect(r, -2, -2); + drawcaption(findwindow('Shell_TrayWnd', nil), Canvas.handle, r, DC_TEXT or DC_ACTIVE or DC_INBUTTON); + end; + end + else begin + if cur then begin + inflaterect(r, 2, 2); + if O_B then + if O_V then + inc(r.left, 2) + else + inc(r.top, 2) + else if O_V then + dec(r.right, 2) + else + dec(r.bottom, 2); + end; + prepare(r); + with Canvas, r do begin + if cur then begin + _moveto(Sx, Sy); + moverel(0, -2); + pen.color := clbtnface; + linerel(W - 3, 0); + linerel(0, 1); + linerel(4 - W, 0); + end; + _moveto(Sx, Sy); + moverel(0, -2); + pen.color := Col[0]; + linerel(0, 2 - H); + linerel(2, -2); + linerel(W - 4, 0); + moverel(0, 1); + pen.color := Col[1]; + linerel(1, 1); + linerel(0, H - 1); + _moveto(Sx, Sy); + moverel(1, -2); + pen.color := Col[2]; + linerel(0, 2 - H); + linerel(1, -1); + linerel(W - 4, 0); + moverel(0, 1); + pen.color := Col[3]; + linerel(0, H - 1); + end; + end; + end; - procedure preparefont; - var - a:integer; - begin - a:=900*pred(ord(not o_b) shl 1); - fnt:=createfont(10,0,a,a,0,0,0,0,DEFAULT_CHARSET,OUT_DEFAULT_PRECIS, - CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,VARIABLE_PITCH,'MS Serif'); - end; + procedure preparefont; + var + a: integer; + begin + a := 900 * pred(ord(not O_B) shl 1); + Fnt := createfont(10, 0, a, a, 0, 0, 0, 0, DEFAULT_CHARSET, + OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, VARIABLE_PITCH, 'MS Serif'); + end; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.Paint', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.Paint', 0 + +@@e_signature: end; - if PaintType = ptSchematic then - begin + if PaintType = ptSchematic then begin SchematicPaint; Exit; end; - o_b:=tcobottom in options; - o_v:=tcovertical in options; - o_btn:=tcobuttons in options; - o_f:=tcoflat in options; - o_brd:=tcoBorder in options; - r:=clientrect; - if o_brd then - begin - drawedge(canvas.handle,r,EDGE_SUNKEN,BF_RECT); - inflaterect(r,-2,-2); + O_B := tcobottom in Options; + O_V := tcovertical in Options; + O_BTN := tcobuttons in Options; + O_F := tcoflat in Options; + O_BRD := tcoBorder in Options; + R := clientrect; + if O_BRD then begin + drawedge(Canvas.handle, R, EDGE_SUNKEN, BF_RECT); + inflaterect(R, -2, -2); end; - inflaterect(r,-4,-4); - if o_b - then if o_v then r.left:=r.right-17 else r.top:=r.bottom-17 - else if o_v then r.right:=r.left+17 else r.bottom:=r.top+17; - dirxx_yy:=ord(not o_v)*pred(ord(not o_b) shl 1); - dirxy_yx:=ord(o_v)*pred(ord(not o_b) shl 1); - col[0 xor ord(o_b)]:=clbtnhighlight; - col[1 xor ord(o_b)]:=cl3ddkshadow; - col[2 xor ord(o_b)]:=cl3dlight; - col[3 xor ord(o_b)]:=clbtnshadow; - if not o_v then PrepareCanvasFontForWYSIWIGPaint(canvas) else - begin + inflaterect(R, -4, -4); + if O_B then + if O_V then + R.left := R.right - 17 + else + R.top := R.bottom - 17 + else if O_V then + R.right := R.left + 17 + else + R.bottom := R.top + 17; + DirXX_YY := ord(not O_V) * pred(ord(not O_B) shl 1); + DirXY_YX := ord(O_V) * pred(ord(not O_B) shl 1); + Col[0 xor ord(O_B)] := clbtnhighlight; + Col[1 xor ord(O_B)] := cl3ddkshadow; + Col[2 xor ord(O_B)] := cl3dlight; + Col[3 xor ord(O_B)] := clbtnshadow; + if not O_V then + PrepareCanvasFontForWYSIWIGPaint(Canvas) + else begin preparefont; - selectobject(canvas.handle,fnt); + selectobject(Canvas.handle, Fnt); end; - curpage:=getcurrentpage; - for i:=0 to pred(ftabs.count) do freemem(ftabs[i]); + CurPage := getcurrentpage; + for I := 0 to pred(ftabs.count) do + freemem(ftabs[I]); ftabs.clear; - setbkmode(canvas.handle,windows.TRANSPARENT); - for i:=0 to pred(count) do - begin - getmem(m,sizeof(trect)); - s:=pages[i].caption; - tw:=canvas.textwidth(s); - if o_v then r.bottom:=r.top+tw+8 else r.right:=r.left+tw+8; - m^:=r; - ftabs.add(m); - if curpage=pages[i] then curr:=r else - begin - drawtab(r,false); - drawtext(canvas.handle,pchar(s),length(s),r,DT_CENTER or DT_VCENTER or DT_SINGLELINE); + setbkmode(Canvas.handle, windows.TRANSPARENT); + for I := 0 to pred(count) do begin + getmem(M, sizeof(trect)); + S := Pages[I].caption; + Tw := Canvas.textwidth(S); + if O_V then + R.bottom := R.top + Tw + 8 + else + R.right := R.left + Tw + 8; + M^ := R; + ftabs.add(M); + if CurPage = Pages[I] then + CurR := R + else begin + drawtab(R, false); + drawtext(Canvas.handle, pchar(S), length(S), R, DT_CENTER or DT_VCENTER or DT_SINGLELINE); end; - pages[i].fonsetbounds:=attempttochangepagebounds; - if o_v then r.top:=r.bottom+4 else r.left:=r.right+4; - if o_btn then - if o_v then inc(r.top,2) else inc(r.left,2); + Pages[I].fonsetbounds := attempttochangepagebounds; + if O_V then + R.top := R.bottom + 4 + else + R.left := R.right + 4; + if O_BTN then + if O_V then + inc(R.top, 2) + else + inc(R.left, 2); end; - r:=clientrect; - if o_brd then inflaterect(r,-2,-2); - if o_b - then if o_v then r.right:=r.right-21 else r.bottom:=r.bottom-21 - else if o_v then r.left:=r.left+21 else r.top:=r.top+21; - if not o_btn then drawedge(canvas.handle,r,EDGE_RAISED,BF_RECT or BF_SOFT); - if curpage<>nil then - begin - drawtab(curr,true); - s:=curpage.caption; - if o_btn then offsetrect(curr,2,2) else offsetrect(curr,-2*dirxy_yx,-2*dirxx_yy); - drawtext(canvas.handle,pchar(s),length(s),curr,DT_CENTER or DT_VCENTER or DT_SINGLELINE); + R := clientrect; + if O_BRD then + inflaterect(R, -2, -2); + if O_B then + if O_V then + R.right := R.right - 21 + else + R.bottom := R.bottom - 21 + else if O_V then + R.left := R.left + 21 + else + R.top := R.top + 21; + if not O_BTN then + drawedge(Canvas.handle, R, EDGE_RAISED, BF_RECT or BF_SOFT); + if CurPage <> nil then begin + drawtab(CurR, true); + S := CurPage.caption; + if O_BTN then + offsetrect(CurR, 2, 2) + else + offsetrect(CurR, -2 * DirXY_YX, -2 * DirXX_YY); + drawtext(Canvas.handle, pchar(S), length(S), CurR, DT_CENTER or DT_VCENTER or DT_SINGLELINE); end; - if o_v then deleteobject(fnt); + if O_V then + deleteobject(Fnt); inherited; end; -function TKOLTabControl.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLTabControl.P_SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -var i: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if Count > 0 then - begin - SL.Add( ' C2R L(' + IntToStr( Count ) + ') DELN R2C DUP C2R' ); - for i := Count-1 downto 0 do - begin - SL.Add( ' L(' + IntToStr( i ) + ') R2C DUP C2R ' + - ' TControl_.GetPages<2> RESULT' ); - end; - SL.Add( ' R2C DEL' ); - end; - case edgeType of - esLowered:; - esRaised: //SL.Add( Prefix + AName + '.Style := ' + AName + '.Style or WS_THICKFRAME;' ); - {P}SL.Add( ' DUP AddWord_LoadRef ##TControl_.fStyle L(' + IntToStr( WS_THICKFRAME ) + ')' + - ' C1 TControl_.SetStyle<2>' ); - //esNone, esTransparent, esSolid: ; - end; -end; - -procedure TKOLTabControl.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.P_SetupLast', 0 - @@e_signature: - end; - inherited; - if CurIndex > 0 then - begin - //SL.Add( Prefix + ' ' + AName + '.CurIndex := ' + IntToStr( CurIndex ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( CurIndex ) + ')' ); - {P}SL.Add( ' ' + - 'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name + - ' C1 C1 TControl_.SetCurIndex<2>' ); - //SL.Add( Prefix + ' ' + AName + '.Pages[ ' + IntToStr( CurIndex ) + ' ].BringToFront;' ); - {P}SL.Add( ' ' + - ' TControl_.GetPages<2> RESULT' ); - {P}SL.Add( ' TControl.BringToFront<1>' ); - end; -end; - -function TKOLTabControl.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -var //O, IL, S: String; - I: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.P_SetupParams', 0 - @@e_signature: - end; - {S := ''; - for I := 0 to Count - 1 do - begin - if S <> '' then - S := S + ', '; - S := S + StringConstant( 'Page' + IntToStr( I ) + 'Caption', Pages[ I ].Caption ); - end; - O := ''; - if tcoButtons in Options then - O := 'tcoButtons'; - if tcoFixedWidth in Options then - O := O + ', tcoFixedWidth'; - if tcoFocusTabs in Options then - O := O + ', tcoFocusTabs'; - if tcoIconLeft in Options then - O := O + ', tcoIconLeft'; - if tcoLabelLeft in Options then - O := O + ', tcoLabelLeft'; - if tcoMultiline in Options then - O := O + ', tcoMultiline'; - if tcoMultiselect in Options then - O := O + ', tcoMultiselect'; - if tcoFitRows in Options then - O := O + ', tcoFitRows'; - if tcoScrollOpposite in Options then - O := O + ', tcoScrollOpposite'; - if tcoBottom in Options then - O := O + ', tcoBottom'; - if tcoVertical in Options then - O := O + ', tcoVertical'; - if tcoFlat in Options then - O := O + ', tcoFlat'; - if tcoHotTrack in Options then - O := O + ', tcoHotTrack'; - if tcoBorder in Options then - O := O + ', tcoBorder'; - if tcoOwnerDrawFixed in Options then - O := O + ', tcoOwnerDrawFixed'; - if O <> '' then - if O[ 1 ] = ',' then - O := Copy( O, 3, MaxInt ); - IL := 'nil'; - if ImageList <> nil then - IL := 'Result.' + ImageList.Name; - Result := AParent + ', [ ' + S + ' ], [ ' + O + ' ], ' + IL - + ', ' + IntToStr( ImageList1stIdx );} - - if Count > 0 then - begin - {P}Result := ' L(' + IntToStr( Count ) + ') LoadPCharArray'; - for i := Count-1 downto 0 do - begin - Result := Result + ' ''' + Pages[ i ].Caption + ''' #0'; - end; - end; - Result := Result + #13#10' LoadStack C2R'; - - {P}Result := Result + ' L(' + IntToStr( PWord( @ Options )^ ) + ')'; - {P}if ImageList=nil then Result := Result + ' L(0)' - else if ImageList.ParentKOLForm = ParentKOLForm then - Result := Result + #13#10' LoadSELF AddWord_LoadRef ##T' + - ParentKOLForm.FormName + '.' + ImageList.Name - else Result := Result + #13#10' Load4 ####T' + ImageList.ParentKOLForm.FormName + - #13#10' AddWord_LoadRef ##T' + ImageList.ParentKOLForm.FormName + - '.' + ImageList.Name; - {P}Result := Result + #13#10' L(' + IntToStr( ImageList1stIdx ) + ')'; - - {P}Result := Result + #13#10' L(' + IntToStr( Count-1 ) + ') R2C'; - {P}Result := Result + #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + - '.'; - if Parent is TForm then Result := Result + 'Form' - else Result := Result + Parent.Name; - - nparams := 3; -end; - -{procedure TKOLTabControl.ReadNewTabControl(Reader: TReader); -begin - ShowMessage( 'Reader is reading NewTabControl property' ); - LogFileOutput( 'C:\log_TC.txt', 'Reader is reading NewTabControl property' ); - fNewTabControl := Reader.ReadBoolean; - //if not fNewTabControl then - begin - Reader.OnFindComponentClass := WhenFindComponentClass; - Reader.OnSetName := WhenReaderSetsName; - end; -end;} - procedure TKOLTabControl.SchematicPaint; -var R: TRect; - I, Tw, Th: Integer; - S: String; - CurPage: TKOLPanel; - M: PRect; +var + R: TRect; + I, Tw, Th: Integer; + S: string; + CurPage: TKOLPanel; + M: PRect; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.Paint', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.Paint', 0 + +@@e_signature: end; inherited Paint; R := ClientRect; - Inc( R.Top, 4 ); - Inc( R.Left, 4 ); - Dec( R.Right, 4 ); - Dec( R.Bottom, 4 ); + Inc(R.Top, 4); + Inc(R.Left, 4); + Dec(R.Right, 4); + Dec(R.Bottom, 4); if tcoBottom in Options then if tcoVertical in Options then R.Left := R.Right - 18 else R.Top := R.Bottom - 18 + else if tcoVertical in Options then + R.Right := R.Left + 18 else - if tcoVertical in Options then - R.Right := R.Left + 18 - else - R.Bottom := R.Top + 18; + R.Bottom := R.Top + 18; R.Right := R.Left + 18; R.Bottom := R.Top + 18; Canvas.Font.Height := 8; Canvas.Brush.Color := clDkGray; CurPage := GetCurrentPage; - for I := 0 to FTabs.Count-1 do - FreeMem( FTabs[ I ] ); + for I := 0 to FTabs.Count - 1 do + FreeMem(FTabs[I]); FTabs.Clear; - for I := 0 to Count-1 do - begin - GetMem( M, SizeOf( TRect ) ); + for I := 0 to Count - 1 do begin + GetMem(M, SizeOf(TRect)); M^ := R; - FTabs.Add( M ); - S := IntToStr( I ); - Tw := Canvas.TextWidth( S ); - Th := Canvas.TextHeight( S ); - Canvas.TextRect( R, R.Left + (18 - Tw) div 2, R.Top + (18 - Th) div 2, S ); - Pages[ I ].FOnSetBounds := AttemptToChangePageBounds; - if CurPage = Pages[ I ] then - begin + FTabs.Add(M); + S := IntToStr(I); + Tw := Canvas.TextWidth(S); + Th := Canvas.TextHeight(S); + Canvas.TextRect(R, R.Left + (18 - Tw) div 2, R.Top + (18 - Th) div 2, S); + Pages[I].FOnSetBounds := AttemptToChangePageBounds; + if CurPage = Pages[I] then begin Canvas.Brush.Color := clBlack; - Canvas.FrameRect( R ); + Canvas.FrameRect(R); Canvas.Brush.Color := clDkGray; end; - if tcoVertical in Options then - begin - Inc( R.Top, 22 ); - Inc( R.Bottom, 22 ); + if tcoVertical in Options then begin + Inc(R.Top, 22); + Inc(R.Bottom, 22); end - else - begin - Inc( R.Left, 22 ); - Inc( R.Right, 22 ); + else begin + Inc(R.Left, 22); + Inc(R.Right, 22); end; end; end; @@ -10825,44 +8341,47 @@ end; procedure TKOLTabControl.SetBounds(aLeft, aTop, aWidth, aHeight: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetBounds', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetBounds', 0 + +@@e_signature: end; inherited; AdjustPages; end; procedure TKOLTabControl.SetCount(const Value: Integer); -var Pg: TKOLPanel; - I: Integer; - S: String; +var + Pg: TKOLPanel; + I: Integer; + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetCount', 0 + +@@e_signature: end; - if Value < Count then Exit; - if csLoading in ComponentState then Exit; + if Value < Count then + Exit; + if csLoading in ComponentState then + Exit; I := Count; - while Value > Count do - begin - while True do - begin - S := Name + '_Tab' + IntToStr( I ); - if (Owner as TForm).FindComponent( S ) = nil then + while Value > Count do begin + while True do begin + S := Name + '_Tab' + IntToStr(I); + if (Owner as TForm).FindComponent(S) = nil then break; - Inc( I ); + Inc(I); end; - Pg := TKOLTabPage.Create( Owner ); + Pg := TKOLTabPage.Create(Owner); Pg.Parent := Self; Pg.Name := S; - Pg.Caption := 'Tab' + IntToStr( I ); + Pg.Caption := 'Tab' + IntToStr(I); Pg.edgeStyle := esNone; - Inc( I ); + Inc(I); end; AdjustPages; Invalidate; @@ -10872,19 +8391,18 @@ end; procedure TKOLTabControl.SetCurIndex(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetCurIndex', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetCurIndex', 0 + +@@e_signature: end; - if (Value >= Count) or (Value < 0) then - begin + if (Value >= Count) or (Value < 0) then begin FCurPage := nil; Exit; end; - FCurPage:=Pages[ Value ]; - if FCurPage <> nil then - begin + FCurPage := Pages[Value]; + if FCurPage <> nil then begin FCurPage.BringToFront; Invalidate; end; @@ -10894,16 +8412,17 @@ end; procedure TKOLTabControl.SetedgeType(const Value: TEdgeStyle); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetedgeType', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetedgeType', 0 + +@@e_signature: end; FedgeType := Value; - if Value in [esNone,esTransparent,esSolid] then - Options := Options - [ tcoBorder ] + if Value in [esNone, esTransparent, esSolid] then + Options := Options - [tcoBorder] else - Options := Options + [ tcoBorder ]; + Options := Options + [tcoBorder]; Change; end; @@ -10916,10 +8435,11 @@ end; procedure TKOLTabControl.SetImageList(const Value: TKOLImageList); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetImageList', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetImageList', 0 + +@@e_signature: end; FImageList := Value; Change; @@ -10928,10 +8448,11 @@ end; procedure TKOLTabControl.SetImageList1stIdx(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetImageList1stIdx', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetImageList1stIdx', 0 + +@@e_signature: end; FImageList1stIdx := Value; Change; @@ -10940,10 +8461,11 @@ end; procedure TKOLTabControl.SetOptions(const Value: TTabControlOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetOptions', 0 + +@@e_signature: end; FOptions := Value; AdjustPages; @@ -10951,112 +8473,76 @@ begin Change; end; -procedure TKOLTabControl.SetupConstruct_Compact; -var KF: TKOLForm; - i: Integer; - C: String; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewTabControl', TRUE, TRUE, '' ); - KF.FormAddNumParameter( Count ); - for i := 0 to Count-1 do - begin - C := Pages[i].Caption; - if not KF.AssignTextToControls then - C := ''; - KF.FormAddStrParameter( C ); - end; - KF.FormAddNumParameter( PByte( @ Options )^ ); - KF.FormAddNumParameter( ImageList1stIdx ); -end; - -procedure TKOLTabControl.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLTabControl.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; + case edgeType of - esLowered:; - esRaised: - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetStyle', '' ); - KF.FormAddNumParameter( WS_THICKFRAME ); - end else - SL.Add( Prefix + AName + '.Style := ' + AName + - '.Style or WS_THICKFRAME;' ); + esLowered: + ; + esRaised: + SL.Add(Prefix + AName + '.Style := ' + AName + '.Style or WS_THICKFRAME;'); //esNone, esTransparent, esSolid: ; end; end; -procedure TKOLTabControl.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLTabControl.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetupLast', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetupLast', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if CurIndex > 0 then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetCurrentTab', '' ); - KF.FormAddNumParameter( CurIndex ); - end - else - begin - SL.Add( Prefix + ' ' + AName + '.CurIndex := ' + IntToStr( CurIndex ) + ';' ); - SL.Add( Prefix + ' ' + AName + '.Pages[ ' + IntToStr( CurIndex ) + ' ].BringToFront;' ); - end; + + if CurIndex > 0 then begin + SL.Add(Prefix + ' ' + AName + '.CurIndex := ' + IntToStr(CurIndex) + ';'); + SL.Add(Prefix + ' ' + AName + '.Pages[ ' + IntToStr(CurIndex) + ' ].BringToFront;'); end; end; -function TKOLTabControl.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var O, IL: String; - I: Integer; - KF: TKOLForm; +function TKOLTabControl.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + O, IL: string; + I: Integer; + KF: TKOLForm; {$IFDEF _D2009orHigher} C, C2, S: WideString; - j : integer; + j: integer; {$ELSE} C, S: string; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.SetupParams', 0 + +@@e_signature: end; S := ''; KF := ParentKOLForm; - for I := 0 to Count - 1 do - begin + for I := 0 to Count - 1 do begin if S <> '' then S := S + ', '; - if (KF <> nil) and KF.AssignTextToControls then - C := StringConstant('Page' + IntToStr( I ) + 'Caption', Pages[ I ].Caption) + if (KF <> nil) and KF.AssignTextToControls then + C := StringConstant('Page' + IntToStr(I) + 'Caption', Pages[I].Caption) else - C := ''''''; + C := ''''''; {$IFDEF _D2009orHigher} - if C <> '''''' then - begin + if C <> '''''' then begin C2 := ''; - for j := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[j])); + for j := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[j])); C := C2; end; {$ENDIF} @@ -11095,59 +8581,26 @@ begin if tcoOwnerDrawFixed in Options then O := O + ', tcoOwnerDrawFixed'; if O <> '' then - if O[ 1 ] = ',' then - O := Copy( O, 3, MaxInt ); + if O[1] = ',' then + O := Copy(O, 3, MaxInt); IL := 'nil'; if ImageList <> nil then IL := 'Result.' + ImageList.Name; - Result := AParent + ', [ ' + S + ' ], [ ' + O + ' ], ' + IL - + ', ' + IntToStr( ImageList1stIdx ); -end; - -function TKOLTabControl.SupportsFormCompact: Boolean; -begin - Result := TRUE; + Result := AParent + ', [ ' + S + ' ], [ ' + O + ' ], ' + IL + ', ' + IntToStr(ImageList1stIdx); end; function TKOLTabControl.TabStopByDefault: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControl.TabStopByDefault', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControl.TabStopByDefault', 0 + +@@e_signature: end; Result := TRUE; end; -{procedure TKOLTabControl.WhenFindComponentClass(Reader: TReader; - const CClassName: string; var CComponentClass: TComponentClass); -begin - if (pos( '_Tab', fNameSetByReader ) > 0) - and (CClassName = 'TKOLPanel') then - begin - CComponentClass := TKOLTabPage; - ShowMessage( 'TKOLPanel class replaced with TKOLTabPage for ' + fNameSetByReader ); - end - else - inherited; -end; - -procedure TKOLTabControl.WhenReaderSetsName(Reader: TReader; - Component: TComponent; var AName: string); -begin - inherited; - fNameSetByReader := AName; - ShowMessage( 'Reader sets name ' + AName ); - LogFileOutput( 'C:\log_TC.txt', 'Reader sets name ' + AName ); -end; - -procedure TKOLTabControl.WriteNewTabControl(Writer: TWriter); -begin - Writer.WriteBoolean( TRUE ); -end; -} - function TKOLTabControl.WYSIWIGPaintImplemented: Boolean; begin Result := TRUE; @@ -11156,20 +8609,21 @@ end; { TKOLToolbar } function TKOLToolbar.AllPicturedButtonsAreLeading: Boolean; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin Result := FALSE; - if PicturedButtonsCount = 0 then Exit; - Bt := Items[ 0 ]; - if not Bt.HasPicture then Exit; + if PicturedButtonsCount = 0 then + Exit; + Bt := Items[0]; + if not Bt.HasPicture then + Exit; Result := TRUE; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if not Bt.HasPicture then - begin - if NoMorePicturedButtonsFrom( I ) then + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if not Bt.HasPicture then begin + if NoMorePicturedButtonsFrom(I) then break; Result := FALSE; break; @@ -11178,300 +8632,304 @@ begin end; function TKOLToolbar.LastBtnHasPicture: Boolean; -var Bt: TKOLToolbarButton; +var + Bt: TKOLToolbarButton; begin Result := FALSE; - if PicturedButtonsCount = 0 then Exit; - if not Assigned( Items ) then Exit; - if Items.Count = 0 then Exit; - Bt := Items[ Items.Count-1 ]; + if PicturedButtonsCount = 0 then + Exit; + if not Assigned(Items) then + Exit; + if Items.Count = 0 then + Exit; + Bt := Items[Items.Count - 1]; Result := Bt.HasPicture; end; procedure TKOLToolbar.AssembleBitmap; -var MaxWidth, MaxHeight: Integer; - I: Integer; - Bt: TKOLToolbarButton; - TranColor: TColor; - TmpBmp: TBitmap; +var + MaxWidth, MaxHeight: Integer; + I: Integer; + Bt: TKOLToolbarButton; + TranColor: TColor; + TmpBmp: TBitmap; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.AssembleBitmap', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.AssembleBitmap', 0 + +@@e_signature: end; MaxWidth := 0; MaxHeight := 0; TranColor := clNone; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.HasPicture then - begin + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.HasPicture then begin if MaxWidth < Bt.picture.Width then MaxWidth := Bt.picture.Width; if MaxHeight < Bt.picture.Height then MaxHeight := Bt.picture.Height; - if TranColor = clNone then - begin + if TranColor = clNone then begin TmpBmp := TBitmap.Create; - TRY + try TmpBmp.Width := Bt.picture.Width; TmpBmp.Height := Bt.picture.Height; - TmpBmp.Canvas.Draw( 0, 0, Bt.picture.Graphic ); - TranColor := TmpBmp.Canvas.Pixels[ 0, TmpBmp.Height - 1 ]; - FINALLY + TmpBmp.Canvas.Draw(0, 0, Bt.picture.Graphic); + TranColor := TmpBmp.Canvas.Pixels[0, TmpBmp.Height - 1]; + finally TmpBmp.Free; - END; + end; end; end; end; - if (MaxWidth = 0) or (MaxHeight = 0) then - begin + if (MaxWidth = 0) or (MaxHeight = 0) then begin Fbitmap.Width := 0; Fbitmap.Height := 0; end - else - begin + else begin Fbitmap.Width := MaxWidth * Items.Count; Fbitmap.Height := MaxHeight; - if TranColor <> clNone then - begin + if TranColor <> clNone then begin Fbitmap.Canvas.Brush.Color := TranColor; - Fbitmap.Canvas.FillRect( Rect( 0, 0, Fbitmap.Width, Fbitmap.Height ) ); + Fbitmap.Canvas.FillRect(Rect(0, 0, Fbitmap.Width, Fbitmap.Height)); end; - for I := 0 to Items.Count - 1 do - begin - Bt := Items[ I ]; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.HasPicture then - Fbitmap.Canvas.Draw( I * MaxWidth, 0, Bt.picture.Graphic ); + Fbitmap.Canvas.Draw(I * MaxWidth, 0, Bt.picture.Graphic); end; end; - if ActiveDesign <> nil then - begin - ActiveDesign.Bitmap.Assign( Fbitmap ); + if ActiveDesign <> nil then begin + ActiveDesign.Bitmap.Assign(Fbitmap); ActiveDesign.ApplyImages; end; if Assigned(FKOLCtrl) then RecreateWnd; end; -function IsBitmapEmpty( Bmp: TBitmap ): Boolean; -var Y, X: Integer; - Color1: TColor; - Lin: PDWORD; - KOLBmp: KOL.PBitmap; +function IsBitmapEmpty(Bmp: TBitmap): Boolean; +var + Y, X: Integer; + Color1: TColor; + Lin: PDWORD; + KOLBmp: KOL.PBitmap; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'IsBitmapEmpty', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'IsBitmapEmpty', 0 + +@@e_signature: end; Result := TRUE; - if not Assigned( Bmp ) then Exit; - if Bmp.Width * Bmp.Height = 0 then Exit; - KOLBmp := NewBitmap( Bmp.Width, Bmp.Height ); - TRY + if not Assigned(Bmp) then + Exit; + if Bmp.Width * Bmp.Height = 0 then + Exit; + KOLBmp := NewBitmap(Bmp.Width, Bmp.Height); + try KOLBmp.HandleType := KOL.bmDIB; KOLBmp.PixelFormat := KOL.pf32bit; - BitBlt( KOLBmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, - Bmp.Canvas.Handle, 0, 0, SrcCopy ); - Lin := KOLBmp.ScanLine[ 0 ]; - if Lin = nil then - begin + BitBlt(KOLBmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SrcCopy); + Lin := KOLBmp.ScanLine[0]; + if Lin = nil then begin Result := FALSE; Exit; end; Color1 := Lin^ and $FFFFFF; - for Y := 0 to KOLBmp.Height-1 do - begin - Lin := KOLBmp.ScanLine[ Y ]; - for X := 0 to KOLBmp.Width-1 do - begin - if DWORD(Lin^ and $FFFFFF) <> DWORD( Color1 ) then - begin + for Y := 0 to KOLBmp.Height - 1 do begin + Lin := KOLBmp.ScanLine[Y]; + for X := 0 to KOLBmp.Width - 1 do begin + if DWORD(Lin^ and $FFFFFF) <> DWORD(Color1) then begin Result := FALSE; Exit; end; - Inc( Lin ); + Inc(Lin); end; end; - FINALLY + finally KOLBmp.Free; - END; + end; end; procedure TKOLToolbar.AssembleTooltips; -var SL: TStringList; - I, N: Integer; - Bt: TKOLToolbarButton; +var + SL: TStringList; + I, N: Integer; + Bt: TKOLToolbarButton; {$IFDEF _D2009orHigher} - C : WideString; - J : integer; + C: WideString; + J: integer; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.AssembleTooltips', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.AssembleTooltips', 0 + +@@e_signature: end; N := 0; SL := TStringList.Create; - TRY - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.separator then continue; + try + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.separator then + continue; {$IFDEF _D2009orHigher} - for J := 2 to Length(Bt.Ftooltip) - 1 do C := C + '#'+int2str(ord(Bt.Ftooltip[J])); - SL.Add( C ); + for J := 2 to Length(Bt.Ftooltip) - 1 do + C := C + '#' + int2str(ord(Bt.Ftooltip[J])); + SL.Add(C); {$ELSE} - SL.Add( Bt.Ftooltip ); + SL.Add(Bt.Ftooltip); {$ENDIF} - if Length( Bt.Ftooltip ) > 0 then - Inc( N ); + if Length(Bt.Ftooltip) > 0 then + Inc(N); end; if N = 0 then SL.Clear; tooltips := SL; showTooltips := SL.Count > 0; - FINALLY + finally SL.Free; - END; + end; end; -procedure TKOLToolbar.bitmap2ItemPictures( AnyWay: Boolean ); -var W, I: Integer; - Bmp: TBitmap; - Bt: TKOLToolbarButton; - Format: TPixelFormat; - KOLBmp: KOL.PBitmap; - Colors: KOL.PList; +procedure TKOLToolbar.bitmap2ItemPictures(AnyWay: Boolean); +var + W, I: Integer; + Bmp: TBitmap; + Bt: TKOLToolbarButton; + Format: TPixelFormat; + KOLBmp: KOL.PBitmap; + Colors: KOL.PList; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.bitmap2ItemPictures', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.bitmap2ItemPictures', 0 + +@@e_signature: end; - if not Assigned( bitmap ) then Exit; - if Items.Count = 0 then Exit; - if bitmap.Width = 0 then Exit; - if bitmap.Height = 0 then Exit; - if not AnyWay then - begin - for I := 0 to Items.Count - 1 do - begin - Bt := Items[ I ]; + if not Assigned(bitmap) then + Exit; + if Items.Count = 0 then + Exit; + if bitmap.Width = 0 then + Exit; + if bitmap.Height = 0 then + Exit; + if not AnyWay then begin + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.HasPicture then Exit; end; - ShowMessage( 'Restoring toolbar buttons bitmap from then previous version of the KOL&MCK format.' ); + ShowMessage('Restoring toolbar buttons bitmap from then previous version of the KOL&MCK format.'); end; W := bitmap.Width div Items.Count; Bmp := TBitmap.Create; - KOLBmp := NewDIBBitmap( Bitmap.Width, Bitmap.Height, KOL.pf32bit ); - TRY - BitBlt( KOLBmp.Canvas.Handle, 0, 0, bitmap.Width, bitmap.Height, - bitmap.Canvas.Handle, 0, 0, SRCCOPY ); + KOLBmp := NewDIBBitmap(Bitmap.Width, Bitmap.Height, KOL.pf32bit); + try + BitBlt(KOLBmp.Canvas.Handle, 0, 0, bitmap.Width, bitmap.Height, bitmap.Canvas.Handle, 0, 0, SRCCOPY); KOLBmp.HandleType := KOL.bmDIB; KOLBmp.PixelFormat := KOL.pf32bit; Colors := NewList; - TRY - case CountSystemColorsUsedInBitmap( KOLBmp, Colors ) of - KOL.pf1bit: Format := pf1bit; - KOL.pf4bit: Format := pf4bit; - KOL.pf8bit: Format := pf8bit; - else Format := pf24bit; - end; - FINALLY - Colors.Free; - END; - FINALLY + try + case CountSystemColorsUsedInBitmap(KOLBmp, Colors) of + KOL.pf1bit: + Format := pf1bit; + KOL.pf4bit: + Format := pf4bit; + KOL.pf8bit: + Format := pf8bit; + else + Format := pf24bit; + end; + finally + Colors.Free; + end; + finally KOLBmp.Free; - END; - TRY + end; + try Bmp.Width := W; Bmp.Height := bitmap.Height; Bmp.PixelFormat := Format; - for I := 0 to Items.Count - 1 do - begin - if I >= Items.Count then break; - if Items[ I ] = nil then break; - Bmp.Canvas.CopyRect( Rect( 0, 0, Bmp.Width, Bmp.Height ), - bitmap.Canvas, - Rect( I * Bmp.Width, 0, (I + 1) * Bmp.Width, Bmp.Height ) ); - Bt := Items[ I ]; - if IsBitmapEmpty( Bmp ) then - begin + for I := 0 to Items.Count - 1 do begin + if I >= Items.Count then + break; + if Items[I] = nil then + break; + Bmp.Canvas.CopyRect(Rect(0, 0, Bmp.Width, Bmp.Height), bitmap.Canvas, Rect + (I * Bmp.Width, 0, (I + 1) * Bmp.Width, Bmp.Height)); + Bt := Items[I]; + if IsBitmapEmpty(Bmp) then begin Bt.Fpicture.Free; Bt.Fpicture := TPicture.Create; end - else - begin - Bt.Fpicture.Assign( Bmp ); + else begin + Bt.Fpicture.Assign(Bmp); end; end; - FINALLY + finally Bmp.Free; - END; + end; end; procedure TKOLToolbar.buttons2Items; -var I, J: Integer; - S, C: String; - Bt: TKOLToolbarButton; +var + I, J: Integer; + S, C: string; + Bt: TKOLToolbarButton; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.buttons2Items', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.buttons2Items', 0 + +@@e_signature: end; S := buttons; J := 0; - while S <> '' do - begin - I := pos( #1, S ); - if I > 0 then - begin - C := Copy( S, 1, I - 1 ); - S := Copy( S, I + 1, MaxInt ); + while S <> '' do begin + I := pos(#1, S); + if I > 0 then begin + C := Copy(S, 1, I - 1); + S := Copy(S, I + 1, MaxInt); end - else - begin + else begin C := S; S := ''; end; if J >= Items.Count then - Bt := TKOLToolbarButton.Create( Self ) + Bt := TKOLToolbarButton.Create(Self) else - Bt := Items[ J ]; + Bt := Items[J]; if C <> '' then - if C[ 1 ] = '^' then - begin - C := Copy( C, 2, MaxInt ); - Bt.Fdropdown := TRUE; - end; + if C[1] = '^' then begin + C := Copy(C, 2, MaxInt); + Bt.Fdropdown := TRUE; + end; Bt.Fcaption := C; if C <> '-' then Bt.Fseparator := FALSE; - Inc( J ); + Inc(J); end; - bitmap2ItemPictures( FALSE ); + bitmap2ItemPictures(FALSE); end; procedure TKOLToolbar.Change; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.Change', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.Change', 0 + +@@e_signature: end; inherited; if ActiveDesign <> nil then @@ -11484,10 +8942,11 @@ end; constructor TKOLToolbar.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.Create', 0 + +@@e_signature: end; Ftooltips := TStringList.Create; inherited; @@ -11495,8 +8954,9 @@ begin FgenerateConstants := TRUE; FHeightAuto := TRUE; Fitems := TList.Create; - ControlStyle := ControlStyle + [ csAcceptsControls ]; - Height := 22; DefaultHeight := Height; + ControlStyle := ControlStyle + [csAcceptsControls]; + Height := 22; + DefaultHeight := Height; Width := 400; DefaultWidth := 400; Align := caTop; @@ -11506,7 +8966,7 @@ begin {$ENDIF} FHasBorder := FALSE; FDefHasBorder := FALSE; - FTimer := TTimer.Create( Self ); + FTimer := TTimer.Create(Self); FTimer.Interval := 200; FTimer.OnTimer := Tick; FTimer.Enabled := TRUE; @@ -11515,39 +8975,42 @@ begin end; procedure TKOLToolbar.DefineProperties(Filer: TFiler); -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.DefineProperties', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.DefineProperties', 0 + +@@e_signature: end; inherited; - Filer.DefineProperty( 'Buttons_Count', LoadButtonCount, SaveButtonCount, TRUE ); - for I := 0 to FButtonCount-1 do - begin + Filer.DefineProperty('Buttons_Count', LoadButtonCount, SaveButtonCount, TRUE); + for I := 0 to FButtonCount - 1 do begin if FItems.Count <= I then - Bt := TKOLToolbarButton.Create( Self ) + Bt := TKOLToolbarButton.Create(Self) else - Bt := FItems[ I ]; - Bt.DefProps( 'Btn' + IntToStr( I + 1 ), Filer ); + Bt := FItems[I]; + Bt.DefProps('Btn' + IntToStr(I + 1), Filer); end; - Filer.DefineProperty( 'NewVersion', ReadNewVersion, WriteNewVersion, fNewVersion ); + Filer.DefineProperty('NewVersion', ReadNewVersion, WriteNewVersion, fNewVersion); end; destructor TKOLToolbar.Destroy; -var I: Integer; +var + I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.Destroy', 0 + +@@e_signature: end; - for I := FItems.Count-1 downto 0 do - TObject( FItems[ I ] ).Free; + for I := FItems.Count - 1 downto 0 do + TObject(FItems[I]).Free; FItems.Free; FTimer.Free; ActiveDesign.Free; @@ -11555,80 +9018,82 @@ begin FBitmap := nil; Ftooltips.Free; if FBmpDesign <> 0 then - DeleteObject( FBmpDesign ); + DeleteObject(FBmpDesign); inherited; end; -function IsNumber( const S: String ): Boolean; -var I: Integer; +function IsNumber(const S: string): Boolean; +var + I: Integer; begin Result := FALSE; - if S = '' then Exit; - for I := 1 to Length( S ) do - if (S[ I ] < '0') or (S[ I ] > '9') then - Exit; + if S = '' then + Exit; + for I := 1 to Length(S) do + if (S[I] < '0') or (S[I] > '9') then + Exit; Result := TRUE; end; procedure TKOLToolbar.DoGenerateConstants(SL: TStringList); -var I, N, K: Integer; - Bt: TKOLToolbarButton; - W, H: Integer; +var + I, N, K: Integer; + Bt: TKOLToolbarButton; + W, H: Integer; begin FResBmpID := -1; H := MaxBtnImgHeight; W := MaxBtnImgWidth; if W * H > 0 then FResBmpID := ParentKOLForm.NextUniqueID; - if not (generateConstants or generateVariables) then Exit; + if not (generateConstants or generateVariables) then + Exit; N := 0; K := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.separator and (Copy( Bt.Name, 1, 2 ) = 'TB') and - IsNumber( Copy( Bt.Name, 3, MaxInt ) ) then - begin - Inc( N ); + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.separator and (Copy(Bt.Name, 1, 2) = 'TB') and IsNumber(Copy(Bt.Name, 3, MaxInt)) then begin + Inc(N); continue; end; - if Bt.Name <> '' then - begin + if Bt.Name <> '' then begin if generateConstants then - SL.Add( 'const ' + Bt.Name + ' = ' + IntToStr( N ) + ';' ) + SL.Add('const ' + Bt.Name + ' = ' + IntToStr(N) + ';') else - SL.Add( 'var ' + Bt.Name + ': Integer = ' + IntToStr( N ) + ';' ); - Inc( K ); + SL.Add('var ' + Bt.Name + ': Integer = ' + IntToStr(N) + ';'); + Inc(K); end; - Inc( N ); + Inc(N); end; - if ( K > 0 ) then - SL.Add( '' ); + if (K > 0) then + SL.Add(''); end; -function TKOLToolbar.GetButtons: String; +function TKOLToolbar.GetButtons: string; begin Result := Fbuttons; - if Items.Count = 0 then Exit; + if Items.Count = 0 then + Exit; Items2buttons; Result := FButtons; end; procedure TKOLToolbar.Items2buttons; -var I: Integer; - S: String; - Bt: TKOLToolbarButton; +var + I: Integer; + S: string; + Bt: TKOLToolbarButton; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.Items2buttons', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.Items2buttons', 0 + +@@e_signature: end; S := ''; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if S <> '' then S := S + #1; if Bt.dropdown then @@ -11641,39 +9106,38 @@ end; procedure TKOLToolbar.LoadButtonCount(R: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.LoadButtonCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.LoadButtonCount', 0 + +@@e_signature: end; FButtonCount := R.ReadInteger; end; procedure TKOLToolbar.Loaded; -var I, J: Integer; - Bt: TKOLToolbarButton; - S: String; - AnyEnabled: Boolean; +var + I, J: Integer; + Bt: TKOLToolbarButton; + S: string; + AnyEnabled: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.Loaded', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.Loaded', 0 + +@@e_signature: end; inherited; buttons2Items; AnyEnabled := FALSE; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.Name = '' then - begin - for J := 1 to MaxInt do - begin - S := 'TB' + IntToStr( J ); - if (FindComponent( S ) = nil) and ((Owner as TForm).FindComponent( S ) = nil) then - begin + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.Name = '' then begin + for J := 1 to MaxInt do begin + S := 'TB' + IntToStr(J); + if (FindComponent(S) = nil) and ((Owner as TForm).FindComponent(S) = nil) then begin Bt.Name := S; break; end; @@ -11682,11 +9146,9 @@ begin if Bt.enabled then AnyEnabled := TRUE; end; - if not AnyEnabled then - begin - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + if not AnyEnabled then begin + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; Bt.enabled := TRUE; end; end; @@ -11699,53 +9161,54 @@ begin end; function TKOLToolbar.MaxBtnImgHeight: Integer; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.MaxBtnImgHeight', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.MaxBtnImgHeight', 0 + +@@e_signature: end; Result := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.HasPicture and (Bt.picture.Height > Result) then Result := Bt.picture.Height; end; end; function TKOLToolbar.MaxBtnImgWidth: Integer; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.MaxBtnImgWidth', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.MaxBtnImgWidth', 0 + +@@e_signature: end; Result := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.HasPicture and (Bt.picture.Width > Result) then Result := Bt.picture.Width; end; end; function TKOLToolbar.NoMorePicturedButtonsFrom(Idx: Integer): Boolean; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin Result := TRUE; - for I := Idx to Items.Count - 1 do - begin - Bt := Items[ I ]; - if Bt.HasPicture or (Bt.sysimg <> stiCustom) then - begin + for I := Idx to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.HasPicture or (Bt.sysimg <> stiCustom) then begin Result := FALSE; break; end; @@ -11753,47 +9216,48 @@ begin end; function TKOLToolbar.PicturedButtonsCount: Integer; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin Result := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.HasPicture then - Inc( Result ); + Inc(Result); end; end; procedure TKOLToolbar.SaveButtonCount(W: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.SaveButtonCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.SaveButtonCount', 0 + +@@e_signature: end; FButtonCount := FItems.Count; - W.WriteInteger( FButtonCount ); + W.WriteInteger(FButtonCount); end; procedure TKOLToolbar.Setbitmap(const Value: TBitmap); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.Setbitmap', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.Setbitmap', 0 + +@@e_signature: end; if Value <> nil then - Fbitmap.Assign( Value ) - else - begin + Fbitmap.Assign(Value) + else begin Fbitmap.Width := 0; Fbitmap.Height := 0; end; if not (csLoading in ComponentState) then - bitmap2ItemPictures( TRUE ); + bitmap2ItemPictures(TRUE); if Assigned(FKOLCtrl) then RecreateWnd; Change; @@ -11802,10 +9266,11 @@ end; procedure TKOLToolbar.SetBtnCount_Dummy(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.SetBtnCount_Dummy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.SetBtnCount_Dummy', 0 + +@@e_signature: end; //FButtonCount := Value; end; @@ -11833,12 +9298,14 @@ end; procedure TKOLToolbar.SetmapBitmapColors(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.SetmapBitmapColors', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.SetmapBitmapColors', 0 + +@@e_signature: end; - if Value = FmapBitmapColors then Exit; + if Value = FmapBitmapColors then + Exit; FmapBitmapColors := Value; if Assigned(FKOLCtrl) then RecreateWnd; @@ -11848,10 +9315,11 @@ end; procedure TKOLToolbar.SetnoTextLabels(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.SetnoTextLabels', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.SetnoTextLabels', 0 + +@@e_signature: end; FnoTextLabels := Value; UpdateButtons; @@ -11861,10 +9329,11 @@ end; procedure TKOLToolbar.SetOptions(const Value: TToolbarOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.SetOptions', 0 + +@@e_signature: end; FOptions := Value; if Assigned(FKOLCtrl) then @@ -11875,10 +9344,11 @@ end; procedure TKOLToolbar.SetshowTooltips(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.SetshowTooltips', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.SetshowTooltips', 0 + +@@e_signature: end; FshowTooltips := Value; Change; @@ -11895,546 +9365,377 @@ end; procedure TKOLToolbar.Settooltips(const Value: TStrings); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.Settooltips', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.Settooltips', 0 + +@@e_signature: end; Ftooltips.Text := Value.Text; DesembleTooltips; Change; end; -procedure TKOLToolbar.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var RsrcFile, RsrcName: String; +procedure TKOLToolbar.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +var + RsrcFile, RsrcName: string; {$IFDEF _D2009orHigher} - C, C2: WideString; - S, B: WideString; - Z : integer; + C, C2: WideString; + S, B: WideString; + Z: integer; {$ELSE} - S, B: String; + S, B: string; {$ENDIF} - I, J, K, W, H, N, I0: Integer; - Bmp: TBitmap; - Bt, Bt1: TKOLToolbarButton; - Btn1st: Integer; - KF: TKOLForm; - {$IFDEF not_economy_code_size} - TipsList: TStringList; - {$ENDIF} - Buttons_Count: Integer; - Images_Count: Integer; - Buttons_List: String; - ImageIndexes_List: String; + I, J, K, W, H, N, I0: Integer; + Bmp: TBitmap; + Bt, Bt1: TKOLToolbarButton; + Btn1st: Integer; + Buttons_Count: Integer; + Images_Count: Integer; + Buttons_List: string; + ImageIndexes_List: string; /////////////////////////////////// - function IndexOfBeginLine: Integer; - var i: Integer; - begin - for i := 0 to SL.Count-1 do - begin - if SL[i] = 'begin' then - begin - Result := i; - Exit; - end; - end; - Result := 1; - end; ////////////////////////////// + + function IndexOfBeginLine: Integer; + var + i: Integer; + begin + for i := 0 to SL.Count - 1 do begin + if SL[i] = 'begin' then begin + Result := i; + Exit; + end; + end; + Result := 1; + end; ////////////////////////////// + + + begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.SetupFirst', 0 + +@@e_signature: end; - KF := ParentKOLForm; RsrcName := ''; H := MaxBtnImgHeight; W := MaxBtnImgWidth; - if W * H > 0 then - begin - RsrcName := UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + IntToStr( FResBmpID ); - RsrcFile := ParentKOLForm.FormName + '_' + Name; - (SL as TFormStringList).OnAdd := nil; - SL.Add( Prefix + ' {$R ' + RsrcFile + '.res}' ); - if KF <> nil then - (SL as TFormStringList).OnAdd := KF.DoFlushFormCompact; - Bmp := TBitmap.Create; - TRY - N := 0; - FBmpTranColor := clNone; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.HasPicture then - begin - if FBmpTranColor = clNone then - begin - Bmp.Assign( Bt.picture ); - FBmpTranColor := Bmp.Canvas.Pixels[ 0, Bmp.Height - 1 ]; - end; - Inc( N ); + if W * H > 0 then begin + RsrcName := UpperCase(ParentKOLForm.FormName) + '_TBBMP' + IntToStr(FResBmpID); + RsrcFile := ParentKOLForm.FormName + '_' + Name; + (SL as TFormStringList).OnAdd := nil; + SL.Add(Prefix + ' {$R ' + RsrcFile + '.res}'); + Bmp := TBitmap.Create; + try + N := 0; + FBmpTranColor := clNone; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.HasPicture then begin + if FBmpTranColor = clNone then begin + Bmp.Assign(Bt.picture); + FBmpTranColor := Bmp.Canvas.Pixels[0, Bmp.Height - 1]; end; + Inc(N); end; - Bmp.Width := N * W; - Bmp.Height := H; - Bmp.PixelFormat := pf24bit; - if FBmpTranColor <> clNone then - begin - Bmp.Canvas.Brush.Color := FBmpTranColor; - Bmp.Canvas.FillRect( Rect( 0, 0, Bmp.Width, Bmp.Height ) ); + end; + Bmp.Width := N * W; + Bmp.Height := H; + Bmp.PixelFormat := pf24bit; + if FBmpTranColor <> clNone then begin + Bmp.Canvas.Brush.Color := FBmpTranColor; + Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height)); + end; + N := 0; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.HasPicture then begin + Bmp.Canvas.Draw(N * W, 0, Bt.picture.Graphic); + Inc(N); end; - N := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.HasPicture then - begin - Bmp.Canvas.Draw( N * W, 0, Bt.picture.Graphic ); - Inc( N ); - end; - end; - GenerateBitmapResource( Bmp, RsrcName, RsrcFile, fUpdated, - AllowBitmapCompression ); - FINALLY - Bmp.Free; - END; + end; + GenerateBitmapResource(Bmp, RsrcName, RsrcFile, fUpdated, AllowBitmapCompression); + finally + Bmp.Free; + end; end; - if HeightAuto then - begin + if HeightAuto then begin + DefaultHeight := Height; + DefaultWidth := Width; + end + else begin + if Align in [caTop, caBottom, caNone] then begin + DefaultHeight := 22; + DefaultWidth := Width; + end + else if Align in [caLeft, caRight] then begin + DefaultHeight := Height; + DefaultWidth := 44; + end + else begin DefaultHeight := Height; DefaultWidth := Width; - end - else - begin - if Align in [ caTop, caBottom, caNone ] then - begin - DefaultHeight := 22; - DefaultWidth := Width; - end else - if Align in [ caLeft, caRight ] then - begin - DefaultHeight := Height; - DefaultWidth := 44; - end else - begin - DefaultHeight := Height; - DefaultWidth := Width; - end; + end; end; inherited; ////////////////////////////////////////////////////////////////// - if AutosizeButtons then - SL.Add( ' ' + Prefix + AName + '.TBAutoSizeButtons := TRUE;' ); + if AutosizeButtons then + SL.Add(' ' + Prefix + AName + '.TBAutoSizeButtons := TRUE;'); - if Assigned( bitmap ) and (bitmap.Width * bitmap.Height > 0) then - begin - W := MaxBtnImgWidth; - H := MaxBtnImgHeight; - if (W <> H) or (StandardImagesUsed > 0) then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetTBBtnImgWidth', '' ); - KF.FormAddNumParameter( W ); - end else - SL.Add( ' ' + Prefix + AName + '.TBBtnImgWidth := ' + IntToStr( W ) + ';' ); + if Assigned(bitmap) and (bitmap.Width * bitmap.Height > 0) then begin + W := MaxBtnImgWidth; + H := MaxBtnImgHeight; + if (W <> H) or (StandardImagesUsed > 0) then begin + SL.Add(' ' + Prefix + AName + '.TBBtnImgWidth := ' + IntToStr(W) + ';'); - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormTBAddBitmap', '' ); - KF.FormAddNumParameter( Integer(mapBitmapColors) ); - KF.FormAddStrParameter( RsrcName ); - if mapBitmapColors then - KF.FormAddNumParameter( (FBmpTranColor shl 1) or (FBmpTranColor shr 31) ); - end - else - begin - S := ' ' + Prefix + AName + '.TBAddBitmap( '; - if mapBitmapColors then - S := S + 'LoadMappedBitmapEx( ' + AName + ', hInstance, ''' + RsrcName + ''', [ ' + - Color2Str( FBmpTranColor ) + ', Color2RGB( clBtnFace ) ] ) );' - else - S := S + 'LoadBmp( hInstance, ''' + RsrcName + ''', ' + - AName + ' ) );'; - SL.Add( S ); - end; - end; - end - else if NoSpaceForImages then - begin - SL.Add( ' ' + Prefix + AName + '.Perform( TB_SETBITMAPSIZE, 0, 16 shl 16 );' ); - end; - - if ((StandardImagesUsed > 0) and (PicturedButtonsCount > 0)) or - not IntIn(StandardImagesUsed, [ 1, 2, 4 ]) then - begin - if LongBool( StandardImagesUsed and 1 ) then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormTBAddBitmap', '' ); - if StandardImagesLarge then - KF.FormAddNumParameter( -2 ) - else - KF.FormAddNumParameter( -1 ); - end else - begin - if StandardImagesLarge then - S := '-2' - else - S := '-1'; - SL.Add( ' ' + Prefix + AName + '.TBAddBitmap( THandle( ' + S + ' ) );' ); - end; - end; - - if LongBool( StandardImagesUsed and 2 ) then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormTBAddBitmap', '' ); - if StandardImagesLarge then - KF.FormAddNumParameter( -6 ) - else - KF.FormAddNumParameter( -5 ); - end else - begin - if StandardImagesLarge then - S := '-6' - else - S := '-5'; - SL.Add( ' ' + Prefix + AName + '.TBAddBitmap( THandle( ' + S + ' ) );' ); - end; - end; - - if LongBool( StandardImagesUsed and 4 ) then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormTBAddBitmap', '' ); - if StandardImagesLarge then - KF.FormAddNumParameter( -10 ) - else - KF.FormAddNumParameter( -9 ); - end else - begin - if StandardImagesLarge then - S := '-10' - else - S := '-9'; - SL.Add( ' ' + Prefix + AName + '.TBAddBitmap( THandle( ' + S + ' ) );' ); - end; - end; - end; - - if (TBButtonsWidth > 0) or AutoSizeButtons then - begin - S := '0'; - if StandardImagesUsed > 0 then + S := ' ' + Prefix + AName + '.TBAddBitmap( '; + if mapBitmapColors then + S := S + 'LoadMappedBitmapEx( ' + AName + ', hInstance, ''' + RsrcName + + ''', [ ' + Color2Str(FBmpTranColor) + ', Color2RGB( clBtnFace ) ] ) );' else - if (Bitmap.Width > 0) and (Bitmap.Height > 0) and - (FResBmpID >= 0) and (MaxBtnImgWidth = MaxBtnImgHeight) and - (StandardImagesUsed=0) then - begin - if mapBitmapColors then - S := 'LoadMappedBitmapEx( Result, hInstance, ''' + - UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + IntToStr( FResBmpID ) + ''', [ ' + - Color2Str( FBmpTranColor ) + ', Color2RGB( clBtnFace ) ] ) ' - else - S := 'LoadBmp( hInstance, PChar( ''' + - UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + IntToStr( FResBmpID ) + - ''' ), Result ) '; - end; - - - Buttons_List := ButtonCaptionsList( Buttons_Count ); - ImageIndexes_List := ButtonImgIndexesList( Images_Count ); - SL.Insert( IndexOfBeginLine, 'const ToolbarButtonsArray_' + Name + ': array[' + - '0..' + IntToStr(Buttons_Count-1) + '] of PKOLChar = (' + - Buttons_List + ');'); - SL.Insert( IndexOfBeginLine, 'const ToolbarImgIndexesArray_' + Name + ': array[' + - '0..' + IntToStr(Images_Count-1) + '] of Integer = (' + - ImageIndexes_List + ');' ); - SL.Add( ' ' + Prefix + 'ToolbarAddButtons( ' + AName + ', ' + - //'['#13#10 + - //' ' + ButtonCaptionsList + ' ],'#13#10 + - ' ToolbarButtonsArray_' + Name + ',' + - //' ' + ButtonImgIndexesList + ','#13#10 + - ' ToolbarImgIndexesArray_' + Name + ',' + - ' ' + S + ' );' ); - if AutosizeButtons then - begin - SL.Add( ' ' + Prefix + AName + '.Perform( TB_SETBUTTONSIZE, 0, ' + - IntToStr( TBButtonsWidth ) + ' or $10000' + - //' or $FFFF0000 and (' + AName + '.Perform( TB_GETBUTTONSIZE, 0, 0 ) )' + - ' );' ); - end; + S := S + 'LoadBmp( hInstance, ''' + RsrcName + ''', ' + AName + ' ) );'; + SL.Add(S); + end; + end + else if NoSpaceForImages then begin + SL.Add(' ' + Prefix + AName + '.Perform( TB_SETBITMAPSIZE, 0, 16 shl 16 );'); end; - if showTooltips or (tooltips.Count > 0) then - begin - {$IFDEF not_economy_code_size} - if (KF <> nil) and KF.FormCompact then - begin - TipsList := TStringList.Create; - TRY - J := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if (tooltips.Count > 0) and (J >= tooltips.Count) then break; + if ((StandardImagesUsed > 0) and (PicturedButtonsCount > 0)) or not IntIn(StandardImagesUsed, + [1, 2, 4]) then begin + if LongBool(StandardImagesUsed and 1) then begin + if StandardImagesLarge then + S := '-2' + else + S := '-1'; + SL.Add(' ' + Prefix + AName + '.TBAddBitmap( THandle( ' + S + ' ) );'); + end; - if Bt.Tooltip <> '' then - B := Bt.Tooltip - else - if (tooltips.Count > 0) and (tooltips[ J ] <> '') and not Bt.separator then - B := tooltips[ J ] - else - if showTooltips then - B := Bt.Caption - else - B := ''; - if Bt.Faction = nil then // {YS} добавить - begin // {YS} добавить - if not Bt.separator then // {YS} добавить - TipsList.Add( B ) - else - TipsList.Add( '' ); - //------ - end else // {YS} добавить - Inc( J ); - end; - if TipsList.Count > 0 then - begin - KF.FormAddCtlCommand( Name, 'FormTBSetTooltips' ); - KF.FormAddNumParameter( TipsList.Count ); - for I := 0 to TipsList.Count-1 do - KF.FormAddStrParameter( TipsList[I] ); - end; - FINALLY - TipsList.Free; - END; - end - else - {$ENDIF} - begin - S := ''; - J := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + if LongBool(StandardImagesUsed and 2) then begin + if StandardImagesLarge then + S := '-6' + else + S := '-5'; + SL.Add(' ' + Prefix + AName + '.TBAddBitmap( THandle( ' + S + ' ) );'); + end; + + if LongBool(StandardImagesUsed and 4) then begin + if StandardImagesLarge then + S := '-10' + else + S := '-9'; + SL.Add(' ' + Prefix + AName + '.TBAddBitmap( THandle( ' + S + ' ) );'); + end; + end; + + if (TBButtonsWidth > 0) or AutoSizeButtons then begin + S := '0'; + if StandardImagesUsed > 0 then + + else if (Bitmap.Width > 0) and (Bitmap.Height > 0) and (FResBmpID >= 0) and + (MaxBtnImgWidth = MaxBtnImgHeight) and (StandardImagesUsed = 0) then begin + if mapBitmapColors then + S := 'LoadMappedBitmapEx( Result, hInstance, ''' + UpperCase(ParentKOLForm.FormName) + + '_TBBMP' + IntToStr(FResBmpID) + ''', [ ' + Color2Str(FBmpTranColor) + + ', Color2RGB( clBtnFace ) ] ) ' + else + S := 'LoadBmp( hInstance, PChar( ''' + UpperCase(ParentKOLForm.FormName) + + '_TBBMP' + IntToStr(FResBmpID) + ''' ), Result ) '; + end; + + Buttons_List := ButtonCaptionsList(Buttons_Count); + ImageIndexes_List := ButtonImgIndexesList(Images_Count); + SL.Insert(IndexOfBeginLine, 'const ToolbarButtonsArray_' + Name + ': array[' + + '0..' + IntToStr(Buttons_Count - 1) + '] of PKOLChar = (' + Buttons_List + ');'); + SL.Insert(IndexOfBeginLine, 'const ToolbarImgIndexesArray_' + Name + + ': array[' + '0..' + IntToStr(Images_Count - 1) + '] of Integer = (' + ImageIndexes_List + ');'); + SL.Add(' ' + Prefix + 'ToolbarAddButtons( ' + AName + ', ' + //'['#13#10 + + //' ' + ButtonCaptionsList + ' ],'#13#10 + + ' ToolbarButtonsArray_' + Name + ',' + //' ' + ButtonImgIndexesList + ','#13#10 + + ' ToolbarImgIndexesArray_' + Name + ',' + ' ' + S + ' );'); + if AutosizeButtons then begin + SL.Add(' ' + Prefix + AName + '.Perform( TB_SETBUTTONSIZE, 0, ' + + IntToStr(TBButtonsWidth) + ' or $10000' + //' or $FFFF0000 and (' + AName + '.Perform( TB_GETBUTTONSIZE, 0, 0 ) )' + + ' );'); + end; + end; + + if showTooltips or (tooltips.Count > 0) then begin + S := ''; + J := 0; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; //if Bt.Faction <> nil then continue; // remove by YS 7-Aug-2004 //if Bt.separator then continue; - //---------{ Maxim Pushkar }---------------------------------------------- //if (tooltips.Count > 0) and (J > tooltips.Count) then break; //----------------------------------------------------------------------// - if (tooltips.Count > 0) and (J >= tooltips.Count) then break; // + if (tooltips.Count > 0) and (J >= tooltips.Count) then + break; // //--------------------------------------------------------------------// - if Bt.Tooltip <> '' then - B := Bt.Tooltip - else - if (tooltips.Count > 0) and (tooltips[ J ] <> '') and not Bt.separator then - B := tooltips[ J ] - else - if showTooltips then - B := Bt.Caption - else - B := ''; - if Bt.Faction = nil then // {YS} добавить - begin // {YS} добавить - if not Bt.separator then // {YS} добавить - begin - if S <> '' then - S := S + ', '; + if Bt.Tooltip <> '' then + B := Bt.Tooltip + else if (tooltips.Count > 0) and (tooltips[J] <> '') and not Bt.separator then + B := tooltips[J] + else if showTooltips then + B := Bt.Caption + else + B := ''; + if Bt.Faction = nil then // {YS} добавить + begin // {YS} добавить + if not Bt.separator then // {YS} добавить + begin + if S <> '' then + S := S + ', '; {$IFDEF _D2009orHigher} - C2 := ''; - C := StringConstant( Bt.Name + '_tip', B ); - for Z := 2 to Length(C) - 1 do - C2 := C2 + '#'+int2str(ord(C[Z])); - S := S + C2; + C2 := ''; + C := StringConstant(Bt.Name + '_tip', B); + for Z := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[Z])); + S := S + C2; {$ELSE} - S := S + PCharStringConstant( Self, Bt.Name + '_tip', B ); + S := S + PCharStringConstant(Self, Bt.Name + '_tip', B); {$ENDIF} - end else + end + else //+++++++ v1.94 - begin - if S <> '' then - S := S + ', ''''' - else - S := S + ''''''; - end; + begin + if S <> '' then + S := S + ', ''''' + else + S := S + ''''''; + end; //------ - end else // {YS} добавить - Inc( J ); - end; + end + else // {YS} добавить + Inc(J); + end; // change by Alexander Pravdin (to fix tooltips for case of first separator): //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - Btn1st := 0; + Btn1st := 0; {for i := 0 to ButtonCount - 1 do if not TKOLToolbarButton( FItems.Items[i] ).Fseparator then begin Btn1st := i; Break; end;} - if S <> '' then - begin - SL.Add( Prefix + ' {$IFDEF USE_GRUSH}' ); - SL.Add( Prefix + ' ToolbarSetTooltips( ' + AName + ', ' + - AName + '.TBIndex2Item( ' + IntToStr( Btn1st ) + ' ), [ ' + S + ' ] );' ); - SL.Add( Prefix + ' {$ELSE}' ); - SL.Add( Prefix + ' ' + AName + '.TBSetTooltips( ' + AName + - '.TBIndex2Item( ' + IntToStr( Btn1st ) + ' ), [ ' + S + ' ] );' ); - SL.Add( Prefix + ' {$ENDIF}' ); - end; + if S <> '' then begin + SL.Add(Prefix + ' {$IFDEF USE_GRUSH}'); + SL.Add(Prefix + ' ToolbarSetTooltips( ' + AName + ', ' + AName + + '.TBIndex2Item( ' + IntToStr(Btn1st) + ' ), [ ' + S + ' ] );'); + SL.Add(Prefix + ' {$ELSE}'); + SL.Add(Prefix + ' ' + AName + '.TBSetTooltips( ' + AName + + '.TBIndex2Item( ' + IntToStr(Btn1st) + ' ), [ ' + S + ' ] );'); + SL.Add(Prefix + ' {$ENDIF}'); + end; //-------------------------------------------------------------------------- - end; end; // assign image list if used: - if ImageListNormal <> nil then - begin - SL.Add( Prefix + ' ' + AName + '.Perform( TB_SETIMAGELIST, 0, Result.' + - ImageListNormal.Name + '.Handle );' ); + if ImageListNormal <> nil then begin + SL.Add(Prefix + ' ' + AName + '.Perform( TB_SETIMAGELIST, 0, Result.' + + ImageListNormal.Name + '.Handle );'); end; - if ImageListDisabled <> nil then - begin - SL.Add( Prefix + ' ' + AName + '.Perform( TB_SETDISABLEDIMAGELIST, 0, Result.' + - ImageListDisabled.Name + '.Handle );' ); + if ImageListDisabled <> nil then begin + SL.Add(Prefix + ' ' + AName + + '.Perform( TB_SETDISABLEDIMAGELIST, 0, Result.' + ImageListDisabled.Name + '.Handle );'); end; - if ImageListHot <> nil then - begin - SL.Add( Prefix + ' ' + AName + '.Perform( TB_SETHOTIMAGELIST, 0, Result.' + - ImageListHot.Name + '.Handle );' ); + if ImageListHot <> nil then begin + SL.Add(Prefix + ' ' + AName + '.Perform( TB_SETHOTIMAGELIST, 0, Result.' + + ImageListHot.Name + '.Handle );'); end; I0 := -1; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - Inc( I0 ); + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + Inc(I0); //if Bt.separator then Continue; - if Bt.fOnClickMethodName <> '' then - begin - S := ''; - for J := I to Items.Count - 1 do - begin - Bt := Items[ J ]; + if Bt.fOnClickMethodName <> '' then begin + S := ''; + for J := I to Items.Count - 1 do begin + Bt := Items[J]; //if Bt.separator then Continue; - if Bt.separator or (Bt.fOnClickMethodName = '') then - begin - N := 0; - for K := J to Items.Count-1 do - begin - Bt1 := Items[ K ]; - if Bt1.separator then Continue; - if Bt1.fOnClickMethodName <> '' then - begin - Inc( N ); - break; - end; - end; - if N = 0 then break; - end; - if S <> '' then S := S + ', '; - if Bt.fOnClickMethodName <> '' then - S := S + 'Result.' + Bt.fOnClickMethodName - else - S := S + 'nil'; + if Bt.separator or (Bt.fOnClickMethodName = '') then begin + N := 0; + for K := J to Items.Count - 1 do begin + Bt1 := Items[K]; + if Bt1.separator then + Continue; + if Bt1.fOnClickMethodName <> '' then begin + Inc(N); + break; + end; end; - SL.Add( ' ' + Prefix + AName + '.TBAssignEvents( ' + IntToStr( I0 ) + - ', [ ' + S + ' ] );' ); - break; + if N = 0 then + break; + end; + if S <> '' then + S := S + ', '; + if Bt.fOnClickMethodName <> '' then + S := S + 'Result.' + Bt.fOnClickMethodName + else + S := S + 'nil'; end; + SL.Add(' ' + Prefix + AName + '.TBAssignEvents( ' + IntToStr(I0) + ', [ ' + S + ' ] );'); + break; + end; end; - if TBButtonsMinWidth > 0 then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetTBButtonsMinWidth', '' ); - KF.FormAddNumParameter( TBButtonsMinWidth ); - end else - SL.Add( Prefix + AName + '.TBButtonsMinWidth := ' + IntToStr( TBButtonsMinWidth ) + ';' ); + if TBButtonsMinWidth > 0 then + SL.Add(Prefix + AName + '.TBButtonsMinWidth := ' + IntToStr(TBButtonsMinWidth) + ';'); - if TBButtonsMaxWidth > 0 then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetTBButtonsMaxWidth', '' ); - KF.FormAddNumParameter( TBButtonsMaxWidth ); - end else - SL.Add( Prefix + AName + '.TBButtonsMaxWidth := ' + IntToStr( TBButtonsMaxWidth ) + ';' ); + if TBButtonsMaxWidth > 0 then + SL.Add(Prefix + AName + '.TBButtonsMaxWidth := ' + IntToStr(TBButtonsMaxWidth) + ';'); - for I := Items.Count-1 downto 0 do - begin - Bt := Items[ I ]; - if not Bt.visible and (Bt.Faction = nil) then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormHideToolbarButton', '' ); - KF.FormAddNumParameter( I ); - end - else - begin - SL.Add( Prefix + '{$IFDEF USE_GRUSH}' ); - SL.Add( Prefix + 'ShowHideToolbarButton( ' + AName + ', ' + IntToStr( I ) + ', FALSE );' ); - SL.Add( Prefix + '{$ELSE}' ); - SL.Add( Prefix + AName + '.TBButtonVisible[ ' + IntToStr( I ) + ' ] := FALSE;' ); - SL.Add( Prefix + '{$ENDIF}' ); - end; - end; + for I := Items.Count - 1 downto 0 do begin + Bt := Items[I]; + if not Bt.visible and (Bt.Faction = nil) then begin + SL.Add(Prefix + '{$IFDEF USE_GRUSH}'); + SL.Add(Prefix + 'ShowHideToolbarButton( ' + AName + ', ' + IntToStr(I) + ', FALSE );'); + SL.Add(Prefix + '{$ELSE}'); + SL.Add(Prefix + AName + '.TBButtonVisible[ ' + IntToStr(I) + ' ] := FALSE;'); + SL.Add(Prefix + '{$ENDIF}'); + end; - if not Bt.enabled and (Bt.Faction = nil) then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormDisableToolbarButton', '' ); - KF.FormAddNumParameter( I ); - end - else - begin - SL.Add( Prefix + '{$IFDEF USE_GRUSH}' ); - SL.Add( Prefix + 'EnableToolbarButton( ' + AName + ', ' + IntToStr( I ) + ', FALSE );' ); - SL.Add( Prefix + '{$ELSE}' ); - SL.Add( Prefix + AName + '.TBButtonEnabled[ ' + IntToStr( I ) + ' ] := FALSE;' ); - SL.Add( Prefix + '{$ENDIF}' ); - end; - end; + if not Bt.enabled and (Bt.Faction = nil) then begin + SL.Add(Prefix + '{$IFDEF USE_GRUSH}'); + SL.Add(Prefix + 'EnableToolbarButton( ' + AName + ', ' + IntToStr(I) + ', FALSE );'); + SL.Add(Prefix + '{$ELSE}'); + SL.Add(Prefix + AName + '.TBButtonEnabled[ ' + IntToStr(I) + ' ] := FALSE;'); + SL.Add(Prefix + '{$ENDIF}'); + end; end; - if not Assigned( OnTBCustomDraw ) and - (tboCustomErase in Options) OR - FixFlatXP and (tboFlat in Options) then - if (KF <> nil) and KF.FormCompact then - KF.FormAddCtlCommand( Name, 'FormFixFlatXPToolbar', '' ) - else - SL.Add( Prefix + AName + '.OnTBCustomDraw := nil;' ); + if not Assigned(OnTBCustomDraw) and (tboCustomErase in Options) or FixFlatXP and (tboFlat in Options) then + SL.Add(Prefix + AName + '.OnTBCustomDraw := nil;'); end; -function TKOLToolbar.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLToolbar.SetupParams(const AName, AParent: TDelphiString): TDelphiString; var {$IFDEF _D2009orHigher} //C: WideString; - S, A: WideString; + S, A: WideString; //B: WideString; {$ELSE} - S, A: String; + S, A: string; {$ENDIF} - Buttons_Count: Integer; - Images_Count: Integer; + Buttons_Count: Integer; + Images_Count: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.SetupParams', 0 + +@@e_signature: end; // 1. Options parameter S := ''; - if (tboTextRight in Options) or - FixFlatXP and {(Align in [caLeft, caRight]) and} (tboFlat in Options) then + if (tboTextRight in Options) or FixFlatXP and + {(Align in [caLeft, caRight]) and} (tboFlat in Options) then S := 'tboTextRight'; if (tboTextBottom in Options) and (S = '') then S := S + ', tboTextBottom'; @@ -12442,9 +9743,8 @@ begin S := S + ', tboFlat'; if tboTransparent in Options then S := S + ', tboTransparent'; - if (tboWrapable in Options) and not( FixFlatXP and (Align in [caLeft, caRight]) and - (tboFlat in Options) ) - {or + if (tboWrapable in Options) and not (FixFlatXP and (Align in [caLeft, caRight]) + and (tboFlat in Options)) {or ( (tboFlat in Options) and not (Align in [caLeft, caRight] ) and FixFlatXP )} then S := S + ', tboWrapable'; if tboNoDivider in Options then @@ -12454,87 +9754,87 @@ begin if tboCustomErase in Options then S := S + ', tboCustomErase'; if S <> '' then - if S[ 1 ] = ',' then - S := Trim( Copy( S, 2, MaxInt ) ); + if S[1] = ',' then + S := Trim(Copy(S, 2, MaxInt)); // 2. Align parameter case Align of - caLeft: A := 'caLeft'; - caRight:A := 'caRight'; - caClient: A := 'caClient'; - caTop: A := 'caTop'; - caBottom: A := 'caBottom'; - else A := 'caNone'; + caLeft: + A := 'caLeft'; + caRight: + A := 'caRight'; + caClient: + A := 'caClient'; + caTop: + A := 'caTop'; + caBottom: + A := 'caBottom'; + else + A := 'caNone'; end; Result := AParent + ', ' + A + ', [' + S + '], '; // 3. Bitmap from a resource - if (Bitmap.Width > 0) and (Bitmap.Height > 0) and - (FResBmpID >= 0) and (MaxBtnImgWidth = MaxBtnImgHeight) and - (StandardImagesUsed=0) then - begin + if (Bitmap.Width > 0) and (Bitmap.Height > 0) and (FResBmpID >= 0) and (MaxBtnImgWidth + = MaxBtnImgHeight) and (StandardImagesUsed = 0) then begin if mapBitmapColors then - Result := Result + 'LoadMappedBitmapEx( Result, hInstance, ''' + - UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + IntToStr( FResBmpID ) + ''', [ ' + - Color2Str( FBmpTranColor ) + ', Color2RGB( clBtnFace ) ] ), ' + Result := Result + 'LoadMappedBitmapEx( Result, hInstance, ''' + UpperCase + (ParentKOLForm.FormName) + '_TBBMP' + IntToStr(FResBmpID) + ''', [ ' + + Color2Str(FBmpTranColor) + ', Color2RGB( clBtnFace ) ] ), ' else - Result := Result + 'LoadBmp( hInstance, PChar( ''' + - UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + IntToStr( FResBmpID ) + - ''' ), Result ), '; + Result := Result + 'LoadBmp( hInstance, PChar( ''' + UpperCase(ParentKOLForm.FormName) + + '_TBBMP' + IntToStr(FResBmpID) + ''' ), Result ), '; end - else // or if standard images are used, type of images here - if (PicturedButtonsCount = 0) and (IntIn( StandardImagesUsed, [ 1, 2, 4 ] )) then - begin + else // or if standard images are used, type of images here +if (PicturedButtonsCount = 0) and (IntIn(StandardImagesUsed, [1, 2, 4])) then begin if StandardImagesUsed = 1 then if StandardImagesLarge then Result := Result + 'THandle( -2 ), ' else Result := Result + 'THandle( -1 ), ' - else - if StandardImagesUsed = 2 then + else if StandardImagesUsed = 2 then if StandardImagesLarge then Result := Result + 'THandle( -6 ), ' else Result := Result + 'THandle( -5 ), ' + else if StandardImagesLarge then + Result := Result + 'THandle( -10 ), ' else - if StandardImagesLarge then - Result := Result + 'THandle( -10 ), ' - else - Result := Result + 'THandle( -9 ), '; + Result := Result + 'THandle( -9 ), '; end - else - begin // or if Bitmap is empty, value 0 - if not ((Bitmap.Width > 0) and (Bitmap.Height > 0) and - (FResBmpID >= 0)) then + else begin // or if Bitmap is empty, value 0 + if not ((Bitmap.Width > 0) and (Bitmap.Height > 0) and (FResBmpID >= 0)) then FResBmpID := 0; Result := Result + '0, '; end; // 4. Button captions Result := Result + '[ '; - if (TBButtonsWidth = 0) and not AutoSizeButtons then - Result := Result + ButtonCaptionsList( Buttons_Count ); + if (TBButtonsWidth = 0) and not AutoSizeButtons then + Result := Result + ButtonCaptionsList(Buttons_Count); Result := Result + ' ], '; // 5. Button image indexes used - if (TBButtonsWidth = 0) and not AutosizeButtons then - Result := Result + '[ ' + ButtonImgIndexesList( Images_Count ) + ' ] ' + if (TBButtonsWidth = 0) and not AutosizeButtons then + Result := Result + '[ ' + ButtonImgIndexesList(Images_Count) + ' ] ' else - Result := Result + '[]'; + Result := Result + '[]'; //Rpt( '$$$$$$$$$$$$$$$ PicturedButtonsCount := ' + IntToStr( PicturedButtonsCount ) ); end; -var LastToolbarWarningtime: Integer; +var + LastToolbarWarningtime: Integer; + procedure ToolbarBetterToPlaceOverPanelWarning; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'ToolbarBetterToPlaceOverPanelWarning', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'ToolbarBetterToPlaceOverPanelWarning', 0 + +@@e_signature: end; - if Abs( Integer( GetTickCount ) - LastToolbarWarningtime ) > 60000 then - begin + if Abs(Integer(GetTickCount) - LastToolbarWarningtime) > 60000 then begin LastToolbarWarningtime := GetTickCount; {ShowMessage( 'It is better to place toolbar on a panel aligning it caClient.'#13 + 'This can improve performance of the application, especially in ' + @@ -12543,48 +9843,47 @@ begin end; function TKOLToolbar.StandardImagesUsed: Integer; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin Result := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.sysimg <> stiCustom then - begin - if Bt.sysimg in [ stdCUT..stdPRINT ] then + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.sysimg <> stiCustom then begin + if Bt.sysimg in [stdCUT..stdPRINT] then Result := Result or 1 - else - if Bt.sysimg in [ viewLARGEICONS..viewVIEWMENU ] then + else if Bt.sysimg in [viewLARGEICONS..viewVIEWMENU] then Result := Result or 2 else Result := Result or 4; - if Result = 7 then break; + if Result = 7 then + break; end; end; end; procedure TKOLToolbar.Tick(Sender: TObject); -var KF: TKOLForm; +var + KF: TKOLForm; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.Tick', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.Tick', 0 + +@@e_signature: end; - if Parent <> nil then - begin + if Parent <> nil then begin FTimer.Enabled := FALSE; if Parent = Owner then ToolbarBetterToPlaceOverPanelWarning; if Parent is TKOLCustomControl then - (Parent as TKOLCustomControl).ReAlign( FALSE ) - else - begin + (Parent as TKOLCustomControl).ReAlign(FALSE) + else begin KF := ParentKOLForm; if KF <> nil then - KF.AlignChildren( nil, FALSE ); + KF.AlignChildren(nil, FALSE); end; FTimer.Free; FTimer := nil; @@ -12598,10 +9897,10 @@ end; procedure TKOLToolbar.WriteNewVersion(Writer: TWriter); begin - Writer.WriteBoolean( fNewVersion ); + Writer.WriteBoolean(fNewVersion); end; -function TKOLToolbar.Generate_SetSize: String; +function TKOLToolbar.Generate_SetSize: string; begin Result := inherited Generate_SetSize; end; @@ -12617,31 +9916,30 @@ var al: kol.TControlAlign; bmp: HBITMAP; begin - Log( '->TKOLToolbar.CreateKOLControl' ); - Log( 'recreating: ' + IntToStr( Integer( Recreating ) ) ); - TRY + Log('->TKOLToolbar.CreateKOLControl'); + Log('recreating: ' + IntToStr(Integer(Recreating))); + try inherited; if Recreating then begin - al:=kol.TControlAlign(Align); + al := kol.TControlAlign(Align); bmp := 0; end else begin - al:=kol.caTop; - bmp:=0; + al := kol.caTop; + bmp := 0; end; - TRY - FKOLCtrl:=NewToolbar(KOLParentCtrl, al, kol.TToolbarOptions(FOptions), bmp, [nil], [-2]); - FKOLCtrl.Visible:=False; - EXCEPT - on E: Exception do - begin - ShowMessage( 'Error: ' + E.Message ); + try + FKOLCtrl := NewToolbar(KOLParentCtrl, al, kol.TToolbarOptions(FOptions), bmp, [nil], [-2]); + FKOLCtrl.Visible := False; + except + on E: Exception do begin + ShowMessage('Error: ' + E.Message); end; - END; + end; LogOK; - FINALLY - Log( '->TKOLToolbar.CreateKOLControl' ); - END; + finally + Log('->TKOLToolbar.CreateKOLControl'); + end; end; procedure TKOLToolbar.KOLControlRecreated; @@ -12650,66 +9948,61 @@ var TmpBmp, TmpBmp2: TBitmap; begin inherited; - if ImageListsUsed then - begin + if ImageListsUsed then begin if ImageListNormal <> nil then - FKOLCtrl.Perform( TB_SETIMAGELIST, 0, ImageListNormal.Handle ); + FKOLCtrl.Perform(TB_SETIMAGELIST, 0, ImageListNormal.Handle); if ImageListDisabled <> nil then - FKOLCtrl.Perform( TB_SETDISABLEDIMAGELIST, 0, ImageListDisabled.Handle ); + FKOLCtrl.Perform(TB_SETDISABLEDIMAGELIST, 0, ImageListDisabled.Handle); if ImageListHot <> nil then - FKOLCtrl.Perform( TB_SETHOTIMAGELIST, 0, ImageListHot.Handle ); + FKOLCtrl.Perform(TB_SETHOTIMAGELIST, 0, ImageListHot.Handle); end - else - begin + else begin if StandardImagesUsed > 0 then begin if StandardImagesLarge then - N:=1 + N := 1 else - N:=0; - FKOLCtrl.TBAddBitmap(HBITMAP(-1-N)); - FKOLCtrl.TBAddBitmap(HBITMAP(-5-N)); - FKOLCtrl.TBAddBitmap(HBITMAP(-9-N)); + N := 0; + FKOLCtrl.TBAddBitmap(HBITMAP(-1 - N)); + FKOLCtrl.TBAddBitmap(HBITMAP(-5 - N)); + FKOLCtrl.TBAddBitmap(HBITMAP(-9 - N)); end; - if (Bitmap <> nil) and not Bitmap.Empty then - begin - if mapBitmapColors then - begin + if (Bitmap <> nil) and not Bitmap.Empty then begin + if mapBitmapColors then begin TmpBmp := TBitmap.Create; - TRY + try TmpBmp.Canvas.Brush.Color := clBtnFace; TmpBmp.Width := Bitmap.Width; TmpBmp.Height := Bitmap.Height; Bitmap.Transparent := TRUE; //Bitmap.TransparentColor := Bitmap.Canvas.Pixels[ 0, Bitmap.Height-1 ]; - TmpBmp.Canvas.Draw( 0, 0, Bitmap ); + TmpBmp.Canvas.Draw(0, 0, Bitmap); Bitmap.Transparent := FALSE; FBmpDesign := TmpBmp.ReleaseHandle; - FINALLY + finally TmpBmp.Free; - END; + end; end - else - begin - FBmpDesign := CopyImage( Bitmap.Handle, IMAGE_BITMAP, 0, 0, LR_CREATEDIBSECTION ); + else begin + FBmpDesign := CopyImage(Bitmap.Handle, IMAGE_BITMAP, 0, 0, LR_CREATEDIBSECTION); end; if mapBitmapColors then begin TmpBmp := TBitmap.Create; TmpBmp2 := TBitmap.Create; - TRY + try TmpBmp.Handle := FBmpDesign; TmpBmp2.Canvas.Brush.Color := clBtnFace; TmpBmp2.Width := TmpBmp.Width; TmpBmp2.Height := TmpBmp.Height; TmpBmp.Transparent := TRUE; - TmpBmp2.Canvas.Draw( 0, 0, TmpBmp ); + TmpBmp2.Canvas.Draw(0, 0, TmpBmp); FBmpDesign := TmpBmp2.ReleaseHandle; - FINALLY + finally TmpBmp.Free; TmpBmp2.Free; - END; + end; end; - FKOLCtrl.TBAddBitmap( FBmpDesign ); + FKOLCtrl.TBAddBitmap(FBmpDesign); end; end; UpdateButtons; @@ -12723,14 +10016,16 @@ end; procedure TKOLToolbar.UpdateButtons; - procedure GenerateButtons{(var Captions: array of string; var PCaptions: array of PChar; var ImgIndices: array of integer)}; + procedure GenerateButtons + {(var Captions: array of string; var PCaptions: array of PChar; var ImgIndices: array of integer)}; var i, N, StdImagesStart, ViewImagesStart, HistImagesStart: integer; s: string; ii: Integer; Bt: TKOLToolbarButton; begin - if FItems.Count = 0 then exit; + if FItems.Count = 0 then + exit; {if PicturedButtonsCount > 0 then N := FItems.Count else @@ -12740,44 +10035,42 @@ procedure TKOLToolbar.UpdateButtons; HistImagesStart := 15 + 12; N := 0; if StandardImagesUsed > 0 then - N := 15 + 12 + 5; - for i:=0 to FItems.Count - 1 do + N := 15 + 12 + 5; + for i := 0 to FItems.Count - 1 do with TKOLToolbarButton(FItems[i]) do begin if noTextLabels then - s:=' ' + s := ' ' else - s:=caption; + s := caption; if checked then - S := '+' + S - else - if radioGroup <> 0 then - S := '-' + S; + s := '+' + s + else if radioGroup <> 0 then + s := '-' + s; if dropdown then - S := '^' + S; + s := '^' + s; {Captions[i]:=s; PCaptions[i]:=PChar(Captions[i]);} - Bt := Items[ i ]; - if ImageListsUsed then - begin + Bt := Items[i]; + if ImageListsUsed then begin ii := Bt.imgIndex; - if ii < 0 then ii := -2; + if ii < 0 then + ii := -2; end - else - if HasPicture then begin - ii {ImgIndices[i]} := N + i; + else if HasPicture then begin + ii {ImgIndices[i]} := N + i; end else case sysimg of stiCustom: - ii {ImgIndices[i]} := -2; // I_IMAGENONE + ii {ImgIndices[i]} := -2; // I_IMAGENONE stdCUT..stdPRINT: - ii {ImgIndices[i]} := StdImagesStart + Ord( sysimg ) - Ord( stdCUT ); + ii {ImgIndices[i]} := StdImagesStart + Ord(sysimg) - Ord(stdCUT); viewLARGEICONS..viewVIEWMENU: - ii {ImgIndices[i]} := ViewImagesStart + Ord( sysimg ) - Ord( viewLARGEICONS ); - else - ii {ImgIndices[i]} := HistImagesStart + Ord( sysimg ) - Ord( histBACK ); + ii {ImgIndices[i]} := ViewImagesStart + Ord(sysimg) - Ord(viewLARGEICONS); + else + ii {ImgIndices[i]} := HistImagesStart + Ord(sysimg) - Ord(histBACK); end; - FKOLCtrl.TBAddButtons( [ PKOLChar( S ) ], [ ii ] ); + FKOLCtrl.TBAddButtons([PKOLChar(s)], [ii]); end; end; @@ -12786,9 +10079,9 @@ var pcapts: array of PChar; imgs: array of integer;} i: integer; - begin - if not Assigned(FKOLCtrl) then exit; + if not Assigned(FKOLCtrl) then + exit; while FKOLCtrl.TBButtonCount > 0 do FKOLCtrl.TBDeleteButton(0); @@ -12798,10 +10091,10 @@ begin SetLength(imgs, FItems.Count);} GenerateButtons{(capts, pcapts, imgs)}; //FKOLCtrl.TBAddButtons(pcapts, imgs); - for i:=0 to FItems.Count - 1 do + for i := 0 to FItems.Count - 1 do with TKOLToolbarButton(FItems[i]) do begin if not enabled then - FKOLCtrl.TBButtonEnabled[i]:=False; + FKOLCtrl.TBButtonEnabled[i] := False; end; end; end; @@ -12810,7 +10103,7 @@ procedure TKOLToolbar.SetMargin(const Value: Integer); begin inherited; if Assigned(FKOLCtrl) then - FKOLCtrl.Perform( TB_SETINDENT, Border, 0 ); + FKOLCtrl.Perform(TB_SETINDENT, Border, 0); end; procedure TKOLToolbar.CMDesignHitTest(var Message: TCMDesignHitTest); @@ -12819,11 +10112,11 @@ var res: integer; begin if Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames]) then begin - Message.Result:=0; - pt:=SmallPointToPoint(Message.Pos); - res:=FKOLCtrl.Perform(WM_USER + 69 {TB_HITTEST}, 0, integer(@pt)); + Message.Result := 0; + pt := SmallPointToPoint(Message.Pos); + res := FKOLCtrl.Perform(WM_USER + 69 {TB_HITTEST}, 0, integer(@pt)); if Abs(res) <= FKOLCtrl.TBButtonCount then - Message.Result:=1; + Message.Result := 1; end else inherited; @@ -12838,24 +10131,24 @@ var FD: IFormDesigner; begin if Assigned(FKOLCtrl) then begin - pt:=SmallPointToPoint(Message.Pos); - res:=FKOLCtrl.Perform(WM_USER + 69 {TB_HITTEST}, 0, integer(@pt)); + pt := SmallPointToPoint(Message.Pos); + res := FKOLCtrl.Perform(WM_USER + 69 {TB_HITTEST}, 0, integer(@pt)); if res < 0 then - res:=-res - 1; + res := -res - 1; if res < FItems.Count then begin F := Owner as TForm; if F <> nil then begin //*/////////////////////////////////////////////////////// {$IFDEF _D6orHigher} // - F.Designer.QueryInterface(IFormDesigner,D); // + F.Designer.QueryInterface(IFormDesigner, D); // {$ELSE} // //*/////////////////////////////////////////////////////// - D := F.Designer; + D := F.Designer; //*/////////////////////////////////////////////////////// {$ENDIF} // //*/////////////////////////////////////////////////////// - if (D <> nil) and QueryFormDesigner( D, FD ) then begin - FD.SelectComponent(TPersistent( FItems[res] ) ); + if (D <> nil) and QueryFormDesigner(D, FD) then begin + FD.SelectComponent(TPersistent(FItems[res])); end; end; end; @@ -12872,230 +10165,238 @@ procedure TKOLToolbar.WMLButtonDblClk(var Message: TWMLButtonDblClk); begin end; -procedure TKOLToolbar.Paint; +procedure TKOLToolbar.Paint; //dufa var - i: integer; - R: TRect; +// R: TRect; + I: Integer; + C: ArrayTCDTBButton; + p: TKOLToolbarButton; begin inherited; - if Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames]) then - with Canvas do begin - Brush.Style:=bsClear; - Pen.Color:=clBtnShadow; - Pen.Style:=psDot; - for i:=0 to FItems.Count - 1 do - with TKOLToolbarButton(FItems[i]) do begin - if checked or (not separator and not (tboFlat in Options)) then continue; - FKOLCtrl.Perform( TB_GETITEMRECT, i, Integer( @R ) ); - if separator then - Windows.Rectangle( Handle, R.Left, R.Top, R.Right, R.Bottom ) - else - DrawEdge(Handle, R, BDR_RAISEDINNER, BF_RECT); - end; - Pen.Style:=psSolid; - Brush.Style:=bsSolid; + if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin + PrepareCanvasFontForWYSIWIGPaint(Canvas); + // cols + SetLength(C, FItems.Count); + for I := 0 to High(C) do begin + p := TKOLToolbarButton(FItems[I]); + C[I].Caption := p.caption; + C[I].Enabled := p.enabled; + C[I].Separator := p.separator; + C[I].Checked := p.checked; + C[I].Rect := Bounds(I * {TBButtonsWidth}50, 0, {TBButtonsWidth}50, Height); end; + // draw + DrawToolbar(True, Enabled, Canvas.Handle, ClientRect, C); +// with Canvas do begin +// Brush.Style := bsClear; +// Pen.Color := clBtnShadow; +// Pen.Style := psDot; +// for i := 0 to FItems.Count - 1 do begin +// with TKOLToolbarButton(FItems[i]) do begin +// if checked or (not separator and not (tboFlat in Options)) then continue; +// FKOLCtrl.Perform( TB_GETITEMRECT, i, Integer( @R ) ); +// if separator then +// Windows.Rectangle( Handle, R.Left, R.Top, R.Right, R.Bottom ) +// else +// DrawEdge(Handle, R, BDR_RAISEDINNER, BF_RECT); +// end; +// end; +// Pen.Style := psSolid; +// Brush.Style := bsSolid; +// end; + end; + //inherited; end; function TKOLToolbar.GetDefaultControlFont: HFONT; begin - Result:=GetStockObject(DEFAULT_GUI_FONT); + Result := GetStockObject(DEFAULT_GUI_FONT); end; procedure TKOLToolbar.SetimageList(const Value: TKOLImageList); + procedure RemoveOldImageList; begin if FImageListNormal <> nil then - FImageListNormal.NotifyLinkedComponent( Self, noRemoved ); + FImageListNormal.NotifyLinkedComponent(Self, noRemoved); FImageListNormal := nil; end; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin - if (Value <> nil) and (Value is TKOLImageList) then - begin - if ImagedButtonsCount > 0 then - begin - I := MessageBox( Application.Handle, 'Some buttons have pictures assigned.'#13#10 + - 'All pictures will be removed. Continue assigning image list to a toolbar?', - PChar( Application.Title + ' : ' + Name ), MB_OKCANCEL ); - if I <> ID_OK then Exit; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + if (Value <> nil) and (Value is TKOLImageList) then begin + if ImagedButtonsCount > 0 then begin + I := MessageBox(Application.Handle, + 'Some buttons have pictures assigned.'#13#10 + 'All pictures will be removed. Continue assigning image list to a toolbar?', + PChar(Application.Title + ' : ' + Name), MB_OKCANCEL); + if I <> ID_OK then + Exit; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.HasPicture then Bt.picture := nil - else - if Bt.sysimg <> stiCustom then + else if Bt.sysimg <> stiCustom then Bt.sysimg := stiCustom; if Bt.Fseparator then Bt.FimgIndex := -1; end; end; RemoveOldImageList; - Value.AddToNotifyList( Self ); + Value.AddToNotifyList(Self); end - else + else RemoveOldImageList; FImageListNormal := Value; if Value <> nil then - if FKOLCtrl <> nil then - begin + if FKOLCtrl <> nil then begin //ShowMessage( 'ImageListNormal.Handle=' + IntToStr( Value.Handle ) ); - FKOLCtrl.Perform( TB_SETIMAGELIST, 0, FImageListNormal.Handle ); - UpdateButtons; - end; + FKOLCtrl.Perform(TB_SETIMAGELIST, 0, FImageListNormal.Handle); + UpdateButtons; + end; Change; end; -procedure TKOLToolbar.NotifyLinkedComponent(Sender: TObject; - Operation: TNotifyOperation); +procedure TKOLToolbar.NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLBitBtn.NotifyLinkedComponent', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLBitBtn.NotifyLinkedComponent', 0 + +@@e_signature: end; inherited; - if Operation = noRemoved then - begin + if Operation = noRemoved then begin if Sender = ImageListNormal then ImageListNormal := nil - else - if Sender = ImageListDisabled then + else if Sender = ImageListDisabled then ImageListDisabled := nil - else - if Sender = ImageListHot then + else if Sender = ImageListHot then ImageListHot := nil else - ShowMessage( 'Could not remove a reference to image list !' ); + ShowMessage('Could not remove a reference to image list !'); end; end; function TKOLToolbar.ImagedButtonsCount: Integer; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin Result := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.HasPicture or (Bt.sysimg <> stiCustom) then - Inc( Result ); + Inc(Result); end; end; function TKOLToolbar.MaxImgIndex: Integer; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin Result := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.FimgIndex >= Result then Result := Bt.FimgIndex + 1; end; end; procedure TKOLToolbar.SetDisabledimageList(const Value: TKOLImageList); + procedure RemoveOldImageList; begin if FimageListDisabled <> nil then - FimageListDisabled.NotifyLinkedComponent( Self, noRemoved ); + FimageListDisabled.NotifyLinkedComponent(Self, noRemoved); FimageListDisabled := nil; end; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin - if (Value <> nil) and (Value is TKOLImageList) then - begin - if ImagedButtonsCount > 0 then - begin - I := MessageBox( Application.Handle, 'Some buttons have pictures assigned.'#13#10 + - 'All pictures will be removed. Continue assigning image list to a toolbar?', - PChar( Application.Title + ' : ' + Name ), MB_OKCANCEL ); - if I <> ID_OK then Exit; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + if (Value <> nil) and (Value is TKOLImageList) then begin + if ImagedButtonsCount > 0 then begin + I := MessageBox(Application.Handle, + 'Some buttons have pictures assigned.'#13#10 + 'All pictures will be removed. Continue assigning image list to a toolbar?', + PChar(Application.Title + ' : ' + Name), MB_OKCANCEL); + if I <> ID_OK then + Exit; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.HasPicture then Bt.picture := nil - else - if Bt.sysimg <> stiCustom then + else if Bt.sysimg <> stiCustom then Bt.sysimg := stiCustom; if Bt.Fseparator then Bt.FimgIndex := -1; end; end; RemoveOldImageList; - Value.AddToNotifyList( Self ); + Value.AddToNotifyList(Self); end - else + else RemoveOldImageList; FimageListDisabled := Value; if Value <> nil then - if FKOLCtrl <> nil then - begin - FKOLCtrl.Perform( TB_SETDISABLEDIMAGELIST, 0, FimageListDisabled.Handle ); - UpdateButtons; - end; + if FKOLCtrl <> nil then begin + FKOLCtrl.Perform(TB_SETDISABLEDIMAGELIST, 0, FimageListDisabled.Handle); + UpdateButtons; + end; Change; end; procedure TKOLToolbar.SetHotimageList(const Value: TKOLImageList); + procedure RemoveOldImageList; begin if FImageListHot <> nil then - FImageListHot.NotifyLinkedComponent( Self, noRemoved ); + FImageListHot.NotifyLinkedComponent(Self, noRemoved); FImageListHot := nil; end; -var I: Integer; - Bt: TKOLToolbarButton; +var + I: Integer; + Bt: TKOLToolbarButton; begin - if (Value <> nil) and (Value is TKOLImageList) then - begin - if ImagedButtonsCount > 0 then - begin - I := MessageBox( Application.Handle, 'Some buttons have pictures assigned.'#13#10 + - 'All pictures will be removed. Continue assigning image list to a toolbar?', - PChar( Application.Title + ' : ' + Name ), MB_OKCANCEL ); - if I <> ID_OK then Exit; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + if (Value <> nil) and (Value is TKOLImageList) then begin + if ImagedButtonsCount > 0 then begin + I := MessageBox(Application.Handle, + 'Some buttons have pictures assigned.'#13#10 + 'All pictures will be removed. Continue assigning image list to a toolbar?', + PChar(Application.Title + ' : ' + Name), MB_OKCANCEL); + if I <> ID_OK then + Exit; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; if Bt.HasPicture then Bt.picture := nil - else - if Bt.sysimg <> stiCustom then + else if Bt.sysimg <> stiCustom then Bt.sysimg := stiCustom; if Bt.Fseparator then Bt.FimgIndex := -1; end; end; RemoveOldImageList; - Value.AddToNotifyList( Self ); + Value.AddToNotifyList(Self); end - else + else RemoveOldImageList; FImageListHot := Value; if Value <> nil then - if FKOLCtrl <> nil then - begin - FKOLCtrl.Perform( TB_SETHOTIMAGELIST, 0, FimageListHot.Handle ); - UpdateButtons; - end; + if FKOLCtrl <> nil then begin + FKOLCtrl.Perform(TB_SETHOTIMAGELIST, 0, FimageListHot.Handle); + UpdateButtons; + end; Change; end; function TKOLToolbar.ImageListsUsed: Boolean; begin - Result := (ImageListNormal <> nil) or (ImageListDisabled <> nil) or - (ImageListHot <> nil); + Result := (ImageListNormal <> nil) or (ImageListDisabled <> nil) or (ImageListHot <> nil); end; procedure TKOLToolbar.SetFixFlatXP(const Value: Boolean); @@ -13118,768 +10419,62 @@ begin Change; end; -procedure TKOLToolbar.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var I: Integer; - Bt: TKOLToolbarButton; - S: String; +procedure TKOLToolbar.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); +var + I: Integer; + Bt: TKOLToolbarButton; + S: string; begin inherited; - if generateVariables then - begin - S := ''; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.separator and (Copy( Bt.Name, 1, 2 ) = 'TB') and - IsNumber( Copy( Bt.Name, 3, MaxInt ) ) then - continue; - if Bt.Name <> '' then - begin - S := S + ',' + Bt.Name; - end; - end; - if ( S <> '' ) then - begin - Delete( S, 1, 1 ); - SL.Add( ' ' + Prefix + AName + '.TBConvertIdxArray2ID( [' + S + '] );' ); - end; - end; - - if AutoSize then - SL.Add( ' ' + Prefix + AName + '.Perform( TB_AUTOSIZE, 0, 0 );' ); - -end; - -procedure TKOLToolbar.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var I, n: Integer; - Bt: TKOLToolbarButton; - S: String; -begin - inherited; - if generateVariables then - begin + if generateVariables then begin S := ''; - n := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.separator and (Copy( Bt.Name, 1, 2 ) = 'TB') and - IsNumber( Copy( Bt.Name, 3, MaxInt ) ) then - continue; - if Bt.Name <> '' then - begin - Inc( n ); - //S := S + ',' + Bt.Name; - {P}S := ' Load4 ####' + BT.Name + S; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.separator and (Copy(Bt.Name, 1, 2) = 'TB') and IsNumber(Copy(Bt.Name, 3, MaxInt)) then + continue; + if Bt.Name <> '' then begin + S := S + ',' + Bt.Name; end; end; - if ( S <> '' ) then - begin - //Delete( S, 1, 1 ); - //SL.Add( Prefix + AName + '.TBConvertIdxArray2ID( [' + S + '] );' ); - {P}SL.Add( S ); - {P}SL.Add( ' LoadStack L(' + IntToStr( n-1 ) + ') xySwap' ); - {P}SL.Add( ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name ); - {P}SL.Add( ' TControl.TBConvertIdxArray2ID<3>' ); - {P}SL.Add( ' DEL(' + IntToStr( n ) + ')' ); - end; - end; -end; - -function TKOLToolbar.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -var S: String; - B: String; - I, N, K: Integer; - Bt, Bt1: TKOLToolbarButton; - StdImagesStart, ViewImagesStart, HistImagesStart: Integer; - TheSameBefore, TheSameAfter: Boolean; -var Op: TToolbarOptions; - BCaps, BImgs: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.P_SetupParams', 0 - @@e_signature: - end; - ValuesInStack := 0; - Result := ''; - nparams := 3; - - // 5. Bitmap from a resource - if (Bitmap.Width > 0) and (Bitmap.Height > 0) and - (FResBmpID >= 0) and (MaxBtnImgWidth = MaxBtnImgHeight) and - (StandardImagesUsed=0) then - begin - if mapBitmapColors then - {Result := Result + 'LoadMappedBitmapEx( Result, hInstance, ''' + - UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + - IntToStr( FResBmpID ) + ''', [ ' + - Color2Str( FBmpTranColor ) + ', Color2RGB( clBtnFace ) ] ), '} - {P}Result := Result + - ' L($' + IntToHex( Color2RGB( clBtnFace ), 6 ) + ')' + - #13#10' L(' + IntToStr( FBmpTranColor ) + ')' + - #13#10' LoadStack L(1) ' + //'xySwap ' + - #13#10' LoadStr ''' + UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + - IntToStr( FResBmpID ) + ''' #0' + - #13#10' LoadHInstance ' + - #13#10' LoadSELF ' + - #13#10' LoadMappedBitmapEx<3> RESULT xySwap DEL xySwap DEL' - else - {Result := Result + 'LoadBmp( hInstance, PChar( ''' + - UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + IntToStr( FResBmpID ) + - ''' ), Result ), ';} - {P}Result := Result + - ' LoadSELF ' + - #13#10' LoadStr ''' + UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + - IntToStr( FResBmpID ) + ''' #0' + - #13#10' LoadHInstance LoadBmp<3> RESULT'; - end - else // or if standard images are used, type of images here - if (PicturedButtonsCount = 0) and (IntIn( StandardImagesUsed, [ 1, 2, 4 ] )) then - begin - if StandardImagesUsed = 1 then - if StandardImagesLarge then - //Result := Result + 'THandle( -2 ), ' - {P}Result := Result + #13#10' L(-2)' - else - //Result := Result + 'THandle( -1 ), ' - {P}Result := Result + #13#10' L(-1)' - else - if StandardImagesUsed = 2 then - if StandardImagesLarge then - //Result := Result + 'THandle( -6 ), ' - {P}Result := Result + #13#10' L(-6)' - else - //Result := Result + 'THandle( -5 ), ' - {P}Result := Result + #13#10' L(-5) ' - else - if StandardImagesLarge then - //Result := Result + 'THandle( -10 ), ' - {P}Result := Result + #13#10' L(-10)' - else - //Result := Result + 'THandle( -9 ), '; - {P}Result := Result + #13#10' L(-9)'; - end - else - begin // or if Bitmap is empty, value 0 - if not ((Bitmap.Width > 0) and (Bitmap.Height > 0) and - (FResBmpID >= 0)) then - FResBmpID := 0; - //Result := Result + '0, '; - Result := Result + #13#10' L(0) '; - end; - Result := Result + #13#10' C2R'; - - // 4. Button image indexes used - //Rpt( '$$$$$$$$$$$$$$$ PicturedButtonsCount := ' + IntToStr( PicturedButtonsCount ) ); - K := 0; - if (StandardImagesUsed = 0) and (PicturedButtonsCount = 0) and not ImageListsUsed then - //Result := Result + '[ -2 ]' - begin - {P}Result := Result + #13#10' L(-2) LoadStack C2R L(0)'; - Inc( ValuesInStack ); - Inc( K ); - end - else - if (StandardImagesUsed = 0) and AllPicturedButtonsAreLeading and - LastBtnHasPicture and not ImageListsUsed then - //Result := Result + '[ 0 ]' - begin - {P}Result := Result + #13#10' L(0) LoadStack C2R L(0)'; - Inc( ValuesInStack ); - Inc( K ); - end - else - begin - N := PicturedButtonsCount; - //Result := Result + '[ '; - StdImagesStart := N; - ViewImagesStart := N; - HistImagesStart := N; - if (StandardImagesUsed > 1) and LongBool(StandardImagesUsed and 1) then - begin - ViewImagesStart := N + 15; - HistImagesStart := N + 15; - end; - if LongBool(StandardImagesUsed and 2) then - HistImagesStart := HistImagesStart + 12; - N := 0; - S := ''; - BImgs := ''; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - //Rpt( '%%%%%%%%%% Bt ' + Bt.Name + ' HasPicture := ' + IntToStr( Integer( Bt.HasPicture ) ) ); - if ImageListsUsed then - begin - if Bt.imgIndex >= 0 then - S := IntToStr( Bt.imgIndex ) - else - S := '-2'; - end - else - if Bt.HasPicture then - begin - S := IntToStr( N ); - Inc( N ); - end - else - case Bt.sysimg of - stiCustom: - S := '-2'; // I_IMAGENONE - stdCUT..stdPRINT: - S := IntToStr( StdImagesStart + Ord( Bt.sysimg ) - Ord( stdCUT ) ); - viewLARGEICONS..viewVIEWMENU: - S := IntToStr( ViewImagesStart + Ord( Bt.sysimg ) - Ord( viewLARGEICONS ) ); - else - S := IntToStr( HistImagesStart + Ord( Bt.sysimg ) - Ord( histBACK ) ); - end; - //Result := Result + S + ', '; - {P}BImgs := ' L(' + S + ')' + BImgs; - Inc( K ); - end; - {if Items.Count > 0 then - Result := Copy( Result, 1, Length( Result ) - 2 ) + ' ]' - else - Result := Result + ']';} - {P}Result := Result + BImgs + - #13#10' LoadStack C2R L(' + IntToStr( K ) + ')'; - Inc( ValuesInStack, K ); - end; - - // 3. Button captions - //Result := Result + '[ '; - BCaps := ''; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.separator then - //Result := Result + '''-''' - {P}BCaps := ' ''-'' #0 ' + BCaps - else - begin - if noTextLabels then - B := ' ' - else - B := Bt.Fcaption; - S := ''; - if Bt.radioGroup <> 0 then - begin - TheSameBefore := FALSE; - TheSameAfter := FALSE; - if I > 0 then - begin - Bt1 := Items[ I - 1 ]; - if not Bt1.separator and (Bt1.FradioGroup = Bt.FradioGroup) then - TheSameBefore := TRUE; - end; - if I < Items.Count-1 then - begin - Bt1 := Items[ I + 1 ]; - if not Bt1.separator and (Bt1.FradioGroup = Bt.FradioGroup) then - TheSameAfter := TRUE; - end; - if TheSameBefore or TheSameAfter then - S := '!' + S; - end; - if Bt.checked and (Bt.Faction = nil) then - S := '+' + S - else - if Bt.radioGroup <> 0 then - S := '-' + S; - if Bt.dropdown then - S := '^' + S; - if noTextLabels then - //Result := Result + '''' + S + B + '''' - {P}BCaps := ' ''' + S + B + ''' #0 ' + BCaps - else - if Bt.Faction <> nil then - //Result := Result + '''' + S + ' ''' - {P}BCaps := ' ''' + S + ' '' #0 ' + BCaps - else - begin - B := StringConstant( Bt.Name + '_btn', B ); - if (B <> '') and (B[ 1 ] = '''') then - //Result := Result + '''' + S + Copy( B, 2, MaxInt ) - {P}BCaps := ' ''' + S + Copy( B, 2, MaxInt ) + ' #0 ' + BCaps - else - if S <> '' then - //Result := Result + 'PChar( ''' + S + ''' + ' + B + ')' - {P}BCaps := ' ''' + S + ''' ' + B + ' #0 ' + BCaps - else - //Result := Result + 'PChar( ' + B + ' )'; - {P}BCaps := B + ' #0 ' + BCaps; - end; - end; - {if I < Items.Count-1 then - Result := Result + ', ';} - end; - //Result := Result + ' ], '; - if Items.Count = 0 then - begin - //{P}Result := Result + ' LoadStack L(-1) R2C L(' + IntToStr( K ) + ')' - {P}Result := Result + #13#10' L(2) R2CN LoadStack L(12) xyAdd xySwap L(-1) xySwap ' + - #13#10' L(' + IntToStr( K-1 ) + ')'; - Inc( ValuesInStack ); - end - else - begin - {P}Result := Result + #13#10' L(' + IntToStr( Items.Count ) + ')' + - #13#10' LoadPCharArray ' + BCaps + ' L(' + IntToStr( Items.Count ) + ')' + - #13#10' L(2) R2CN LoadStack L(12) xyAdd xySwap L(' + IntToStr( Items.Count-1 ) + ') xySwap L(' + - IntToStr( K-1 ) + ')'; - Inc( ValuesInStack, Items.Count+2 ); - end; - - // 2. Options parameter - Op := []; - if (tboTextRight in Options) or - FixFlatXP and {(Align in [caLeft, caRight]) and} (tboFlat in Options) then - Op := [tboTextRight]; - if (tboTextBottom in Options) and (Op = []) then Op := Op + [tboTextBottom]; - if tboFlat in Options then Op := Op + [tboFlat]; - if tboTransparent in Options then Op := Op + [tboTransparent]; - if (tboWrapable in Options) and not( FixFlatXP and (Align in [caLeft, caRight]) and - (tboFlat in Options) ) - {or - ( (tboFlat in Options) and not (Align in [caLeft, caRight] ) and FixFlatXP )} then - Op := Op + [tboWrapable]; - if tboNoDivider in Options then Op := Op + [tboNoDivider]; - if tbo3DBorder in Options then Op := Op + [tbo3DBorder]; - //Result := AParent + ', ' + A + ', [' + S + '], '; - {P}Result := Result + #13#10' L(' + IntToStr( PWord( @ Op )^ ) + ')'; - - // 1. Align parameter - {case Align of - caLeft: A := 'caLeft'; - caRight:A := 'caRight'; - caClient: A := 'caClient'; - caTop: A := 'caTop'; - caBottom: A := 'caBottom'; - else A := 'caNone'; - end;} - //Result := AParent + ', ' + A + ', [' + S + '], '; - {P}Result := Result + #13#10' L(' + IntToStr( Integer( Align ) ) + ')'; - - // 0.Parent parameter - {P}Result := Result + #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.'; - {P}if Parent = Owner then Result := Result + 'Form' - else Result := Result + Parent.Name; - nparams := 3; -end; - -procedure TKOLToolbar.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var RsrcFile, RsrcName: String; - S, B: String; - I, J, K, W, H, N, I0, K1: Integer; - Bmp: TBitmap; - Bt, Bt1: TKOLToolbarButton; - Btn1st, NEvents: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.P_SetupFirst', 0 - @@e_signature: - end; - RsrcName := ''; - H := MaxBtnImgHeight; - W := MaxBtnImgWidth; - if W * H > 0 then - begin - RsrcName := UpperCase( ParentKOLForm.FormName ) + '_TBBMP' + IntToStr( FResBmpID ); - RsrcFile := ParentKOLForm.FormName + '_' + Name; - SL.Add( '{$R ' + RsrcFile + '.res}' ); - Bmp := TBitmap.Create; - TRY - N := 0; - FBmpTranColor := clNone; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.HasPicture then - begin - if FBmpTranColor = clNone then - begin - Bmp.Assign( Bt.picture ); - FBmpTranColor := Bmp.Canvas.Pixels[ 0, Bmp.Height - 1 ]; - end; - Inc( N ); - end; - end; - Bmp.Width := N * W; - Bmp.Height := H; - Bmp.PixelFormat := pf24bit; - if FBmpTranColor <> clNone then - begin - Bmp.Canvas.Brush.Color := FBmpTranColor; - Bmp.Canvas.FillRect( Rect( 0, 0, Bmp.Width, Bmp.Height ) ); - end; - N := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.HasPicture then - begin - Bmp.Canvas.Draw( N * W, 0, Bt.picture.Graphic ); - Inc( N ); - end; - end; - GenerateBitmapResource( Bmp, RsrcName, RsrcFile, fUpdated, AllowBitmapCompression ); - FINALLY - Bmp.Free; - END; - end; - if HeightAuto then - begin - DefaultHeight := Height; - DefaultWidth := Width; - end - else - begin - if Align in [ caTop, caBottom, caNone ] then - begin - DefaultHeight := 22; - DefaultWidth := Width; - end - else - if Align in [ caLeft, caRight ] then - begin - DefaultHeight := Height; - DefaultWidth := 44; - end - else - begin - DefaultHeight := Height; - DefaultWidth := Width; - end; - end; - inherited; - if ValuesInStack = 1 then - SL.Add( ' xySwap DEL' ) - else - if ValuesInStack > 0 then - SL.Add( ' C2R L(' + IntToStr( ValuesInStack ) + ') DELN R2C' );; - ValuesInStack := 0; - if TBButtonsWidth > 0 then - //SL.Add( ' ' + Prefix + AName + '.Perform( TB_SETBUTTONSIZE, ' + - // IntToStr( TBButtonsWidth ) + ', 0 );' ); - {P}SL.Add( ' L(0) L(' + IntToStr( TBButtonsWidth ) + ') L(' + - IntToStr( TB_SETBUTTONSIZE ) + ') C3 TControl.Perform<0>' ); // stdcall! - if Assigned( bitmap ) and (bitmap.Width * bitmap.Height > 0) then - begin - W := MaxBtnImgWidth; - H := MaxBtnImgHeight; - if (W <> H) or (StandardImagesUsed > 0) then - begin - //SL.Add( ' ' + Prefix + AName + '.TBBtnImgWidth := ' + IntToStr( W ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( W ) + - ') C1 AddWord_Store ##TControl_.fTBBtnImgWidth' ); - //S := ' ' + Prefix + AName + '.TBAddBitmap( '; - if mapBitmapColors then - //S := S + 'LoadMappedBitmapEx( ' + AName + ', hInstance, ''' + RsrcName + ''', [ ' + - // Color2Str( FBmpTranColor ) + ', Color2RGB( clBtnFace ) ] ) );' - {P}SL.Add( ' L($' + IntToHex( clBtnFace, 6 ) + ') Color2RGB<1> RESULT' + - ' L($' + IntToHex( FBmpTranColor, 6 ) + ')' + - ' LoadStack L(1)' + - ' LoadStr ''' + RsrcName + ''' #0' + - ' LoadHInstance C6 LoadMappedBitmapEx<3> DEL DEL RESULT' ) - else - //S := S + 'LoadBmp( hInstance, ''' + RsrcName + ''', ' + - // AName + ' ) );'; - {P}SL.Add( ' DUP LoadStr ''' + RsrcName + ''' #0 LoadHInstance' + - ' LoadBmp<3> RESULT'); - //SL.Add( S ); - {P}SL.Add( ' C1 TControl.TBAddBitmap<2>' ); - end; - end; - if ((StandardImagesUsed > 0) and (PicturedButtonsCount > 0)) or - not IntIn(StandardImagesUsed, [ 1, 2, 4 ]) then - begin - if LongBool( StandardImagesUsed and 1 ) then - begin - if StandardImagesLarge then - S := '-2' - else - S := '-1'; - //SL.Add( ' ' + Prefix + AName + '.TBAddBitmap( THandle( ' + S + ' ) );' ); - {P}SL.Add( ' L(' + S + ') C1 TControl.TBAddBitmap<2>' ); - end; - if LongBool( StandardImagesUsed and 2 ) then - begin - if StandardImagesLarge then - S := '-6' - else - S := '-5'; - //SL.Add( ' ' + Prefix + AName + '.TBAddBitmap( THandle( ' + S + ' ) );' ); - {P}SL.Add( ' L(' + S + ') C1 TControl.TBAddBitmap<2>' ); - end; - if LongBool( StandardImagesUsed and 4 ) then - begin - if StandardImagesLarge then - S := '-10' - else - S := '-9'; - //SL.Add( ' ' + Prefix + AName + '.TBAddBitmap( THandle( ' + S + ' ) );' ); - {P}SL.Add( ' L(' + S + ') C1 TControl.TBAddBitmap<2>' ); + if (S <> '') then begin + Delete(S, 1, 1); + SL.Add(' ' + Prefix + AName + '.TBConvertIdxArray2ID( [' + S + '] );'); end; end; - if showTooltips or (tooltips.Count > 0) then - begin - S := ''; - J := 0; - K1 := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - //if Bt.Faction <> nil then continue; // remove by YS 7-Aug-2004 - //if Bt.separator then continue; + if AutoSize then + SL.Add(' ' + Prefix + AName + '.Perform( TB_AUTOSIZE, 0, 0 );'); - //---------{ Maxim Pushkar }---------------------------------------------- - //if (tooltips.Count > 0) and (J > tooltips.Count) then break; - //----------------------------------------------------------------------// - if (tooltips.Count > 0) and (J >= tooltips.Count) then break; // - //--------------------------------------------------------------------// - - if Bt.Tooltip <> '' then - B := Bt.Tooltip - else - if (tooltips.Count > 0) and (tooltips[ J ] <> '') and not Bt.separator then - B := tooltips[ J ] - else - if showTooltips then - B := Bt.Caption - else - B := ''; - if Bt.Faction = nil then // {YS} добавить - begin // {YS} добавить - if not Bt.separator then // {YS} добавить - begin - //if S <> '' then - // S := S + ', '; - //S := S + PCharStringConstant( Self, Bt.Name + '_tip', B ); - {P}S := //P_PCharStringConstant( Self, Bt.Name + '_tip', B ) + S; - ' ' + P_String2Pascal( B ) + ' ' + S; - inc( K1 ); - end - else - //+++++++ v1.94 - begin - {if S <> '' then - //S := S + ', ''''' - else - //S := S + '''''';} - {P}S := #13#10' #0 ' + S; - inc( K1 ); - end; - //------ - end // {YS} добавить - else // {YS} добавить - Inc( J ); - end; - // change by Alexander Pravdin (to fix tooltips for case of first separator): - //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - Btn1st := 0; - {for i := 0 to ButtonCount - 1 do - if not TKOLToolbarButton( FItems.Items[i] ).Fseparator then begin - Btn1st := i; - Break; - end;} - if S <> '' then - begin - //SL.Add( Prefix + ' ' + AName + '.TBSetTooltips( ' + AName + - // '.TBIndex2Item( ' + IntToStr( Btn1st ) + ' ), [ ' + S + ' ] );' ); - {P}SL.Add( ' L(' + IntToStr( K1 ) + ') LoadPCharArray ' + S + - #13#10' LoadStack L(' + IntToStr( K1-1 ) + ') xySwap' + - #13#10' L(' + IntToStr( Btn1st ) + ') LoadSELF AddWord_LoadRef ##T' + - ParentKOLForm.FormName + '.' + Name + - #13#10' TControl.TBIndex2Item<2> RESULT' + - #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + - '.' + Name + - //#13#10' TControl.TBSetTooltips<3> ' + - #13#10' ToolbarSetTooltips<3> ' + - #13#10' L(' + IntToStr( Items.Count ) + ') DELN' ); - end; - //-------------------------------------------------------------------------- - {if S <> '' then - SL.Add( Prefix + ' ' + AName + '.TBSetTooltips( ' + AName + - '.TBIndex2Item( 0 ), [ ' + S + ' ] );' );} - //////////////////////////////////////////////////////////////////////////// - end; - - // assign image list if used: - if ImageListNormal <> nil then - begin - //SL.Add( Prefix + ' ' + AName + '.Perform( TB_SETIMAGELIST, 0, Result.' + - // ImageListNormal.Name + '.Handle );' ); - {P}SL.Add( ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + - '.' + ImageListNormal.Name + - #13#10' TImageList_.GetHandle<1> RESULT' + - #13#10' L(0) L(' + IntToStr( TB_SETIMAGELIST ) + ')' + - #13#10' C3 TControl.Perform<0>' ); // stdcall! - end; - if ImageListDisabled <> nil then - begin - //SL.Add( Prefix + ' ' + AName + '.Perform( TB_SETDISABLEDIMAGELIST, 0, Result.' + - // ImageListDisabled.Name + '.Handle );' ); - {P}SL.Add( ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + - '.' + imageListDisabled.Name + - #13#10' TImageList_.GetHandle<1> RESULT' + - #13#10' L(0) L(' + IntToStr( TB_SETDISABLEDIMAGELIST ) + ')' + - #13#10' C3 TControl.Perform<0>' ); // stdcall! - end; - if ImageListHot <> nil then - begin - //SL.Add( Prefix + ' ' + AName + '.Perform( TB_SETHOTIMAGELIST, 0, Result.' + - // ImageListHot.Name + '.Handle );' ); - {P}SL.Add( ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + - '.' + imageListHot.Name + - #13#10' TImageList_.GetHandle<1> RESULT' + - #13#10' L(0) L(' + IntToStr( TB_SETHOTIMAGELIST ) + ')' + - #13#10' C3 TControl.Perform<0>' ); // stdcall! - end; - - I0 := -1; - NEvents := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - Inc( I0 ); - //if Bt.separator then Continue; - if Bt.fOnClickMethodName <> '' then - begin - S := ''; - for J := I to Items.Count - 1 do - begin - Bt := Items[ J ]; - //if Bt.separator then Continue; - if Bt.separator or (Bt.fOnClickMethodName = '') then - begin - N := 0; - for K := J to Items.Count-1 do - begin - Bt1 := Items[ K ]; - if Bt1.separator then Continue; - if Bt1.fOnClickMethodName <> '' then - begin - Inc( N ); - break; - end; - end; - if N = 0 then break; - end; - //if S <> '' then S := S + ', '; - if Bt.fOnClickMethodName <> '' then - //S := S + 'Result.' + Bt.fOnClickMethodName - {P}S := #13#10' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + - Bt.fOnClickMethodName + S - else - //S := S + 'nil'; - {P}S := #13#10' L(0) L(0) ' + S; - inc( NEvents ); - end; - //SL.Add( ' ' + Prefix + AName + '.TBAssignEvents( ' + IntToStr( I0 ) + - // ', [ ' + S + ' ] );' ); - {P}SL.Add( S + #13#10' LoadStack L(' + IntToStr( NEvents-1 ) + ') xySwap' + - #13#10' L(' + IntToStr( I0 ) + ')' + - #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + - Name + ' TControl.TBAssignEvents<3>' ); - {P}SL.Add( ' L(' + IntToStr( NEvents * 2 ) + ') DELN' ); - break; - end; - end; - if TBButtonsMinWidth > 0 then - //SL.Add( Prefix + AName + '.TBButtonsMinWidth := ' + IntToStr( TBButtonsMinWidth ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( TBButtonsMinWidth ) + ') L(0)' + - #13#10' C2 TControl_.TBSetBtMinMaxWidth<3>' ); - if TBButtonsMaxWidth > 0 then - //SL.Add( Prefix + AName + '.TBButtonsMaxWidth := ' + IntToStr( TBButtonsMaxWidth ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( TBButtonsMaxWidth ) + ') L(1)' + - #13#10' C2 TControl_.TBSetBtMinMaxWidth<3>' ); - for I := Items.Count-1 downto 0 do - begin - Bt := Items[ I ]; - if not Bt.visible and (Bt.Faction = nil) then - //SL.Add( Prefix + AName + '.TBButtonVisible[ ' + IntToStr( I ) + ' ] := FALSE;' ); - {P}SL.Add( ' L(0) L(' + IntToStr( I ) + ')' + - //#13#10' C2 TControl_.TBSetButtonVisible<3>' ); - #13#10' C2 ShowHideToolbarButton<3>' ); - if not Bt.enabled and (Bt.Faction = nil) then - //SL.Add( Prefix + AName + '.TBButtonEnabled[ ' + IntToStr( I ) + ' ] := FALSE;' ); - {P}SL.Add( ' L(0) L(' + IntToStr( TB_ENABLEBUTTON ) + ') L(' + IntToStr( I ) + ')' + - //#13#10' C3 TControl_.TBSetBtnStt<3>' ); - #13#10' C3 EnableToolbarButton<3>' ); - end; - - if FixFlatXP then - if (tboFlat in Options) and (Parent <> nil) and not(Parent is TForm) then - begin - if Align in [ caLeft, caRight ] then - begin - //SL.Add( Prefix + ' ' + AName + '.Style := ' + AName + - // '.Style or TBSTYLE_WRAPABLE;' ); - {P}SL.Add( ' DUP AddWord_LoadRef ##TControl_.fStyle' + - #13#10' L(' + IntToStr( TBSTYLE_WRAPABLE ) + ') |' + - #13#10' C1 TControl_.SetStyle<2>' ); - end - else - begin - {SL.Add( Prefix + 'if WinVer >= wvXP then' ); - SL.Add( Prefix + 'begin' ); - SL.Add( Prefix + ' ' + AName + '.Style := ' + AName + - '.Style or TBSTYLE_WRAPABLE;' ); - SL.Add( Prefix + ' ' + AName + '.Transparent := TRUE;' ); - SL.Add( Prefix + 'end;' );} - {P}SL.Add( ' WinVer RESULTB' + - #13#10' L(' + IntToStr( Integer( wvXP ) ) + ')' + - #13#10' - x>=0? IF1' + - ' DUP AddWord_LoadRef ##TControl_.fStyle' + - ' L(' + IntToStr( TBSTYLE_WRAPABLE ) + ') |' + - ' C1 TControl_.SetStyle<2>' + - ' L(1) C1 TControl_.SetTransparent<2>' + - #13#10' ENDIF' ); - end; - end; -end; - -function TKOLToolbar.Pcode_Generate: Boolean; -begin - Result := TRUE; end; procedure TKOLToolbar.DesembleTooltips; -var SL: TStrings; - I, N: Integer; - Bt: TKOLToolbarButton; +var + SL: TStrings; + I, N: Integer; + Bt: TKOLToolbarButton; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbar.AssembleTooltips', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbar.AssembleTooltips', 0 + +@@e_signature: end; N := 0; SL := tooltips; - if SL <> nil then - BEGIN - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.separator then continue; + if SL <> nil then begin + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.separator then + continue; if N >= SL.Count then Bt.FTooltip := '' else - Bt.Ftooltip := SL[ N ]; - Inc( N ); + Bt.Ftooltip := SL[N]; + Inc(N); end; showTooltips := SL.Count > 0; - END; + end; end; procedure TKOLToolbar.SetOnTBCustomDraw(const Value: TOnTBCustomDraw); @@ -13888,378 +10483,175 @@ begin Change; end; -procedure TKOLToolbar.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLToolbar.AssignEvents(SL: TStringList; const AName: string); begin inherited; - DoAssignEvents( SL, AName, [ 'OnTBCustomDraw' ], - [ @ OnTBCustomDraw ] ); + DoAssignEvents(SL, AName, ['OnTBCustomDraw'], [@OnTBCustomDraw]); end; -procedure TKOLToolbar.SetupConstruct_Compact; -var KF: TKOLForm; - i, N: Integer; - Bt, Bt1: TKOLToolbarButton; - s, B: String; - TheSameBefore, TheSameAfter: Boolean; - StdImagesStart, ViewImagesStart, HistImagesStart: Integer; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewToolbar', TRUE, TRUE, '' ); - KF.FormAddNumParameter( Integer( Align ) ); - KF.FormAddNumParameter( PInteger( @ Options )^ ); - if (Bitmap.Width > 0) and (Bitmap.Height > 0) and - (FResBmpID >= 0) and (MaxBtnImgWidth = MaxBtnImgHeight) and - (StandardImagesUsed=0) then - begin - KF.FormAddNumParameter( Integer( mapBitmapColors )+1 ); - if mapBitmapColors then - KF.FormAddNumParameter( (FBmpTranColor shl 1) or (FBmpTranColor shr 31) ); - KF.FormAddStrParameter( UpperCase( ParentKOLForm.FormName ) + - '_TBBMP' + IntToStr( FResBmpID ) ); - end - else - begin - if (PicturedButtonsCount = 0) and (IntIn( StandardImagesUsed, [ 1, 2, 4 ] )) then - begin - if StandardImagesUsed = 1 then - if StandardImagesLarge then - //Result := Result + 'THandle( -2 ), ' - KF.FormAddNumParameter( -2 ) - else - //Result := Result + 'THandle( -1 ), ' - KF.FormAddNumParameter( -1 ) - else - if StandardImagesUsed = 2 then - if StandardImagesLarge then - //Result := Result + 'THandle( -6 ), ' - KF.FormAddNumParameter( -6 ) - else - //Result := Result + 'THandle( -5 ), ' - KF.FormAddNumParameter( -5 ) - else - if StandardImagesLarge then - //Result := Result + 'THandle( -10 ), ' - KF.FormAddNumParameter( -10 ) - else - //Result := Result + 'THandle( -9 ), '; - KF.FormAddNumParameter( -9 ); - end - else - begin - if not ((Bitmap.Width > 0) and (Bitmap.Height > 0) - and (FResBmpID >= 0)) then - FResBmpID := 0; - KF.FormAddNumParameter( 0 ); - end; - end; - KF.FormAddNumParameter( Items.Count ); - for i := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.separator then - s := '-' - else - begin - if noTextLabels or not KF.AssignTextToControls then - B := ' ' - else - B := Bt.Fcaption; - s := ''; - if Bt.radioGroup <> 0 then - begin - TheSameBefore := FALSE; - TheSameAfter := FALSE; - if i> 0 then - begin - Bt1 := Items[ i - 1 ]; - if not Bt1.separator and (Bt1.FradioGroup = Bt.FradioGroup) then - TheSameBefore := TRUE; - end; - if i < Items.Count-1 then - begin - Bt1 := Items[ I + 1 ]; - if not Bt1.separator and (Bt1.FradioGroup = Bt.FradioGroup) then - TheSameAfter := TRUE; - end; - if TheSameBefore or TheSameAfter then - s := '!' + s; - end; - if Bt.checked and (Bt.Faction = nil) then - s := '+' + s - else - if Bt.radioGroup <> 0 then - s := '-' + s; - if Bt.dropdown then - s := '^' + s; - if noTextLabels then - s := s + B - else - if Bt.Faction <> nil then - // - else - begin - B := Bt.Name; - if (B <> '') and (B[ 1 ] = '''') then - s := s + Copy( B, 2, MaxInt ) - else - s := s + B; - end; - end; - KF.FormAddStrParameter( s ); - end; - - if (StandardImagesUsed = 0) and (PicturedButtonsCount = 0) and not ImageListsUsed then - begin - KF.FormAddNumParameter( 1 ); - KF.FormAddNumParameter( -2 ); - end else - if (StandardImagesUsed = 0) and AllPicturedButtonsAreLeading and - LastBtnHasPicture and not ImageListsUsed then - begin - KF.FormAddNumParameter( 1 ); - KF.FormAddNumParameter( 0 ); - end else - begin - N := PicturedButtonsCount; - StdImagesStart := N; - ViewImagesStart := N; - HistImagesStart := N; - if (StandardImagesUsed > 1) and LongBool(StandardImagesUsed and 1) then - begin - ViewImagesStart := N + 15; - HistImagesStart := N + 15; - end; - if LongBool(StandardImagesUsed and 2) then - HistImagesStart := HistImagesStart + 12; - N := 0; - S := ''; - KF.FormAddNumParameter( Items.Count ); - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if ImageListsUsed then - begin - if Bt.imgIndex >= 0 then - KF.FormAddNumParameter( Bt.imgIndex ) - else - KF.FormAddNumParameter( -2 ); - end - else - if Bt.HasPicture then - begin - KF.FormAddNumParameter( N ); - Inc( N ); - end - else - case Bt.sysimg of - stiCustom: - KF.FormAddNumParameter( -2 ); // I_IMAGENONE - stdCUT..stdPRINT: - KF.FormAddNumParameter( StdImagesStart + Ord( Bt.sysimg ) - Ord( stdCUT ) ); - viewLARGEICONS..viewVIEWMENU: - KF.FormAddNumParameter( ViewImagesStart + Ord( Bt.sysimg ) - Ord( viewLARGEICONS ) ); - else - KF.FormAddNumParameter( HistImagesStart + Ord( Bt.sysimg ) - Ord( histBACK ) ); - end; - end; - end; -end; - -function TKOLToolbar.SupportsFormCompact: Boolean; -begin - Result := TRUE; //CompactCode; -end; - -procedure TKOLToolbar.SetCompactCode(const Value: Boolean); -begin - if FCompactCode = Value then Exit; - FCompactCode := Value; - Change; -end; - -function TKOLToolbar.HasCompactConstructor: Boolean; -begin - Result := CompactCode and (Items.Count < 256); -end; - -function TKOLToolbar.ButtonCaptionsList( var Cnt: Integer ): String; -VAR S, B: String; - I: Integer; - Bt, Bt1: TKOLToolbarButton; - TheSameBefore, TheSameAfter: Boolean; +function TKOLToolbar.ButtonCaptionsList(var Cnt: Integer): string; +var + S, B: string; + I: Integer; + Bt, Bt1: TKOLToolbarButton; + TheSameBefore, TheSameAfter: Boolean; {$IFDEF _D2009orHigher} - C2: String; - C : String; - Z: Integer; + C2: string; + C: string; + Z: Integer; {$ENDIF} begin Result := ''; Cnt := 0; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; - if Bt.separator then - begin - Result := Result + '''-'''; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; + if Bt.separator then begin + Result := Result + '''-'''; end - else - begin - if noTextLabels or - (ParentKOLForm = nil) or not ParentKOLForm.AssignTextToControls then - B := ' ' - else - begin + else begin + if noTextLabels or (ParentKOLForm = nil) or not ParentKOLForm.AssignTextToControls then + B := ' ' + else begin {$IFDEF _D2009orHigher} - C2 := ''; - C := Bt.Fcaption; - for Z := 1 to Length(C) do - C2 := C2 + '#' + Int2Str(ord(C[Z])); - B := C2 + '#0'; //dufa + C2 := ''; + C := Bt.Fcaption; + for Z := 1 to Length(C) do + C2 := C2 + '#' + Int2Str(ord(C[Z])); + B := C2 + '#0'; //dufa {$ELSE} - B := Bt.Fcaption; + B := Bt.Fcaption; {$ENDIF} - end; - S := ''; - if Bt.radioGroup <> 0 then - begin - TheSameBefore := FALSE; - TheSameAfter := FALSE; - if I > 0 then - begin - Bt1 := Items[ I - 1 ]; - if not Bt1.separator and (Bt1.FradioGroup = Bt.FradioGroup) then - TheSameBefore := TRUE; - end; - if I < Items.Count-1 then - begin - Bt1 := Items[ I + 1 ]; - if not Bt1.separator and (Bt1.FradioGroup = Bt.FradioGroup) then - TheSameAfter := TRUE; - end; - if TheSameBefore or TheSameAfter then - S := '!' + S; - end; - if Bt.checked and (Bt.Faction = nil) then - S := '+' + S - else - if Bt.radioGroup <> 0 then - S := '-' + S; - if Bt.dropdown then - S := '^' + S; - if noTextLabels then - Result := Result + '''' + S + B + '''' - else - if Bt.Faction <> nil then - Result := Result + '''' + S + ' ''' - else - begin - {$IFDEF _D2009orHigher} - if B = '' then B := ''''''; - {$ELSE} - B := StringConstant( Bt.Name + '_btn', B ); - {$ENDIF} - if (B <> '') and (B[ 1 ] = '''') then - Result := Result + '''' + S + Copy( B, 2, MaxInt ) - else - if S <> '' then - Result := Result + 'PKOLChar( ''' + S + ''' + ' + B + ')' - else - Result := Result + 'PKOLChar( ' + B + ' )'; - end; end; - if I < Items.Count-1 then - Result := Result + ', '; - inc( Cnt ); + S := ''; + if Bt.radioGroup <> 0 then begin + TheSameBefore := FALSE; + TheSameAfter := FALSE; + if I > 0 then begin + Bt1 := Items[I - 1]; + if not Bt1.separator and (Bt1.FradioGroup = Bt.FradioGroup) then + TheSameBefore := TRUE; + end; + if I < Items.Count - 1 then begin + Bt1 := Items[I + 1]; + if not Bt1.separator and (Bt1.FradioGroup = Bt.FradioGroup) then + TheSameAfter := TRUE; + end; + if TheSameBefore or TheSameAfter then + S := '!' + S; + end; + if Bt.checked and (Bt.Faction = nil) then + S := '+' + S + else if Bt.radioGroup <> 0 then + S := '-' + S; + if Bt.dropdown then + S := '^' + S; + if noTextLabels then + Result := Result + '''' + S + B + '''' + else if Bt.Faction <> nil then + Result := Result + '''' + S + ' ''' + else begin + {$IFDEF _D2009orHigher} + if B = '' then + B := ''''''; + {$ELSE} + B := StringConstant(Bt.Name + '_btn', B); + {$ENDIF} + if (B <> '') and (B[1] = '''') then + Result := Result + '''' + S + Copy(B, 2, MaxInt) + else if S <> '' then + Result := Result + 'PKOLChar( ''' + S + ''' + ' + B + ')' + else + Result := Result + 'PKOLChar( ' + B + ' )'; + end; + end; + if I < Items.Count - 1 then + Result := Result + ', '; + inc(Cnt); end; end; -function TKOLToolbar.ButtonImgIndexesList( var Cnt: Integer ): String; -VAR I, N: Integer; - StdImagesStart, ViewImagesStart, HistImagesStart: Integer; - S: String; - Bt: TKOLToolbarButton; +function TKOLToolbar.ButtonImgIndexesList(var Cnt: Integer): string; +var + I, N: Integer; + StdImagesStart, ViewImagesStart, HistImagesStart: Integer; + S: string; + Bt: TKOLToolbarButton; begin Cnt := 0; - if (StandardImagesUsed = 0) and (PicturedButtonsCount = 0) and not ImageListsUsed then - begin - Result := Result + '-2'; - Cnt := 1; - end else - if (StandardImagesUsed = 0) and AllPicturedButtonsAreLeading and - LastBtnHasPicture and not ImageListsUsed then - begin - Result := Result + '0'; - Cnt := 1; - end else - begin + if (StandardImagesUsed = 0) and (PicturedButtonsCount = 0) and not ImageListsUsed then begin + Result := Result + '-2'; + Cnt := 1; + end + else if (StandardImagesUsed = 0) and AllPicturedButtonsAreLeading and + LastBtnHasPicture and not ImageListsUsed then begin + Result := Result + '0'; + Cnt := 1; + end + else begin N := PicturedButtonsCount; StdImagesStart := N; ViewImagesStart := N; HistImagesStart := N; - if (StandardImagesUsed > 1) and LongBool(StandardImagesUsed and 1) then - begin - ViewImagesStart := N + 15; - HistImagesStart := N + 15; + if (StandardImagesUsed > 1) and LongBool(StandardImagesUsed and 1) then begin + ViewImagesStart := N + 15; + HistImagesStart := N + 15; end; - if LongBool(StandardImagesUsed and 2) then - HistImagesStart := HistImagesStart + 12; + if LongBool(StandardImagesUsed and 2) then + HistImagesStart := HistImagesStart + 12; N := 0; S := ''; - for I := 0 to Items.Count-1 do - begin - Bt := Items[ I ]; + for I := 0 to Items.Count - 1 do begin + Bt := Items[I]; //Rpt( '%%%%%%%%%% Bt ' + Bt.Name + ' HasPicture := ' + IntToStr( Integer( Bt.HasPicture ) ) ); - if ImageListsUsed then - begin - if Bt.imgIndex >= 0 then - S := IntToStr( Bt.imgIndex ) - else - S := '-2'; - end + if ImageListsUsed then begin + if Bt.imgIndex >= 0 then + S := IntToStr(Bt.imgIndex) else - if Bt.HasPicture then - begin - S := IntToStr( N ); - Inc( N ); - end - else + S := '-2'; + end + else if Bt.HasPicture then begin + S := IntToStr(N); + Inc(N); + end + else case Bt.sysimg of - stiCustom: - S := '-2'; // I_IMAGENONE - stdCUT..stdPRINT: - S := IntToStr( StdImagesStart + Ord( Bt.sysimg ) - Ord( stdCUT ) ); - viewLARGEICONS..viewVIEWMENU: - S := IntToStr( ViewImagesStart + Ord( Bt.sysimg ) - Ord( viewLARGEICONS ) ); + stiCustom: + S := '-2'; // I_IMAGENONE + stdCUT..stdPRINT: + S := IntToStr(StdImagesStart + Ord(Bt.sysimg) - Ord(stdCUT)); + viewLARGEICONS..viewVIEWMENU: + S := IntToStr(ViewImagesStart + Ord(Bt.sysimg) - Ord(viewLARGEICONS)); else - S := IntToStr( HistImagesStart + Ord( Bt.sysimg ) - Ord( histBACK ) ); + S := IntToStr(HistImagesStart + Ord(Bt.sysimg) - Ord(histBACK)); end; - Result := Result + S + ', '; - inc( Cnt ); + Result := Result + S + ', '; + inc(Cnt); end; - if Items.Count > 0 then - Result := Copy( Result, 1, Length( Result ) - 2 ); + if Items.Count > 0 then + Result := Copy(Result, 1, Length(Result) - 2); end; end; procedure TKOLToolbar.SetAutosizeButtons(const Value: Boolean); begin - if FAutosizeButtons = Value then Exit; - FAutosizeButtons := Value; - Change; + if FAutosizeButtons = Value then + Exit; + FAutosizeButtons := Value; + Change; end; procedure TKOLToolbar.SetNoSpaceForImages(const Value: Boolean); begin - if FNoSpaceForImages = Value then Exit; - FNoSpaceForImages := Value; - Change; + if FNoSpaceForImages = Value then + Exit; + FNoSpaceForImages := Value; + Change; end; procedure TKOLToolbar.SetAllowBitmapCompression(const Value: Boolean); begin - if FAllowBitmapCompression = Value then Exit; + if FAllowBitmapCompression = Value then + Exit; FAllowBitmapCompression := Value; Change; end; @@ -14267,22 +10659,25 @@ end; { TKOLToolbarButtonsEditor } procedure TKOLToolbarButtonsEditor.Edit; -var Tb: TKOLToolbar; +var + Tb: TKOLToolbar; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButtonsEditor.Edit', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButtonsEditor.Edit', 0 + +@@e_signature: end; - if GetComponent( 0 ) = nil then Exit; - Tb := GetComponent( 0 ) as TKOLToolbar; + if GetComponent(0) = nil then + Exit; + Tb := GetComponent(0) as TKOLToolbar; if Tb.ActiveDesign = nil then - Tb.ActiveDesign := TfmToolbarEditor.Create( Application ); + Tb.ActiveDesign := TfmToolbarEditor.Create(Application); Tb.ActiveDesign.ToolbarControl := Tb; Tb.ActiveDesign.Visible := TRUE; - SetForegroundWindow( Tb.ActiveDesign.Handle ); - Tb.ActiveDesign.MakeActive( TRUE ); + SetForegroundWindow(Tb.ActiveDesign.Handle); + Tb.ActiveDesign.MakeActive(TRUE); if Tb.ParentForm <> nil then Tb.ParentForm.Invalidate; end; @@ -14290,33 +10685,37 @@ end; function TKOLToolbarButtonsEditor.GetAttributes: TPropertyAttributes; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButtonsEditor.GetAttributes', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButtonsEditor.GetAttributes', 0 + +@@e_signature: end; - Result := [ paDialog, paReadOnly ]; + Result := [paDialog, paReadOnly]; end; { TKOLToolbarEditor } procedure TKOLToolbarEditor.Edit; -var Tb: TKOLToolbar; +var + Tb: TKOLToolbar; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarEditor.Edit', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarEditor.Edit', 0 + +@@e_signature: end; - if Component = nil then Exit; + if Component = nil then + Exit; Tb := Component as TKOLToolbar; if Tb.ActiveDesign = nil then - Tb.ActiveDesign := TfmToolbarEditor.Create( Application ); + Tb.ActiveDesign := TfmToolbarEditor.Create(Application); Tb.ActiveDesign.ToolbarControl := Tb; Tb.ActiveDesign.Visible := TRUE; - SetForegroundWindow( Tb.ActiveDesign.Handle ); - Tb.ActiveDesign.MakeActive( TRUE ); + SetForegroundWindow(Tb.ActiveDesign.Handle); + Tb.ActiveDesign.MakeActive(TRUE); if Tb.ParentForm <> nil then Tb.ParentForm.Invalidate; end; @@ -14324,10 +10723,11 @@ end; procedure TKOLToolbarEditor.ExecuteVerb(Index: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarEditor.ExecuteVerb', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarEditor.ExecuteVerb', 0 + +@@e_signature: end; Edit; end; @@ -14335,10 +10735,11 @@ end; function TKOLToolbarEditor.GetVerb(Index: Integer): string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarEditor.GetVerb', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarEditor.GetVerb', 0 + +@@e_signature: end; Result := '&Edit'; end; @@ -14346,10 +10747,11 @@ end; function TKOLToolbarEditor.GetVerbCount: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarEditor.GetVerbCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarEditor.GetVerbCount', 0 + +@@e_signature: end; Result := 1; end; @@ -14357,29 +10759,31 @@ end; { TKOLTabControlEditor } procedure TKOLTabControlEditor.Edit; -var P: TPoint; - C: TComponent; - TabControl: TKOLTabControl; - I: Integer; - R: PRect; +var + P: TPoint; + C: TComponent; + TabControl: TKOLTabControl; + I: Integer; + R: PRect; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControlEditor.Edit', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControlEditor.Edit', 0 + +@@e_signature: end; - GetCursorPos( P ); + GetCursorPos(P); C := Component; - if C = nil then Exit; - if not( C is TKOLTabControl ) then Exit; + if C = nil then + Exit; + if not (C is TKOLTabControl) then + Exit; TabControl := C as TKOLTabControl; - P := TabControl.ScreenToClient( P ); - for I := 0 to TabControl.Count-1 do - begin - R := TabControl.FTabs[ I ]; - if PtInRect( R^, P ) then - begin + P := TabControl.ScreenToClient(P); + for I := 0 to TabControl.Count - 1 do begin + R := TabControl.FTabs[I]; + if PtInRect(R^, P) then begin TabControl.CurIndex := I; break; end; @@ -14389,10 +10793,11 @@ end; procedure TKOLTabControlEditor.ExecuteVerb(Index: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControlEditor.ExecuteVerb', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControlEditor.ExecuteVerb', 0 + +@@e_signature: end; Edit; end; @@ -14400,10 +10805,11 @@ end; function TKOLTabControlEditor.GetVerb(Index: Integer): string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControlEditor.GetVerb', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControlEditor.GetVerb', 0 + +@@e_signature: end; Result := ''; end; @@ -14411,10 +10817,11 @@ end; function TKOLTabControlEditor.GetVerbCount: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTabControlEditor.GetVerbCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTabControlEditor.GetVerbCount', 0 + +@@e_signature: end; Result := 0; end; @@ -14424,10 +10831,11 @@ end; constructor TKOLImageShow.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.Create', 0 + +@@e_signature: end; inherited; FHasBorder := FALSE; @@ -14437,25 +10845,28 @@ end; destructor TKOLImageShow.Destroy; begin if ImageListNormal <> nil then - ImageListNormal.NotifyLinkedComponent( Self, noRemoved ); + ImageListNormal.NotifyLinkedComponent(Self, noRemoved); inherited; end; procedure TKOLImageShow.DoAutoSize; -var Delta: Integer; +var + Delta: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.DoAutoSize', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.DoAutoSize', 0 + +@@e_signature: end; - if not fImgShwAutoSize then Exit; - if FImageListNormal = nil then Exit; + if not fImgShwAutoSize then + Exit; + if FImageListNormal = nil then + Exit; Delta := 0; - if HasBorder then - begin - Inc( Delta, 6 ); + if HasBorder then begin + Inc(Delta, 6); end; Width := FImageListNormal.ImgWidth + Delta; Height := FImageListNormal.ImgHeight + Delta; @@ -14469,14 +10880,14 @@ begin Result := HasBorder; end; -procedure TKOLImageShow.NotifyLinkedComponent(Sender: TObject; - Operation: TNotifyOperation); +procedure TKOLImageShow.NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.NotifyLinkedComponent', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.NotifyLinkedComponent', 0 + +@@e_signature: end; inherited; if Operation = noRemoved then @@ -14485,135 +10896,75 @@ end; procedure TKOLImageShow.Paint; var - R, RDest:TRect; - EdgeFlag:DWord; + R, RDest: TRect; + EdgeFlag: DWord; //Flag:DWord; - Delta:DWord; - TMP:TBitMap; + Delta: DWord; + TMP: TBitMap; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.Paint', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.Paint', 0 + +@@e_signature: end; - R.Left:=0; - R.Top:=0; - R.Right:=Width; - R.Bottom:=Height; + R.Left := 0; + R.Top := 0; + R.Right := Width; + R.Bottom := Height; - if HasBorder then - begin - EdgeFlag:=EDGE_RAISED; - Delta:=3; + if HasBorder then begin + EdgeFlag := EDGE_RAISED; + Delta := 3; end - else - begin - EdgeFlag:=0; - Delta:=0; + else begin + EdgeFlag := 0; + Delta := 0; end; - if Delta <> 0 then - begin - DrawEdge(Canvas.Handle,R,EdgeFlag,BF_RECT or BF_MIDDLE ); - R.Left:=Delta-1; - R.Top:=Delta-1; - R.Right:=Width-Integer( Delta )+1; - R.Bottom:=Height-Integer( Delta )+1; - Canvas.Brush.Color :=clInactiveBorder; + if Delta <> 0 then begin + DrawEdge(Canvas.Handle, R, EdgeFlag, BF_RECT or BF_MIDDLE); + R.Left := Delta - 1; + R.Top := Delta - 1; + R.Right := Width - Integer(Delta) + 1; + R.Bottom := Height - Integer(Delta) + 1; + Canvas.Brush.Color := clInactiveBorder; Canvas.FrameRect(R); - R.Left:=R.Left+1; - R.Top:=R.Top+1; - R.Right:=R.Right-1; - R.Bottom:=R.Bottom-1; + R.Left := R.Left + 1; + R.Top := R.Top + 1; + R.Right := R.Right - 1; + R.Bottom := R.Bottom - 1; Canvas.Brush.Color := Color; - Canvas.FillRect( R ); + Canvas.FillRect(R); end; - if ImageListNormal<>nil then - begin - TMP:=TBitMap.Create; - TMP.Width:=ImageListNormal.ImgWidth; - TMP.Height:=ImageListNormal.ImgHeight; - RDest := Rect(0,0,ImageListNormal.ImgWidth,ImageListNormal.ImgHeight); + if ImageListNormal <> nil then begin + TMP := TBitMap.Create; + TMP.Width := ImageListNormal.ImgWidth; + TMP.Height := ImageListNormal.ImgHeight; + RDest := Rect(0, 0, ImageListNormal.ImgWidth, ImageListNormal.ImgHeight); TMP.Canvas.FillRect(RDest); - TMP.Canvas.CopyRect( RDest, - ImageListNormal.Bitmap.Canvas, - Rect( ImageListNormal.ImgWidth*(CurIndex),0, - ImageListNormal.ImgWidth*(CurIndex+1), - ImageListNormal.ImgHeight)); - TMP.Transparent:=True; - TMP.TransparentColor:=ImageListNormal.TransparentColor; - Canvas.Draw((Width - ImageListNormal.ImgWidth) div 2, - (Height - ImageListNormal.ImgHeight) div 2, - TMP); + TMP.Canvas.CopyRect(RDest, ImageListNormal.Bitmap.Canvas, Rect(ImageListNormal.ImgWidth + * (CurIndex), 0, ImageListNormal.ImgWidth * (CurIndex + 1), ImageListNormal.ImgHeight)); + TMP.Transparent := True; + TMP.TransparentColor := ImageListNormal.TransparentColor; + Canvas.Draw((Width - ImageListNormal.ImgWidth) div 2, (Height - ImageListNormal.ImgHeight) div 2, TMP); TMP.Free; end; inherited; end; -function TKOLImageShow.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLImageShow.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if CurIndex <> 0 then - //SL.Add( Prefix + AName + '.CurIndex := ' + IntToStr( CurIndex ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( CurIndex ) + ') C1 TControl_.SetCurIndex<2>' ); -end; - -function TKOLImageShow.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.P_SetupParams', 0 - @@e_signature: - end; - nparams := 3; - {Result := AParent + ', '; - if ImageListNormal <> nil then - begin - if ImageListNormal.ParentFORM.Name = ParentForm.Name then - Result := Result + 'Result.' + ImageListNormal.Name - else Result := Result + ImageListNormal.ParentFORM.Name +'.'+ ImageListNormal.Name; - end - else - Result := Result + 'nil'; - Result := Result + ', ' + IntToStr( CurIndex );} - {P}Result := ' L(' + IntToStr( CurIndex ) + ')'; - if ImageListNormal <> nil then - if ImageListNormal.ParentForm.Name = ParentForm.Name then - Result := Result + ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + - '.' + ImageListNormal.Name - else - Result := Result + ' Load4 ####' + ImageListNormal.ParentForm.Name + - #13#10' AddWord_LoadRef ##T' + ImageListNormal.ParentKOLForm.FormName + - '.' + ImageListNormal.Name - else Result := Result + #13#10' L(0)'; - {P}Result := Result + #13#10' C2'; -end; - procedure TKOLImageShow.SetBounds(aLeft, aTop, aWidth, aHeight: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.SetBounds', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.SetBounds', 0 + +@@e_signature: end; if (aWidth <> Width) or (aHeight <> Height) then AutoSize := FALSE; @@ -14624,10 +10975,11 @@ end; procedure TKOLImageShow.SetCurIndex(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.SetCurIndex', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.SetCurIndex', 0 + +@@e_signature: end; FCurIndex := Value; Change; @@ -14635,37 +10987,39 @@ begin end; procedure TKOLImageShow.SetHasBorder(const Value: Boolean); -var WasAuto: Boolean; +var + WasAuto: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.SetHasBorder', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.SetHasBorder', 0 + +@@e_signature: end; WasAuto := AutoSize; inherited; AutoSize := WasAuto; - if AutoSize then DoAutoSize; + if AutoSize then + DoAutoSize; Change; end; procedure TKOLImageShow.SetImageListNormal(const Value: TKOLImageList); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.SetImageListNormal', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.SetImageListNormal', 0 + +@@e_signature: end; if FImageListNormal <> nil then - FImageListNormal.NotifyLinkedComponent( Self, noRemoved ); + FImageListNormal.NotifyLinkedComponent(Self, noRemoved); FImageListNormal := Value; - if Value <> nil then - begin - Value.AddToNotifyList( Self ); - if Value.ImgWidth * Value.ImgHeight > 0 then - begin + if Value <> nil then begin + Value.AddToNotifyList(Self); + if Value.ImgWidth * Value.ImgHeight > 0 then begin if AutoSize then DoAutoSize; end; @@ -14678,10 +11032,11 @@ end; procedure TKOLImageShow.SetImgShwAutoSize(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.SetImgShwAutoSize', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.SetImgShwAutoSize', 0 + +@@e_signature: end; fImgShwAutoSize := Value; //Change; @@ -14689,74 +11044,45 @@ begin DoAutoSize; end; -procedure TKOLImageShow.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewImageShow', TRUE, TRUE, '' ); - if CurIndex <> 0 then - begin - KF.FormAddCtlCommand( Name, 'FormSetCurIdx', '' ); - KF.FormAddNumParameter( CurIndex ); - end; -end; - -procedure TKOLImageShow.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLImageShow.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if (KF <> nil) and KF.FormCompact then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + if CurIndex <> 0 then - SL.Add( Prefix + AName + '.CurIndex := ' + IntToStr( CurIndex ) + '; {SetupFirst}' ); + SL.Add(Prefix + AName + '.CurIndex := ' + IntToStr(CurIndex) + '; {SetupFirst}'); end; -procedure TKOLImageShow.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLImageShow.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - if not KF.FormCompact then Exit; - if ImageListNormal <> nil then - SL.Add( ' Result.' + Name + '.ImageListNormal := ' + - 'Result.' + ImageListNormal.Name + ';' ); end; -function TKOLImageShow.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLImageShow.SetupParams(const AName, AParent: TDelphiString): TDelphiString; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageShow.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageShow.SetupParams', 0 + +@@e_signature: end; Result := AParent + ', '; - if (ImageListNormal <> nil) and - (ParentKOLForm <> nil) and not ParentKOLForm.FormCompact then - begin - if ImageListNormal.ParentKOLForm = ParentKOLForm then - Result := Result + 'Result.' + ImageListNormal.Name - else Result := Result + ImageListNormal.ParentFORM.Name +'.'+ ImageListNormal.Name; + if (ImageListNormal <> nil) and (ParentKOLForm <> nil) then begin + if ImageListNormal.ParentKOLForm = ParentKOLForm then + Result := Result + 'Result.' + ImageListNormal.Name + else + Result := Result + ImageListNormal.ParentFORM.Name + '.' + ImageListNormal.Name; end else Result := Result + 'nil'; - Result := Result + ', ' + IntToStr( CurIndex ); -end; - -function TKOLImageShow.SupportsFormCompact: Boolean; -begin - Result := TRUE; + Result := Result + ', ' + IntToStr(CurIndex); end; function TKOLImageShow.WYSIWIGPaintImplemented: Boolean; @@ -14766,14 +11092,14 @@ end; { TKOLLabelEffect } -function TKOLLabelEffect.AdjustVerticalAlign( - Value: TVerticalAlign): TVerticalAlign; +function TKOLLabelEffect.AdjustVerticalAlign(Value: TVerticalAlign): TVerticalAlign; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.AdjustVerticalAlign', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabelEffect.AdjustVerticalAlign', 0 + +@@e_signature: end; Result := Value; end; @@ -14781,16 +11107,18 @@ end; function TKOLLabelEffect.AutoHeight(Canvas: TCanvas): Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.AutoHeight', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabelEffect.AutoHeight', 0 + +@@e_signature: end; Result := inherited AutoHeight(Canvas); - if Font.FontOrientation = 0 then Exit; + if Font.FontOrientation = 0 then + Exit; try - Result := Trunc( Result * cos( Font.FontOrientation / 1800 * PI ) + - inherited AutoWidth(Canvas) * sin( Font.FontOrientation / 1800 * PI ) ); + Result := Trunc(Result * cos(Font.FontOrientation / 1800 * PI) + inherited + AutoWidth(Canvas) * sin(Font.FontOrientation / 1800 * PI)); except end; end; @@ -14798,16 +11126,18 @@ end; function TKOLLabelEffect.AutoWidth(Canvas: TCanvas): Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.AutoWidth', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabelEffect.AutoWidth', 0 + +@@e_signature: end; Result := inherited AutoWidth(Canvas); - if Font.FontOrientation = 0 then Exit; + if Font.FontOrientation = 0 then + Exit; try - Result := Trunc( Result * cos( Font.FontOrientation / 1800 * PI ) + - inherited AutoHeight(Canvas) * sin( Font.FontOrientation / 1800 * PI ) ); + Result := Trunc(Result * cos(Font.FontOrientation / 1800 * PI) + inherited + AutoHeight(Canvas) * sin(Font.FontOrientation / 1800 * PI)); except end; end; @@ -14815,10 +11145,11 @@ end; constructor TKOLLabelEffect.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabelEffect.Create', 0 + +@@e_signature: end; inherited; //Color := clWindowText; @@ -14828,101 +11159,52 @@ end; procedure TKOLLabelEffect.Paint; var - R:TRect; - Flag:DWord; + R: TRect; + Flag: DWord; begin - PrepareCanvasFontForWYSIWIGPaint( Canvas ); + PrepareCanvasFontForWYSIWIGPaint(Canvas); - R.Left:=ShadowDeep; - R.Top:=ShadowDeep; - R.Right:=Width+ShadowDeep; - R.Bottom:=Height+ShadowDeep; - Flag:=0; + R.Left := ShadowDeep; + R.Top := ShadowDeep; + R.Right := Width + ShadowDeep; + R.Bottom := Height + ShadowDeep; + Flag := 0; case TextAlign of - taRight: Flag:=Flag or DT_RIGHT; - taLeft: Flag:=Flag or DT_LEFT; - taCenter: Flag:=Flag or DT_CENTER; + taRight: + Flag := Flag or DT_RIGHT; + taLeft: + Flag := Flag or DT_LEFT; + taCenter: + Flag := Flag or DT_CENTER; end; case VerticalAlign of - vaTop: Flag:=Flag or DT_TOP or DT_SINGLELINE; - vaBottom: Flag:=Flag or DT_BOTTOM or DT_SINGLELINE; - vaCenter: Flag:=Flag or DT_VCENTER or DT_SINGLELINE; + vaTop: + Flag := Flag or DT_TOP or DT_SINGLELINE; + vaBottom: + Flag := Flag or DT_BOTTOM or DT_SINGLELINE; + vaCenter: + Flag := Flag or DT_VCENTER or DT_SINGLELINE; end; if (WordWrap) and (not AutoSize) then - Flag:=Flag or DT_WORDBREAK and not DT_SINGLELINE; - Canvas.Font.Color:=Color2; - DrawText(Canvas.Handle,PChar(Caption),Length(Caption),R,Flag); + Flag := Flag or DT_WORDBREAK and not DT_SINGLELINE; + Canvas.Font.Color := Color2; + DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R, Flag); inherited; end; -procedure TKOLLabelEffect.P_SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.P_SetupFirst', 0 - @@e_signature: - end; - inherited; - if Color2 <> clNone then - //SL.Add( Prefix + AName + '.Color2 := ' + Color2Str( Color2 ) + ';' ); - {P}SL.Add( ' L($' + IntToHex( Integer( Color2 ), 6 ) + - ') C1 TControl_.SetColor2<2>' ); - if Ctl3D then - //SL.Add( Prefix + AName + '.Ctl3D := TRUE;' ); - {P}SL.Add( ' L(1) C1 TControl_.SetCtl3D<2>' ); -end; - -function TKOLLabelEffect.P_SetupParams(const AName, - AParent: String; var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.P_SetupParams', 0 - @@e_signature: - end; - //Result := AParent + ', ' + StringConstant('Caption', Caption) + ', ' + - // IntToStr( ShadowDeep ); - {P}Result := P_StringConstant( 'Caption', Caption ) + - #13#10' L(' + IntToStr( ShadowDeep ) + ') xySwap' + - #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + '.' + - Remove_Result_dot( AParent ); - nparams := 3; -end; - -procedure TKOLLabelEffect.P_SetupTextAlign(SL: TStrings; - const AName: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.P_SetupTextAlign', 0 - @@e_signature: - end; - if TextAlign <> taCenter then - //SL.Add( ' ' + AName + '.TextAlign := ' + TextAligns[ TextAlign ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( TextAlign ) ) + ') ' + - ' C1 TControl_.SetTextAlign<2>' ); - if VerticalAlign <> vaTop then - //SL.Add( ' ' + AName + '.VerticalAlign := ' + VertAligns[ VerticalAlign ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( VerticalAlignAsKOLVerticalAlign ) + ') ' + - ' C1 TControl_.SetVerticalAlign<2>' ); -end; - procedure TKOLLabelEffect.SetColor2(const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.SetColor2', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabelEffect.SetColor2', 0 + +@@e_signature: end; FColor2 := Value; Change; @@ -14932,135 +11214,86 @@ end; procedure TKOLLabelEffect.SetShadowDeep(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.SetShadowDeep', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabelEffect.SetShadowDeep', 0 + +@@e_signature: end; FShadowDeep := Value; Change; Invalidate; end; -procedure TKOLLabelEffect.SetupConstruct_Compact; -var KF: TKOLForm; - C: String; -begin - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddCtlParameter( Name ); - KF.FormCurrentCtlForTransparentCalls := Name; - KF.FormAddAlphabet( 'FormNewLabelEffect', TRUE, TRUE, '' ); - C := Caption; - if not KF.AssignTextToControls then - C := ''; - KF.FormAddStrParameter( C ); - KF.FormAddNumParameter( ShadowDeep ); -end; - -procedure TKOLLabelEffect.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; - C: DWORD; +procedure TKOLLabelEffect.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabelEffect.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if Color2 <> clNone then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetColor2', '' ); - C := Color2; - if C and $FF000000 = $FF000000 then - C := C and $FFFFFF or $80000000; - C := (C shl 1) or (C shr 31); - RptDetailed( 'Prepare FormSetColor parameter, src color =$' + - Int2Hex( Color2, 2 ) + ', coded color =$' + - Int2Hex( C, 2 ), CYAN ); - KF.FormAddNumParameter( C ); - end else - SL.Add( Prefix + AName + '.Color2 := TColor(' + Color2Str( Color2 ) + ');' ); - if Ctl3D then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetCtl3D', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.Ctl3D := TRUE;' ); + if Color2 <> clNone then + SL.Add(Prefix + AName + '.Color2 := TColor(' + Color2Str(Color2) + ');'); + + if Ctl3D then + SL.Add(Prefix + AName + '.Ctl3D := TRUE;'); end; -function TKOLLabelEffect.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLLabelEffect.SetupParams(const AName, AParent: TDelphiString): TDelphiString; var {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabelEffect.SetupParams', 0 + +@@e_signature: end; - if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - C := StringConstant('Caption', Caption ) - else - C := ''''''; + if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then + C := StringConstant('Caption', Caption) + else + C := ''''''; {$IFDEF _D2009orHigher} - if C <> '''''' then - begin - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; + if C <> '''''' then begin + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + int2str(ord(C[i])); + C := C2; end; {$ENDIF} - Result := AParent + ', ' + C + ', ' + IntToStr( ShadowDeep ); + Result := AParent + ', ' + C + ', ' + IntToStr(ShadowDeep); end; -procedure TKOLLabelEffect.SetupTextAlign(SL: TStrings; - const AName: String); -var KF: TKOLForm; +procedure TKOLLabelEffect.SetupTextAlign(SL: TStrings; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLLabelEffect.SetupTextAlign', 0 - @@e_signature: - end; - KF := ParentKOLForm; - if TextAlign <> taCenter then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetTextAlign', '' ); - KF.FormAddNumParameter( Integer( TextAlign ) ); - end else - SL.Add( ' ' + AName + '.TextAlign := KOL.' + TextAligns[ TextAlign ] + ';' ); + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLLabelEffect.SetupTextAlign', 0 - if VerticalAlign <> vaTop then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetTextVAlign', '' ); - KF.FormAddNumParameter( Integer( VerticalAlign ) ); - end else - SL.Add( ' ' + AName + '.VerticalAlign := KOL.' + VertAligns[ VerticalAlign ] + ';' ); +@@e_signature: + end; + + if TextAlign <> taCenter then + SL.Add(' ' + AName + '.TextAlign := KOL.' + TextAligns[TextAlign] + ';'); + + if VerticalAlign <> vaTop then + SL.Add(' ' + AName + '.VerticalAlign := KOL.' + VertAligns[VerticalAlign] + ';'); end; procedure TKOLLabelEffect.SetWindowed(const Value: Boolean); begin - inherited SetWindowed( TRUE ); -end; - -function TKOLLabelEffect.SupportsFormCompact: Boolean; -begin - Result := TRUE; + inherited SetWindowed(TRUE); end; { TKOLScrollBox } @@ -15068,40 +11301,42 @@ end; constructor TKOLScrollBox.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBox.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLScrollBox.Create', 0 + +@@e_signature: end; inherited; FEdgeStyle := esLowered; FScrollBars := ssBoth; - ControlStyle := ControlStyle + [ csAcceptsControls ]; + ControlStyle := ControlStyle + [csAcceptsControls]; FHasScrollbarsToOverride := TRUE; end; function TKOLScrollBox.IsControlContainer: Boolean; -var I: Integer; - C: TComponent; - K: TControl; +var + I: Integer; + C: TComponent; + K: TControl; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBox.IsControlContainer', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLScrollBox.IsControlContainer', 0 + +@@e_signature: end; Result := ControlContainer; - if Result then Exit; - if Owner = nil then Exit; - for I := 0 to Owner.ComponentCount - 1 do - begin - C := Owner.Components[ I ]; - if C is TControl then - begin + if Result then + Exit; + if Owner = nil then + Exit; + for I := 0 to Owner.ComponentCount - 1 do begin + C := Owner.Components[I]; + if C is TControl then begin K := C as TControl; - if K.Parent = Self then - begin + if K.Parent = Self then begin Result := TRUE; Exit; end; @@ -15118,50 +11353,14 @@ begin inherited; end; -function TKOLScrollBox.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLScrollBox.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -//var S: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBox.P_SetupParams', 0 - @@e_signature: - end; - {Result := AParent + ', ' + EdgeStyles[ EdgeStyle ]; - if not IsControlContainer then - begin - S := ''; - case ScrollBars of - ssHorz: S := 'sbHorizontal'; - ssVert: S := 'sbVertical'; - ssBoth: S := 'sbHorizontal, sbVertical'; - end; - Result := Result + ', [ ' + S + ' ]'; - end;} - nparams := 2; - Result := ' DUP C2R'; - if not IsControlContainer then - begin - nparams := 3; - {P}Result := Result + #13#10' L(' + IntToStr( PByte( @ ScrollBars )^ ) + ')'; - end; - {P}Result := Result + #13#10' L(' + IntToStr( PByte( @ EdgeStyle )^ ) + ')' + - ' R2C'; -end; - procedure TKOLScrollBox.SetControlContainer(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBox.SetControlContainer', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLScrollBox.SetControlContainer', 0 + +@@e_signature: end; FControlContainer := Value; Change; @@ -15170,23 +11369,25 @@ end; procedure TKOLScrollBox.SetEdgeStyle(const Value: TEdgeStyle); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBox.SetEdgeStyle', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLScrollBox.SetEdgeStyle', 0 + +@@e_signature: end; FEdgeStyle := Value; - ReAlign( FALSE ); + ReAlign(FALSE); Change; end; procedure TKOLScrollBox.SetScrollBars(const Value: TScrollBars); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBox.SetScrollBars', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLScrollBox.SetScrollBars', 0 + +@@e_signature: end; FScrollBars := Value; Change; @@ -15194,67 +11395,46 @@ begin Invalidate; end; -procedure TKOLScrollBox.SetupConstruct_Compact; -var KF: TKOLForm; - i: Integer; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNew' + TypeName, TRUE, TRUE, '' ); - KF.FormAddNumParameter( Integer( EdgeStyle ) ); - if TypeName = 'ScrollBox' then - begin - CASE ScrollBars OF - ssNone: i := 0; - ssHorz: i := 1; - ssVert: i := 2; - else i := 3; - END; - KF.FormAddNumParameter( i ); - end; -end; - -function TKOLScrollBox.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -const EdgeStyles: array[ TEdgeStyle ] of String = - ( 'esRaised', 'esLowered', 'esNone', 'esTransparent', 'esSolid' ); -var S: String; +function TKOLScrollBox.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +const + EdgeStyles: array[TEdgeStyle] of string = ('esRaised', 'esLowered', 'esNone', 'esTransparent', 'esSolid'); +var + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBox.SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLScrollBox.SetupParams', 0 + +@@e_signature: end; - Result := AParent + ', ' + EdgeStyles[ EdgeStyle ]; - if not IsControlContainer then - begin + Result := AParent + ', ' + EdgeStyles[EdgeStyle]; + if not IsControlContainer then begin S := ''; case ScrollBars of - ssHorz: S := 'sbHorizontal'; - ssVert: S := 'sbVertical'; - ssBoth: S := 'sbHorizontal, sbVertical'; + ssHorz: + S := 'sbHorizontal'; + ssVert: + S := 'sbVertical'; + ssBoth: + S := 'sbHorizontal, sbVertical'; end; Result := Result + ', [ ' + S + ' ]'; end; end; -function TKOLScrollBox.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - -function TKOLScrollBox.TypeName: String; +function TKOLScrollBox.TypeName: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBox.TypeName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLScrollBox.TypeName', 0 + +@@e_signature: end; Result := inherited TypeName; - if IsControlContainer then - Result := 'ScrollBoxEx'; + if IsControlContainer then + Result := 'ScrollBoxEx'; end; function TKOLScrollBox.WYSIWIGPaintImplemented: Boolean; @@ -15264,66 +11444,67 @@ end; { TKOLMDIClient } -var MDIWarningLastTime: Integer; +var + MDIWarningLastTime: Integer; + procedure MDIClientMustBeAChildOfTheFormWarning; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'MDIClientMustBeAChildOfTheFormWarning', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'MDIClientMustBeAChildOfTheFormWarning', 0 + +@@e_signature: end; - if Abs( Integer( GetTickCount ) - MDIWarningLastTime ) > 60000 then - begin + if Abs(Integer(GetTickCount) - MDIWarningLastTime) > 60000 then begin MDIWarningLastTime := GetTickCount; - ShowMessage( 'TKOLMDIClient control must be a child of the form itself!'#13 + - 'Otherwise maximizing of MDI children will lead to access violation ' + - 'at run-time execution.' ); + ShowMessage('TKOLMDIClient control must be a child of the form itself!'#13 + + 'Otherwise maximizing of MDI children will lead to access violation ' + 'at run-time execution.'); end; end; procedure MsgDuplicatedMDIClient; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'MsgDuplicatedMDIClient', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'MsgDuplicatedMDIClient', 0 + +@@e_signature: end; - if Abs( Integer( GetTickCount ) - MDIWarningLastTime ) > 60000 then - begin + if Abs(Integer(GetTickCount) - MDIWarningLastTime) > 60000 then begin MDIWarningLastTime := GetTickCount; - ShowMessage( 'TKOLMDIClient control must be a single on the form, ' + - 'but another instance of MDI client object found there.' ); + ShowMessage('TKOLMDIClient control must be a single on the form, ' + + 'but another instance of MDI client object found there.'); end; end; constructor TKOLMDIClient.Create(AOwner: TComponent); -var I: Integer; - C: TComponent; +var + I: Integer; + C: TComponent; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMDIClient.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMDIClient.Create', 0 + +@@e_signature: end; inherited; Align := caClient; - if (AOwner <> nil) and (AOwner is TForm) then - begin - for I := 0 to (AOwner as TForm).ComponentCount-1 do - begin - C := (AOwner as TForm).Components[ I ]; - if C = Self then continue; - if C is TKOLMDIClient then - begin + if (AOwner <> nil) and (AOwner is TForm) then begin + for I := 0 to (AOwner as TForm).ComponentCount - 1 do begin + C := (AOwner as TForm).Components[I]; + if C = Self then + continue; + if C is TKOLMDIClient then begin MsgDuplicatedMDIClient; break; end; end; end; - FTimer := TTimer.Create( Self ); + FTimer := TTimer.Create(Self); FTimer.Interval := 200; FTimer.OnTimer := Tick; FTimer.Enabled := TRUE; @@ -15333,153 +11514,84 @@ end; destructor TKOLMDIClient.Destroy; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMDIClient.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMDIClient.Destroy', 0 + +@@e_signature: end; inherited; MDIWarningLastTime := 0; end; -function TKOLMDIClient.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; +function TKOLMDIClient.SetupParams(const AName, AParent: TDelphiString): TDelphiString; -function TKOLMDIClient.P_SetupParams(const AName, AParent: String; var nparams: Integer): String; - - function FindWindowMenu( MI: TKOLMenuItem ): Integer; - var I: Integer; - SMI: TKOLMenuItem; + function FindWindowMenu(MI: TKOLMenuItem): Integer; + var + I: Integer; + SMI: TKOLMenuItem; begin Result := 0; if MI.WindowMenu then Result := MI.itemindex else - for I := 0 to MI.Count-1 do - begin - SMI := MI.SubItems[ I ]; - Result := FindWindowMenu( SMI ); - if Result > 0 then - break; - end; + for I := 0 to MI.Count - 1 do begin + SMI := MI.SubItems[I]; + Result := FindWindowMenu(SMI); + if Result > 0 then + break; + end; end; -var I, J, WM: Integer; - C: TComponent; - MM: TKOLMainMenu; - MI: TKOLMenuItem; - S: String; +var + I, J, WM: Integer; + C: TComponent; + MM: TKOLMainMenu; + MI: TKOLMenuItem; + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMDIClient.P_SetupParams', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMDIClient.SetupParams', 0 + +@@e_signature: end; - //Result := AParent + ', '; - S := ' L(0)'; - for I := 0 to (Owner as TForm).ComponentCount-1 do - begin - C := (Owner as TForm).Components[ I ]; - if C is TKOLMainMenu then - begin - MM := C as TKOLMainMenu; - for J := 0 to MM.Count-1 do - begin - MI := MM.Items[ J ]; - WM := FindWindowMenu( MI ); - if WM > 0 then - begin - //S := 'Result.' + MM.Name + '.ItemHandle[ ' + IntToStr( WM ) + ' ]'; - {P}S := ' L(' + IntToStr( WM ) + - ') LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + - '.' + MM.Name + ' TMenu.GetMenuItemHandle<2> RESULT'; - break; - end; + Result := AParent + ', '; + S := '0'; + for I := 0 to (Owner as TForm).ComponentCount - 1 do begin + C := (Owner as TForm).Components[I]; + if C is TKOLMainMenu then begin + MM := C as TKOLMainMenu; + for J := 0 to MM.Count - 1 do begin + MI := MM.Items[J]; + WM := FindWindowMenu(MI); + if WM > 0 then begin + S := 'Result.' + MM.Name + '.ItemHandle[ ' + IntToStr(WM) + ' ]'; + break; end; - break; end; - end; - //Result := Result + S; - {P}Result := S + - #13#10' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.FormName + - '.' + Remove_Result_dot( AParent ); - nparams := 2; -end; - -function TKOLMDIClient.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; - - function FindWindowMenu( MI: TKOLMenuItem ): Integer; - var I: Integer; - SMI: TKOLMenuItem; - begin - Result := 0; - if MI.WindowMenu then - Result := MI.itemindex - else - for I := 0 to MI.Count-1 do - begin - SMI := MI.SubItems[ I ]; - Result := FindWindowMenu( SMI ); - if Result > 0 then - break; + break; end; end; - -var I, J, WM: Integer; - C: TComponent; - MM: TKOLMainMenu; - MI: TKOLMenuItem; - S: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMDIClient.SetupParams', 0 - @@e_signature: - end; - Result := AParent + ', '; - S := '0'; - for I := 0 to (Owner as TForm).ComponentCount-1 do - begin - C := (Owner as TForm).Components[ I ]; - if C is TKOLMainMenu then - begin - MM := C as TKOLMainMenu; - for J := 0 to MM.Count-1 do - begin - MI := MM.Items[ J ]; - WM := FindWindowMenu( MI ); - if WM > 0 then - begin - S := 'Result.' + MM.Name + '.ItemHandle[ ' + - IntToStr( WM ) + ' ]'; - break; - end; - end; - break; - end; - end; - Result := Result + S; + Result := Result + S; end; procedure TKOLMDIClient.Tick(Sender: TObject); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMDIClient.Tick', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLMDIClient.Tick', 0 + +@@e_signature: end; - if Parent <> nil then - begin + if Parent <> nil then begin FTimer.Enabled := FALSE; if Parent <> Owner then MDIClientMustBeAChildOfTheFormWarning else - ParentKOLForm.AlignChildren( nil, FALSE ); + ParentKOLForm.AlignChildren(nil, FALSE); FTimer.Free; FTimer := nil; end; @@ -15490,12 +11602,14 @@ end; procedure TKOLToolbarButton.Change; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Change', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Change', 0 + +@@e_signature: end; - if csLoading in ComponentState then Exit; + if csLoading in ComponentState then + Exit; if FToolbar <> nil then begin FToolbar.UpdateButtons; FToolbar.Change; @@ -15505,57 +11619,59 @@ end; constructor TKOLToolbarButton.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Create', 0 + +@@e_signature: end; inherited; if AOwner <> nil then - if AOwner is TKOLToolbar then - begin - FToolbar := AOwner as TKOLToolbar; - FToolbar.FItems.Add( Self ); - end; + if AOwner is TKOLToolbar then begin + FToolbar := AOwner as TKOLToolbar; + FToolbar.FItems.Add(Self); + end; Fpicture := TPicture.Create; Fvisible := TRUE; Fenabled := TRUE; FimgIndex := -1; end; -procedure TKOLToolbarButton.DefProps(const Prefix: String; Filer: Tfiler); +procedure TKOLToolbarButton.DefProps(const Prefix: string; Filer: Tfiler); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.DefProps', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.DefProps', 0 + +@@e_signature: end; - Filer.DefineProperty( Prefix + 'Name', LoadName, SaveName, TRUE ); - Filer.DefineProperty( Prefix + 'caption', LoadCaption, SaveCaption, TRUE ); - Filer.DefineProperty( Prefix + 'checked', LoadChecked, SaveChecked, TRUE ); - Filer.DefineProperty( Prefix + 'dropdown', LoadDropDown, SaveDropDown, TRUE ); - Filer.DefineProperty( Prefix + 'enabled', LoadEnabled, SaveEnabled, TRUE ); - Filer.DefineProperty( Prefix + 'separator', LoadSeparator, SaveSeparator, TRUE ); - Filer.DefineProperty( Prefix + 'tooltip', LoadTooltip, SaveTooltip, TRUE ); - Filer.DefineProperty( Prefix + 'visible', LoadVisible, SaveVisible, TRUE ); - Filer.DefineProperty( Prefix + 'onClick', LoadOnClick, SaveOnClick, TRUE ); - Filer.DefineProperty( Prefix + 'picture', LoadPicture, SavePicture, TRUE ); - Filer.DefineProperty( Prefix + 'sysimg', LoadSysImg, SaveSysImg, TRUE ); - Filer.DefineProperty( Prefix + 'radioGroup', LoadRadioGroup, SaveRadioGroup, radioGroup <> 0 ); - Filer.DefineProperty( Prefix + 'imgIndex', LoadImgIndex, SaveImgIndex, imgIndex >= 0 ); + Filer.DefineProperty(Prefix + 'Name', LoadName, SaveName, TRUE); + Filer.DefineProperty(Prefix + 'caption', LoadCaption, SaveCaption, TRUE); + Filer.DefineProperty(Prefix + 'checked', LoadChecked, SaveChecked, TRUE); + Filer.DefineProperty(Prefix + 'dropdown', LoadDropDown, SaveDropDown, TRUE); + Filer.DefineProperty(Prefix + 'enabled', LoadEnabled, SaveEnabled, TRUE); + Filer.DefineProperty(Prefix + 'separator', LoadSeparator, SaveSeparator, TRUE); + Filer.DefineProperty(Prefix + 'tooltip', LoadTooltip, SaveTooltip, TRUE); + Filer.DefineProperty(Prefix + 'visible', LoadVisible, SaveVisible, TRUE); + Filer.DefineProperty(Prefix + 'onClick', LoadOnClick, SaveOnClick, TRUE); + Filer.DefineProperty(Prefix + 'picture', LoadPicture, SavePicture, TRUE); + Filer.DefineProperty(Prefix + 'sysimg', LoadSysImg, SaveSysImg, TRUE); + Filer.DefineProperty(Prefix + 'radioGroup', LoadRadioGroup, SaveRadioGroup, radioGroup <> 0); + Filer.DefineProperty(Prefix + 'imgIndex', LoadImgIndex, SaveImgIndex, imgIndex >= 0); end; destructor TKOLToolbarButton.Destroy; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Destroy', 0 + +@@e_signature: end; if FToolbar <> nil then - FToolbar.FItems.Remove( Self ); + FToolbar.FItems.Remove(Self); Fpicture.Free; inherited; end; @@ -15563,24 +11679,26 @@ end; function TKOLToolbarButton.HasPicture: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.HasPicture', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.HasPicture', 0 + +@@e_signature: end; {if Assigned( picture ) then Rpt( '%%%%%%%% ' + Name + '.picture: Width=' + IntToStr( picture.Width ) + ' Height=' + IntToStr( picture.Height ) );} - Result := Assigned( picture ) and (picture.Width * picture.Height > 0); + Result := Assigned(picture) and (picture.Width * picture.Height > 0); end; procedure TKOLToolbarButton.LoadCaption(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadCaption', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadCaption', 0 + +@@e_signature: end; Fcaption := Reader.ReadString; end; @@ -15588,10 +11706,11 @@ end; procedure TKOLToolbarButton.LoadChecked(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadChecked', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadChecked', 0 + +@@e_signature: end; Fchecked := Reader.ReadBoolean; end; @@ -15599,10 +11718,11 @@ end; procedure TKOLToolbarButton.LoadDropDown(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadDropDown', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadDropDown', 0 + +@@e_signature: end; Fdropdown := Reader.ReadBoolean; end; @@ -15610,10 +11730,11 @@ end; procedure TKOLToolbarButton.LoadEnabled(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadEnabled', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadEnabled', 0 + +@@e_signature: end; Fenabled := Reader.ReadBoolean; end; @@ -15624,20 +11745,24 @@ begin end; procedure TKOLToolbarButton.LoadName(Reader: TReader); -var S: String; +var + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadName', 0 + +@@e_signature: end; S := Reader.ReadString; - if FToolbar = nil then Exit; - if FToolbar.FindComponent( S ) <> nil then Exit; - if (FToolbar.Owner <> nil) and (FToolbar.Owner is TForm) then - begin - if (FToolbar.Owner as TForm).FindComponent( S ) <> nil then Exit; + if FToolbar = nil then + Exit; + if FToolbar.FindComponent(S) <> nil then + Exit; + if (FToolbar.Owner <> nil) and (FToolbar.Owner is TForm) then begin + if (FToolbar.Owner as TForm).FindComponent(S) <> nil then + Exit; Name := S; end; end; @@ -15645,43 +11770,45 @@ end; procedure TKOLToolbarButton.LoadOnClick(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadOnClick', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadOnClick', 0 + +@@e_signature: end; fOnClickMethodName := Reader.ReadString; end; procedure TKOLToolbarButton.LoadPicture(Reader: TReader); -var S: String; - MS: TMemoryStream; - Bmp: TBitmap; +var + S: string; + MS: TMemoryStream; + Bmp: TBitmap; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadPicture', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadPicture', 0 + +@@e_signature: end; S := Reader.ReadString; //ShowMessage( 'Read picture: <' + S + '>' ); - if Trim( S ) <> '' then - begin + if Trim(S) <> '' then begin MS := TMemoryStream.Create; - TRY - MS.Write( S[ 1 ], Length( S ) ); + try + MS.Write(S[1], Length(S)); MS.Position := 0; Bmp := TBitmap.Create; - TRY - Bmp.LoadFromStream( MS ); - Fpicture.Assign( Bmp ); - FINALLY + try + Bmp.LoadFromStream(MS); + Fpicture.Assign(Bmp); + finally Bmp.Free; - END; - FINALLY + end; + finally MS.Free; - END; + end; end; //ShowMessage( 'Read picture - end' ); end; @@ -15689,10 +11816,11 @@ end; procedure TKOLToolbarButton.LoadProps(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadProps', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadProps', 0 + +@@e_signature: end; Fcaption := Reader.ReadString; Fchecked := Reader.ReadBoolean; @@ -15707,10 +11835,11 @@ end; procedure TKOLToolbarButton.LoadRadioGroup(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadRadioGroup', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadRadioGroup', 0 + +@@e_signature: end; FradioGroup := Reader.ReadInteger; end; @@ -15718,26 +11847,28 @@ end; procedure TKOLToolbarButton.LoadSeparator(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadSeparator', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadSeparator', 0 + +@@e_signature: end; Fseparator := Reader.ReadBoolean; end; procedure TKOLToolbarButton.LoadSysImg(Reader: TReader); begin - Fsysimg := TSystemToolbarImage( Reader.ReadInteger ); + Fsysimg := TSystemToolbarImage(Reader.ReadInteger); end; procedure TKOLToolbarButton.LoadTooltip(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadTooltip', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadTooltip', 0 + +@@e_signature: end; Ftooltip := Reader.ReadString; end; @@ -15745,10 +11876,11 @@ end; procedure TKOLToolbarButton.LoadVisible(Reader: TReader); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.LoadVisible', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.LoadVisible', 0 + +@@e_signature: end; Fvisible := Reader.ReadBoolean; end; @@ -15766,176 +11898,189 @@ end; procedure TKOLToolbarButton.SaveCaption(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveCaption', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveCaption', 0 + +@@e_signature: end; - Writer.WriteString( Fcaption ); + Writer.WriteString(Fcaption); end; procedure TKOLToolbarButton.SaveChecked(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveChecked', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveChecked', 0 + +@@e_signature: end; - Writer.WriteBoolean( Fchecked ); + Writer.WriteBoolean(Fchecked); end; procedure TKOLToolbarButton.SaveDropDown(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveDropDown', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveDropDown', 0 + +@@e_signature: end; - Writer.WriteBoolean( Fdropdown ); + Writer.WriteBoolean(Fdropdown); end; procedure TKOLToolbarButton.SaveEnabled(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveEnabled', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveEnabled', 0 + +@@e_signature: end; - Writer.WriteBoolean( Fenabled ); + Writer.WriteBoolean(Fenabled); end; procedure TKOLToolbarButton.SaveImgIndex(Writer: TWriter); begin - Writer.WriteInteger( FimgIndex ); + Writer.WriteInteger(FimgIndex); end; procedure TKOLToolbarButton.SaveName(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveName', 0 + +@@e_signature: end; - Writer.WriteString( Name ); + Writer.WriteString(Name); end; procedure TKOLToolbarButton.SaveOnClick(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveOnClick', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveOnClick', 0 + +@@e_signature: end; - Writer.WriteString( fOnClickMethodName ); + Writer.WriteString(fOnClickMethodName); end; procedure TKOLToolbarButton.SavePicture(Writer: TWriter); -var S: String; - MS: TMemoryStream; - Bmp: TBitmap; +var + S: string; + MS: TMemoryStream; + Bmp: TBitmap; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SavePicture', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SavePicture', 0 + +@@e_signature: end; MS := TMemoryStream.Create; - TRY + try S := ''; - if Assigned( picture ) and (picture.Width * picture.Height > 0) then - begin + if Assigned(picture) and (picture.Width * picture.Height > 0) then begin Bmp := TBitmap.Create; - TRY - Bmp.Assign( picture.Graphic ); - Bmp.SaveToStream( MS ); - FINALLY + try + Bmp.Assign(picture.Graphic); + Bmp.SaveToStream(MS); + finally Bmp.Free; - END; - SetLength( S, MS.Size ); - Move( MS.Memory^, S[ 1 ], MS.Size ); + end; + SetLength(S, MS.Size); + Move(MS.Memory^, S[1], MS.Size); end; - Writer.WriteString( S ); - FINALLY + Writer.WriteString(S); + finally MS.Free; - END; + end; end; procedure TKOLToolbarButton.SaveProps(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveProps', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveProps', 0 + +@@e_signature: end; - Writer.WriteString( Fcaption ); - Writer.WriteBoolean( Fchecked ); - Writer.WriteBoolean( Fdropdown ); - Writer.WriteBoolean( Fenabled ); - Writer.WriteBoolean( Fseparator ); - Writer.WriteString( Ftooltip ); - Writer.WriteBoolean( Fvisible ); - Writer.WriteString( fOnClickMethodName ); + Writer.WriteString(Fcaption); + Writer.WriteBoolean(Fchecked); + Writer.WriteBoolean(Fdropdown); + Writer.WriteBoolean(Fenabled); + Writer.WriteBoolean(Fseparator); + Writer.WriteString(Ftooltip); + Writer.WriteBoolean(Fvisible); + Writer.WriteString(fOnClickMethodName); end; procedure TKOLToolbarButton.SaveRadioGroup(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveRadioGroup', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveRadioGroup', 0 + +@@e_signature: end; - Writer.WriteInteger( FradioGroup ); + Writer.WriteInteger(FradioGroup); end; procedure TKOLToolbarButton.SaveSeparator(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveSeparator', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveSeparator', 0 + +@@e_signature: end; - Writer.WriteBoolean( Fseparator ); + Writer.WriteBoolean(Fseparator); end; procedure TKOLToolbarButton.SaveSysImg(Writer: TWriter); begin - Writer.WriteInteger( Integer( Fsysimg ) ); + Writer.WriteInteger(Integer(Fsysimg)); end; procedure TKOLToolbarButton.SaveTooltip(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveTooltip', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveTooltip', 0 + +@@e_signature: end; - Writer.WriteString( Ftooltip ); + Writer.WriteString(Ftooltip); end; procedure TKOLToolbarButton.SaveVisible(Writer: TWriter); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SaveVisible', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SaveVisible', 0 + +@@e_signature: end; - Writer.WriteBoolean( Fvisible ); + Writer.WriteBoolean(Fvisible); end; procedure TKOLToolbarButton.Setaction(const Value: TKOLAction); begin - if Faction = Value then exit; + if Faction = Value then + exit; if Faction <> nil then Faction.UnLinkComponent(Self); Faction := Value; @@ -15944,19 +12089,21 @@ begin Change; end; -procedure TKOLToolbarButton.Setcaption(const Value: String); +procedure TKOLToolbarButton.Setcaption(const Value: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Setcaption', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Setcaption', 0 + +@@e_signature: end; - if Fcaption = Value then Exit; + if Fcaption = Value then + Exit; if Faction = nil then Fcaption := Value else - Fcaption:=Faction.Caption; + Fcaption := Faction.Caption; if Fcaption <> '-' then Fseparator := FALSE; Change; @@ -15964,34 +12111,38 @@ end; procedure TKOLToolbarButton.SetCheckable(const Value: Boolean); begin - ShowMessage( 'Jus change property radioGroup!' ) + ShowMessage('Jus change property radioGroup!') end; procedure TKOLToolbarButton.Setchecked(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Setchecked', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Setchecked', 0 + +@@e_signature: end; - if FChecked = Value then Exit; + if FChecked = Value then + Exit; if Faction = nil then FChecked := Value else - FChecked:=Faction.Checked; + FChecked := Faction.Checked; Change; end; procedure TKOLToolbarButton.Setdropdown(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Setdropdown', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Setdropdown', 0 + +@@e_signature: end; - if Fdropdown = Value then Exit; + if Fdropdown = Value then + Exit; Fdropdown := Value; Change; end; @@ -15999,16 +12150,18 @@ end; procedure TKOLToolbarButton.Setenabled(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Setenabled', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Setenabled', 0 + +@@e_signature: end; - if Fenabled = Value then Exit; + if Fenabled = Value then + Exit; if Faction = nil then Fenabled := Value else - Fenabled:=Faction.Enabled; + Fenabled := Faction.Enabled; Change; end; @@ -16022,132 +12175,128 @@ begin end; procedure TKOLToolbarButton.SetName(const NewName: TComponentName); -var OldName, NewMethodName: String; - F: TForm; - D: IDesigner; - FD: IFormDesigner; +var + OldName, NewMethodName: string; + F: TForm; + D: IDesigner; + FD: IFormDesigner; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SetName', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SetName', 0 + +@@e_signature: end; OldName := Name; //Rpt( 'Renaming ' + OldName + ' to ' + NewName ); - if (FToolbar <> nil) and (OldName <> '') and - (FToolbar.FindComponent( NewName ) <> nil) then - begin - ShowMessage( 'Can not rename to ' + NewName + ' - such name is already used.' ); + if (FToolbar <> nil) and (OldName <> '') and (FToolbar.FindComponent(NewName) <> nil) then begin + ShowMessage('Can not rename to ' + NewName + ' - such name is already used.'); Exit; end; - if (OldName <> '') and (NewName = '') then - begin - ShowMessage( 'Can not rename to '''' - name must not be empty.' ); + if (OldName <> '') and (NewName = '') then begin + ShowMessage('Can not rename to '''' - name must not be empty.'); Exit; end; inherited; - if OldName = '' then Exit; + if OldName = '' then + Exit; if fOnClickMethodName <> '' then - if FToolbar <> nil then - begin - if LowerCase( FToolbar.Name + OldName + 'Click' ) = LowerCase( fOnClickMethodName ) then - begin + if FToolbar <> nil then begin + if LowerCase(FToolbar.Name + OldName + 'Click') = LowerCase(fOnClickMethodName) then begin // rename event handler also here: - F := FToolbar.ParentForm; - NewMethodName := FToolbar.Name + NewName + 'Click'; - if F <> nil then - begin + F := FToolbar.ParentForm; + NewMethodName := FToolbar.Name + NewName + 'Click'; + if F <> nil then begin {$IFDEF _D6orHigher} - F.Designer.QueryInterface(IFormDesigner,D); + F.Designer.QueryInterface(IFormDesigner, D); {$ELSE} - D := F.Designer; + D := F.Designer; {$ENDIF} - if D <> nil then - if QueryFormDesigner( D, FD ) then - begin - if not FD.MethodExists( NewMethodName ) then - begin - FD.RenameMethod( fOnClickMethodName, NewMethodName ); - if FD.MethodExists( NewMethodName ) then - fOnClickMethodName := NewMethodName; - end; + if D <> nil then + if QueryFormDesigner(D, FD) then begin + if not FD.MethodExists(NewMethodName) then begin + FD.RenameMethod(fOnClickMethodName, NewMethodName); + if FD.MethodExists(NewMethodName) then + fOnClickMethodName := NewMethodName; + end; + end; end; end; end; - end; Change; end; procedure TKOLToolbarButton.SetonClick(const Value: TOnToolbarButtonClick); -var F: TForm; +var + F: TForm; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.SetOnClick', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.SetOnClick', 0 + +@@e_signature: end; - if @ fOnClick = @ Value then Exit; + if @fOnClick = @Value then + Exit; FonClick := Value; - if TMethod( Value ).Code <> nil then - begin - if FToolbar <> nil then - begin + if TMethod(Value).Code <> nil then begin + if FToolbar <> nil then begin F := FToolbar.ParentForm; - fOnClickMethodName := F.MethodName( TMethod( Value ).Code ); + fOnClickMethodName := F.MethodName(TMethod(Value).Code); end; end - else + else FOnClickMethodName := ''; Change; end; procedure TKOLToolbarButton.Setpicture(Value: TPicture); -var Bmp: TBitmap; - I: Integer; +var + Bmp: TBitmap; + I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Setpicture', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Setpicture', 0 + +@@e_signature: end; if Value <> nil then if Value.Width * Value.Height = 0 then Value := nil; - if Value = nil then - begin + if Value = nil then begin Fpicture.Free; Fpicture := TPicture.Create; end - else - begin - if FToolbar.ImageListsUsed then - begin - I := MessageBox( Application.Handle, 'Image list(s) will be detached from the toolbar.'#13#10 + - 'Continue?', PChar( Application.Title + ' : ' + Name ), MB_OKCANCEL ); - if I <> ID_OK then Exit; + else begin + if FToolbar.ImageListsUsed then begin + I := MessageBox(Application.Handle, + 'Image list(s) will be detached from the toolbar.'#13#10 + 'Continue?', + PChar(Application.Title + ' : ' + Name), MB_OKCANCEL); + if I <> ID_OK then + Exit; FToolbar.imageListNormal := nil; FToolbar.imageListDisabled := nil; FToolbar.imageListHot := nil; end; Bmp := TBitmap.Create; - TRY + try Bmp.Width := Value.Width; Bmp.Height := Value.Height; - if Value.Graphic is TIcon then - begin + if Value.Graphic is TIcon then begin Bmp.Canvas.Brush.Color := clSilver; - Bmp.Canvas.FillRect( Rect( 0, 0, Bmp.Width, Bmp.Height ) ); - Bmp.Canvas.Draw( 0, 0, Value.Graphic ); + Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height)); + Bmp.Canvas.Draw(0, 0, Value.Graphic); end - else - Bmp.Assign( Value.Graphic ); - Fpicture.Assign( Bmp ); - FINALLY + else + Bmp.Assign(Value.Graphic); + Fpicture.Assign(Bmp); + finally Bmp.Free; - END; + end; Fseparator := False; end; FToolbar.AssembleBitmap; @@ -16157,43 +12306,42 @@ begin end; procedure TKOLToolbarButton.SetradioGroup(const Value: Integer); -var I, J: Integer; - AlreadyPresent, TheSameBefore, TheSameAfter: Boolean; - Bt: TKOLToolbarButton; +var + I, J: Integer; + AlreadyPresent, TheSameBefore, TheSameAfter: Boolean; + Bt: TKOLToolbarButton; begin - if Value = FradioGroup then Exit; - I := FToolbar.Items.IndexOf( Self ); - if I < 0 then Exit; - if Value <> 0 then - begin + if Value = FradioGroup then + Exit; + I := FToolbar.Items.IndexOf(Self); + if I < 0 then + Exit; + if Value <> 0 then begin AlreadyPresent := FALSE; - for J := 0 to FToolbar.Items.Count-1 do - begin - if I = J then continue; - Bt := FToolbar.Items[ J ]; - if Bt.FradioGroup = Value then - begin + for J := 0 to FToolbar.Items.Count - 1 do begin + if I = J then + continue; + Bt := FToolbar.Items[J]; + if Bt.FradioGroup = Value then begin AlreadyPresent := TRUE; break; end; end; - if AlreadyPresent then - begin + if AlreadyPresent then begin TheSameBefore := FALSE; TheSameAfter := FALSE; - if (I > 0) then - begin - Bt := FToolbar.Items[ I - 1 ]; + if (I > 0) then begin + Bt := FToolbar.Items[I - 1]; if not Bt.separator and (Bt.FradioGroup = Value) then TheSameBefore := TRUE; end; - if (I < FToolbar.Items.Count-1) then - begin - Bt := FToolbar.Items[ I + 1 ]; + if (I < FToolbar.Items.Count - 1) then begin + Bt := FToolbar.Items[I + 1]; if not Bt.separator and (Bt.FradioGroup = Value) then TheSameAfter := TRUE; end; - if not (TheSameBefore or TheSameAfter) then Exit; + if not (TheSameBefore or TheSameAfter) then + Exit; end; end; FradioGroup := Value; @@ -16203,15 +12351,16 @@ end; procedure TKOLToolbarButton.Setseparator(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Setseparator', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Setseparator', 0 + +@@e_signature: end; - if Fseparator = Value then Exit; + if Fseparator = Value then + Exit; Fseparator := Value; - if Value then - begin + if Value then begin Fcaption := '-'; FimgIndex := -1; end; @@ -16219,18 +12368,16 @@ begin end; procedure TKOLToolbarButton.Setsysimg(const Value: TSystemToolbarImage); -var I: Integer; +var + I: Integer; begin - if Value <> stiCustom then - begin - if (FToolbar.ImageListNormal <> nil) or - (FToolbar.ImageListDisabled <> nil) or - (FToolbar.ImageListHot <> nil) then - begin - I := MessageBox( Application.Handle, 'Image list(s) will be detached from ' + - 'the toolbar. Continue?', PChar( Application.Title + ' : ' + Name ), - MB_OKCANCEL ); - if I <> ID_OK then Exit; + if Value <> stiCustom then begin + if (FToolbar.ImageListNormal <> nil) or (FToolbar.ImageListDisabled <> nil) + or (FToolbar.ImageListHot <> nil) then begin + I := MessageBox(Application.Handle, 'Image list(s) will be detached from ' + + 'the toolbar. Continue?', PChar(Application.Title + ' : ' + Name), MB_OKCANCEL); + if I <> ID_OK then + Exit; FToolbar.ImageListNormal := nil; FToolbar.ImageListDisabled := nil; FToolbar.ImageListHot := nil; @@ -16243,19 +12390,21 @@ begin Change; end; -procedure TKOLToolbarButton.Settooltip(const Value: String); +procedure TKOLToolbarButton.Settooltip(const Value: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Settooltip', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Settooltip', 0 + +@@e_signature: end; - if Ftooltip = Value then Exit; + if Ftooltip = Value then + Exit; if Faction = nil then Ftooltip := Value else - Ftooltip:=Faction.Hint; + Ftooltip := Faction.Hint; if FToolbar <> nil then FToolbar.AssembleTooltips; Change; @@ -16264,113 +12413,113 @@ end; procedure TKOLToolbarButton.Setvisible(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButton.Setvisible', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButton.Setvisible', 0 + +@@e_signature: end; - if Fvisible = Value then Exit; + if Fvisible = Value then + Exit; if Faction = nil then Fvisible := Value else - Fvisible:=Faction.Visible; + Fvisible := Faction.Visible; Change; end; { TKOLToolButtonOnClickPropEditor } function TKOLToolButtonOnClickPropEditor.GetValue: string; -var Comp: TPersistent; - F: TForm; - D: IDesigner; - FD: IFormDesigner; - Orig: String; +var + Comp: TPersistent; + F: TForm; + D: IDesigner; + FD: IFormDesigner; + Orig: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButtonOnClickPropEditor.GetValue', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButtonOnClickPropEditor.GetValue', 0 + +@@e_signature: end; - if FResetting then - begin + if FResetting then begin Result := ''; Exit; end; Result := inherited GetValue; Orig := Result; //**Windows.Beep( 100, 100 ); - if Result = '' then - begin - Comp := GetComponent( 0 ); + if Result = '' then begin + Comp := GetComponent(0); if Comp <> nil then - if Comp is TKOLToolbarButton then - begin - Result := (Comp as TKOLToolbarButton).FOnClickMethodName; - end; + if Comp is TKOLToolbarButton then begin + Result := (Comp as TKOLToolbarButton).FOnClickMethodName; + end; end; //**Windows.Beep( 200, 100 ); - TRY + try - Comp := GetComponent( 0 ); - if (Comp <> nil) and - (Comp is TKOLToolbarButton) and - ((Comp as TKOLToolbarButton).FToolbar <> nil) then - begin - F := (Comp as TKOLToolbarButton).FToolbar.ParentForm; - if (F = nil) or (F.Designer = nil) then - begin - Result := ''; Exit; - end; + Comp := GetComponent(0); + if (Comp <> nil) and (Comp is TKOLToolbarButton) and ((Comp as + TKOLToolbarButton).FToolbar <> nil) then begin + F := (Comp as TKOLToolbarButton).FToolbar.ParentForm; + if (F = nil) or (F.Designer = nil) then begin + Result := ''; + Exit; + end; {$IFDEF _D6orHigher} - F.Designer.QueryInterface(IFormDesigner,D); + F.Designer.QueryInterface(IFormDesigner, D); {$ELSE} - D := F.Designer; + D := F.Designer; {$ENDIF} - if (D <> nil) and QueryFormDesigner( D, FD ) then - begin - if not FD.MethodExists( Result ) then Result := ''; + if (D <> nil) and QueryFormDesigner(D, FD) then begin + if not FD.MethodExists(Result) then + Result := ''; + end + else + Result := ''; end - else Result := ''; - end - else Result := ''; + else + Result := ''; //**Windows.Beep( 200, 100 ); - if (Result = '') and (Orig <> '') then - begin - FResetting := TRUE; - TRY + if (Result = '') and (Orig <> '') then begin + FResetting := TRUE; + try //Windows.Beep( 100, 200 ); - SetValue( '' ); - FINALLY - FResetting := FALSE; - END; - end; + SetValue(''); + finally + FResetting := FALSE; + end; + end; - EXCEPT - Rpt( 'Exception while retrieving property onClick for TKOLToolbarButton', RED ); - END; + except + Rpt('Exception while retrieving property onClick for TKOLToolbarButton', RED); + end; end; procedure TKOLToolButtonOnClickPropEditor.SetValue(const AValue: string); -var Comp: TPersistent; - I: Integer; +var + Comp: TPersistent; + I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLToolbarButtonOnClickPropEditor.SetValue', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLToolbarButtonOnClickPropEditor.SetValue', 0 + +@@e_signature: end; inherited; - for I := 0 to PropCount - 1 do - begin - Comp := GetComponent( I ); + for I := 0 to PropCount - 1 do begin + Comp := GetComponent(I); if Comp <> nil then - if Comp is TKOLToolbarButton then - begin - (Comp as TKOLToolbarButton).FOnClickMethodName := AValue; - (Comp as TKOLToolbarButton).Change; - end; + if Comp is TKOLToolbarButton then begin + (Comp as TKOLToolbarButton).FOnClickMethodName := AValue; + (Comp as TKOLToolbarButton).Change; + end; end; end; @@ -16378,7 +12527,7 @@ end; procedure TKOLListViewColumn.Change; begin - if Assigned( FListView ) then begin + if Assigned(FListView) then begin FListView.UpdateColumns; {YS} FListView.Change; end; @@ -16390,33 +12539,31 @@ begin FLVColOrder := -1; FLVColImage := -1; if AOwner <> nil then - if AOwner is TKOLListView then - begin - FListView := AOwner as TKOLListView; - FListView.Cols.Add( Self ); + if AOwner is TKOLListView then begin + FListView := AOwner as TKOLListView; + FListView.Cols.Add(Self); {ShowMessage( 'Parent FListView=' + Int2Hex( DWORD( FListView ), 8 ) + ', ' + FListView.Name );} - end; + end; FWidth := 50; end; -procedure TKOLListViewColumn.DefProps(const Prefix: String; Filer: TFiler); +procedure TKOLListViewColumn.DefProps(const Prefix: string; Filer: TFiler); begin - Filer.DefineProperty( Prefix + 'Name', LoadName, SaveName, True ); - Filer.DefineProperty( Prefix + 'Caption', LoadCaption, SaveCaption, True ); - Filer.DefineProperty( Prefix + 'TextAlign', LoadTextAlign, SaveTextAlign, True ); - Filer.DefineProperty( Prefix + 'Width', LoadWidth, SaveWidth, True ); - Filer.DefineProperty( Prefix + 'WidthType', LoadWidthType, SaveWidthType, True ); - Filer.DefineProperty( Prefix + 'LVColImage', LoadLVColImage, SaveLVColImage, True ); - Filer.DefineProperty( Prefix + 'LVColOrder', LoadLVColOrder, SaveLVColOrder, LVColOrder >= 0 ); - Filer.DefineProperty( Prefix + 'LVColRightImg', LoadLVColRightImg, SaveLVColRightImg, LVColRightImg ); + Filer.DefineProperty(Prefix + 'Name', LoadName, SaveName, True); + Filer.DefineProperty(Prefix + 'Caption', LoadCaption, SaveCaption, True); + Filer.DefineProperty(Prefix + 'TextAlign', LoadTextAlign, SaveTextAlign, True); + Filer.DefineProperty(Prefix + 'Width', LoadWidth, SaveWidth, True); + Filer.DefineProperty(Prefix + 'WidthType', LoadWidthType, SaveWidthType, True); + Filer.DefineProperty(Prefix + 'LVColImage', LoadLVColImage, SaveLVColImage, True); + Filer.DefineProperty(Prefix + 'LVColOrder', LoadLVColOrder, SaveLVColOrder, LVColOrder >= 0); + Filer.DefineProperty(Prefix + 'LVColRightImg', LoadLVColRightImg, SaveLVColRightImg, LVColRightImg); end; destructor TKOLListViewColumn.Destroy; begin - if FListView <> nil then - begin - FListView.FCols.Remove( Self ); + if FListView <> nil then begin + FListView.FCols.Remove(Self); FListView.UpdateColumns; FListView.Change; end; @@ -16450,7 +12597,7 @@ end; procedure TKOLListViewColumn.LoadTextAlign(Reader: TReader); begin - FTextAlign := TTextAlign( Reader.ReadInteger ); + FTextAlign := TTextAlign(Reader.ReadInteger); end; procedure TKOLListViewColumn.LoadWidth(Reader: TReader); @@ -16460,50 +12607,50 @@ end; procedure TKOLListViewColumn.LoadWidthType(Reader: TReader); begin - FWidthType := TKOLListViewColWidthType( Reader.ReadInteger ); + FWidthType := TKOLListViewColWidthType(Reader.ReadInteger); end; procedure TKOLListViewColumn.SaveCaption(Writer: TWriter); begin - Writer.WriteString( fCaption ); + Writer.WriteString(fCaption); end; procedure TKOLListViewColumn.SaveLVColImage(Writer: TWriter); begin - Writer.WriteInteger( FLVColImage ); + Writer.WriteInteger(FLVColImage); end; procedure TKOLListViewColumn.SaveLVColOrder(Writer: TWriter); begin - Writer.WriteInteger( FLVColOrder ); + Writer.WriteInteger(FLVColOrder); end; procedure TKOLListViewColumn.SaveLVColRightImg(Writer: TWriter); begin - Writer.WriteBoolean( FLVColRightImg ); + Writer.WriteBoolean(FLVColRightImg); end; procedure TKOLListViewColumn.SaveName(Writer: TWriter); begin - Writer.WriteString( Name ); + Writer.WriteString(Name); end; procedure TKOLListViewColumn.SaveTextAlign(Writer: TWriter); begin - Writer.WriteInteger( Integer( FTextAlign ) ); + Writer.WriteInteger(Integer(FTextAlign)); end; procedure TKOLListViewColumn.SaveWidth(Writer: TWriter); begin - Writer.WriteInteger( FWidth ); + Writer.WriteInteger(FWidth); end; procedure TKOLListViewColumn.SaveWidthType(Writer: TWriter); begin - Writer.WriteInteger( Integer( FWidthType ) ); + Writer.WriteInteger(Integer(FWidthType)); end; -procedure TKOLListViewColumn.SetCaption(const Value: String); +procedure TKOLListViewColumn.SetCaption(const Value: string); begin FCaption := Value; Change; @@ -16516,26 +12663,26 @@ begin end; procedure TKOLListViewColumn.SetLVColOrder(const Value: Integer); -var I: Integer; - Col: TKOLListViewColumn; +var + I: Integer; + Col: TKOLListViewColumn; begin - if FListView <> nil then - begin - for I := 0 to FListView.Cols.Count-1 do - begin - Col := FListView.Cols[ I ]; - if Col = Self then continue; + if FListView <> nil then begin + for I := 0 to FListView.Cols.Count - 1 do begin + Col := FListView.Cols[I]; + if Col = Self then + continue; if Col.FLVColOrder > FLVColOrder then - Dec( Col.FLVColOrder ); + Dec(Col.FLVColOrder); end; if Value >= 0 then - for I := 0 to FListView.Cols.Count-1 do - begin - Col := FListView.Cols[ I ]; - if Col = Self then continue; - if Col.FLVColOrder >= Value then - Inc( Col.FLVColOrder ); - end; + for I := 0 to FListView.Cols.Count - 1 do begin + Col := FListView.Cols[I]; + if Col = Self then + continue; + if Col.FLVColOrder >= Value then + Inc(Col.FLVColOrder); + end; end; FLVColOrder := Value; Change; @@ -16565,8 +12712,7 @@ begin Change; end; -procedure TKOLListViewColumn.SetWidthType( - const Value: TKOLListViewColWidthType); +procedure TKOLListViewColumn.SetWidthType(const Value: TKOLListViewColWidthType); begin FWidthType := Value; Change; @@ -16575,39 +12721,44 @@ end; { TKOLLVColumnsPropEditor } procedure TKOLLVColumnsPropEditor.Edit; -var LV: TKOLListView; +var + LV: TKOLListView; begin - if GetComponent( 0 ) = nil then Exit; - LV := GetComponent( 0 ) as TKOLListView; + if GetComponent(0) = nil then + Exit; + LV := GetComponent(0) as TKOLListView; if LV.ActiveDesign = nil then - LV.ActiveDesign := TfmLVColumnsEditor.Create( Application ); + LV.ActiveDesign := TfmLVColumnsEditor.Create(Application); LV.ActiveDesign.ListView := LV; LV.ActiveDesign.Visible := TRUE; - SetForegroundWindow( LV.ActiveDesign.Handle ); - LV.ActiveDesign.MakeActive( TRUE ); + SetForegroundWindow(LV.ActiveDesign.Handle); + LV.ActiveDesign.MakeActive(TRUE); if LV.ParentForm <> nil then LV.ParentForm.Invalidate; end; function TKOLLVColumnsPropEditor.GetAttributes: TPropertyAttributes; begin - Result := [ paDialog, paReadOnly ]; + Result := [paDialog, paReadOnly]; end; { TKOLLVColumnsEditor } procedure TKOLLVColumnsEditor.Edit; -var LV: TKOLListView; +var + LV: TKOLListView; begin - if Component = nil then Exit; - if not(Component is TKOLListView) then Exit; + if Component = nil then + Exit; + if not (Component is TKOLListView) then + Exit; LV := Component as TKOLListView; if LV.ActiveDesign = nil then - LV.ActiveDesign := TfmLVColumnsEditor.Create( Application ); + LV.ActiveDesign := TfmLVColumnsEditor.Create(Application); LV.ActiveDesign.ListView := LV; LV.ActiveDesign.Visible := True; - SetForegroundWindow( LV.ActiveDesign.Handle ); - LV.ActiveDesign.MakeActive( TRUE ); + SetForegroundWindow(LV.ActiveDesign.Handle); + LV.ActiveDesign.MakeActive(TRUE); if LV.ParentForm <> nil then LV.ParentForm.Invalidate; end; @@ -16629,73 +12780,26 @@ end; { TKOLDateTimePicker } -procedure TKOLDateTimePicker.AssignEvents(SL: TStringList; - const AName: String); +procedure TKOLDateTimePicker.AssignEvents(SL: TStringList; const AName: string); begin inherited; - DoAssignEvents( SL, AName, [ 'OnDTPUserString' ], [ @ OnDTPUserString ] ); + DoAssignEvents(SL, AName, ['OnDTPUserString'], [@OnDTPUserString]); end; constructor TKOLDateTimePicker.Create(AOwner: TComponent); begin inherited; - Width := 110; DefaultWidth := Width; - Height := 24; DefaultHeight := Height; + Width := 110; + DefaultWidth := Width; + Height := 24; + DefaultHeight := Height; Color := clWindow; fTabStop := TRUE; MonthBkColor := clNone; MonthTxtColor := clNone; end; -function TKOLDateTimePicker.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLDateTimePicker.P_AssignEvents(SL: TStringList; - const AName: String; CheckOnly: Boolean): Boolean; -begin - Result := inherited P_AssignEvents( SL, AName, CheckOnly ); - if Result and CheckOnly then Exit; - Result := Result or - P_DoAssignEvents( SL, AName, [ 'OnDTPUserString' ], [ @ OnDTPUserString ], - [ FALSE ], CheckOnly ); -end; - -procedure TKOLDateTimePicker.P_SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -begin - inherited; - if Format <> '' then - //SL.Add( Prefix + AName + '.DateTimeFormat := ' + StringConstant( 'Format', Format ) + ';' ); - {P}SL.Add( ' DUP C2R ' + P_StringConstant( 'Format', Format ) + - ' R2C TControl_.SetDateTimeFormat<2> DelAnsiStr' ); - if not ParentColor then - //SL.Add( Prefix + AName + '.DateTimePickerColors[ dtpcBackground ] := ' + - // Color2Str( Color ) + ';' ); - {P}SL.Add( ' L($' + IntToHex( Color, 6 ) + ') L(' + IntToStr( Integer( dtpcBackground ) ) + - ') C2 TControl_.SetDateTimePickerColor<3>' ); -end; - -function TKOLDateTimePicker.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -//var S: String; -begin - {S := ''; - if dtpoTime in Options then S := S + ',dtpoTime'; - if dtpoDateLong in Options then S := S + ',dtpoDateLong'; - if dtpoUpDown in Options then S := S + ',dtpoUpDown'; - if dtpoRightAlign in Options then S := S + ',dtpoRightAlign'; - if dtpoShowNone in Options then S := S + ',dtpoShowNone'; - if dtpoParseInput in Options then S := S + ',dtpoParseInput'; - Delete( S, 1, 1 ); - Result := AParent + ', [' + S + ']';} - {P}Result := ' L(' + IntToStr( PByte( @ Options )^ ) + ')' + - #13#10' C1'; - nparams := 2; -end; - -procedure TKOLDateTimePicker.SetFormat(const Value: String); +procedure TKOLDateTimePicker.SetFormat(const Value: string); begin FFormat := Value; Change; @@ -16703,16 +12807,18 @@ end; procedure TKOLDateTimePicker.SetMonthBkColor(const Value: TColor); begin - if FMonthBkColor = Value then Exit; - FMonthBkColor := Value; - Change; + if FMonthBkColor = Value then + Exit; + FMonthBkColor := Value; + Change; end; procedure TKOLDateTimePicker.SetMonthTxtColor(const Value: TColor); begin - if FMonthTxtColor = Value then Exit; - FMonthTxtColor := Value; - Change; + if FMonthTxtColor = Value then + Exit; + FMonthTxtColor := Value; + Change; end; procedure TKOLDateTimePicker.SetOnDTPUserString(const Value: KOL.TDTParseInputEvent); @@ -16721,82 +12827,52 @@ begin Change; end; -procedure TKOLDateTimePicker.SetOptions( - const Value: TDateTimePickerOptions); +procedure TKOLDateTimePicker.SetOptions(const Value: TDateTimePickerOptions); begin - if ( dtpoTime in Value ) and not( dtpoTime in FOptions ) then - FOptions := Value + [ dtpoUpDown ] + if (dtpoTime in Value) and not (dtpoTime in FOptions) then + FOptions := Value + [dtpoUpDown] else FOptions := Value; Change; end; -procedure TKOLDateTimePicker.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewDateTimePicker', TRUE, TRUE, '' ); - KF.FormAddNumParameter( PByte( @ Options )^ ); -end; - -procedure TKOLDateTimePicker.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -var KF: TKOLForm; +procedure TKOLDateTimePicker.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin inherited; - KF := ParentKOLForm; - if Format <> '' then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetDateTimeFormat', '' ); - KF.FormAddStrParameter( Format ); - end else - SL.Add( Prefix + AName + '.DateTimeFormat := ' + - StringConstant( 'Format', Format ) + ';' ); - if MonthBkColor <> clNone then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetDateTimeColor', '' ); - KF.FormAddNumParameter( (MonthBkColor shl 1) or (MonthBkColor shr 31) ); - KF.FormAddNumParameter( Integer( dtpcBackground ) ); - end else - SL.Add( Prefix + AName + '.DateTimePickerColors[ dtpcBackground ] := TColor(' + - Color2Str( MonthBkColor ) + ');' ); + if Format <> '' then + SL.Add(Prefix + AName + '.DateTimeFormat := ' + StringConstant('Format', Format) + ';'); - if MonthTxtColor <> clNone then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetDateTimeColor', '' ); - KF.FormAddNumParameter( (MonthTxtColor shl 1) or (MonthTxtColor shr 31) ); - KF.FormAddNumParameter( Integer( dtpcText ) ); - end else - SL.Add( Prefix + AName + '.DateTimePickerColors[ dtpcMonthBk ] := TColor(' + - Color2Str( MonthTxtColor ) + ');' ); + if MonthBkColor <> clNone then + SL.Add(Prefix + AName + '.DateTimePickerColors[ dtpcBackground ] := TColor(' + + Color2Str(MonthBkColor) + ');'); + if MonthTxtColor <> clNone then + SL.Add(Prefix + AName + '.DateTimePickerColors[ dtpcMonthBk ] := TColor(' + + Color2Str(MonthTxtColor) + ');'); end; -function TKOLDateTimePicker.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -var S: String; +function TKOLDateTimePicker.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +var + S: string; begin S := ''; - if dtpoTime in Options then S := S + ',dtpoTime'; - if dtpoDateLong in Options then S := S + ',dtpoDateLong'; - if dtpoUpDown in Options then S := S + ',dtpoUpDown'; - if dtpoRightAlign in Options then S := S + ',dtpoRightAlign'; - if dtpoShowNone in Options then S := S + ',dtpoShowNone'; - if dtpoParseInput in Options then S := S + ',dtpoParseInput'; - Delete( S, 1, 1 ); + if dtpoTime in Options then + S := S + ',dtpoTime'; + if dtpoDateLong in Options then + S := S + ',dtpoDateLong'; + if dtpoUpDown in Options then + S := S + ',dtpoUpDown'; + if dtpoRightAlign in Options then + S := S + ',dtpoRightAlign'; + if dtpoShowNone in Options then + S := S + ',dtpoShowNone'; + if dtpoParseInput in Options then + S := S + ',dtpoParseInput'; + Delete(S, 1, 1); Result := AParent + ', [' + S + ']'; end; -function TKOLDateTimePicker.SupportsFormCompact: Boolean; -begin - Result := TRUE; -end; - function TKOLDateTimePicker.TabStopByDefault: Boolean; begin Result := TRUE; @@ -16804,19 +12880,18 @@ end; { TKOLScrollBar } -procedure TKOLScrollBar.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLScrollBar.AssignEvents(SL: TStringList; const AName: string); begin inherited; - DoAssignEvents( SL, AName, [ 'OnSBBeforeScroll', 'OnSBScroll' ], - [ @OnSBBeforeScroll, @OnSBScroll ] ); + DoAssignEvents(SL, AName, ['OnSBBeforeScroll', 'OnSBScroll'], [@OnSBBeforeScroll, @OnSBScroll]); end; constructor TKOLScrollBar.Create(AOwner: TComponent); begin inherited; FSBMax := 100; - DefaultWidth := GetSystemMetrics( SM_CXVSCROLL ); - DefaultHeight := GetSystemMetrics( SM_CYHSCROLL ); + DefaultWidth := GetSystemMetrics(SM_CXVSCROLL); + DefaultHeight := GetSystemMetrics(SM_CYHSCROLL); FSBBar := KOL.sbVertical; Width := DefaultWidth; end; @@ -16824,72 +12899,14 @@ end; procedure TKOLScrollBar.Paint; begin if not (Assigned(FKOLCtrl) and (PaintType in [ptWYSIWIG, ptWYSIWIGFrames])) then begin - PrepareCanvasFontForWYSIWIGPaint( Canvas ); - DrawScrollBar(True, Canvas.Handle, ClientRect, Enabled, (SBbar = KOL.sbVertical), SBPosition, SBMin, SBMax); - end; - inherited; -end; - -function TKOLScrollBar.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLScrollBar.P_AssignEvents(SL: TStringList; const AName: String; - CheckOnly: Boolean): Boolean; -begin - Result := inherited P_AssignEvents( SL, AName, CheckOnly ); - if Result and CheckOnly then Exit; - Result := Result or - P_DoAssignEvents( SL, AName, [ 'OnSBBeforeScroll', 'OnSBScroll' ], - [ @OnSBBeforeScroll, @OnSBScroll ], - [ FALSE, FALSE ], CheckOnly ); -end; - -procedure TKOLScrollBar.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBar.P_SetupFirst', 0 - @@e_signature: + PrepareCanvasFontForWYSIWIGPaint(Canvas); + DrawScrollBar(True, Enabled, (SBbar = KOL.sbVertical), Canvas.Handle, + ClientRect, SBPosition, SBMin, SBMax); end; inherited; - if SBMin <> 0 then - //SL.Add( Prefix + AName + '.SBMin := ' + IntToStr( SBMin ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( SBMin ) + ')' + - ' C1 TControl_.SetSBMin<2>' ); - //if SBMax <> 100 then - //SL.Add( Prefix + AName + '.SBMax := ' + IntToStr( SBMax ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( SBMax ) + ')' + - ' C1 TControl_.SetSBMax<2>' ); - if SBPosition <> SBMin then - //SL.Add( Prefix + AName + '.SBPosition := ' + IntToStr( SBPosition ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( SBPosition ) + ')' + - ' C1 TControl_.SetSBPosition<2>' ); - if SBPageSize <> 0 then - //SL.Add( Prefix + AName + '.SBPageSize := ' + IntToStr( SBPageSize ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( SBPageSize ) + ')' + - ' C1 TControl_.SetSBPageSize<2>' ); end; -function TKOLScrollBar.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBar.P_SetupParams', 0 - @@e_signature: - end; - //Result := AParent + ', ' + ScrollerbarNames[ SBBar ]; - {P}Result := ' L(' + IntToStr( Integer( SBBar ) ) + ') C1'; - nparams := 2; -end; - -procedure TKOLScrollBar.SetOnSBBeforeScroll( - const Value: TOnSBBeforeScroll); +procedure TKOLScrollBar.SetOnSBBeforeScroll(const Value: TOnSBBeforeScroll); begin FOnSBBeforeScroll := Value; Change; @@ -16902,29 +12919,32 @@ begin end; procedure TKOLScrollBar.SetSBbar(const Value: TScrollerBar); -var WasBar: TScrollerBar; - WasWidth, WasHeight: Integer; +var + WasBar: TScrollerBar; + WasWidth, WasHeight: Integer; begin WasBar := FSBbar; WasWidth := Width; WasHeight := Height; - if WasBar = Value then Exit; + if WasBar = Value then + Exit; FSBbar := Value; - if (Align in [ caLeft, caRight ]) and (WasBar = KOL.sbVertical) then - begin - CASE Align OF - caLeft: Align := caTop; - else Align := caBottom; - END; + if (Align in [caLeft, caRight]) and (WasBar = KOL.sbVertical) then begin + case Align of + caLeft: + Align := caTop; + else + Align := caBottom; + end; Height := WasWidth; end - else - if (Align in [ caTop, caBottom ]) and (WasBar = KOL.sbHorizontal) then - begin - CASE Align OF - caTop: Align := caLeft; - else Align := caRight; - END; + else if (Align in [caTop, caBottom]) and (WasBar = KOL.sbHorizontal) then begin + case Align of + caTop: + Align := caLeft; + else + Align := caRight; + end; Width := WasHeight; end; Change; @@ -16980,76 +13000,41 @@ begin Change; end; -procedure TKOLScrollBar.SetupConstruct_Compact; -var KF: TKOLForm; -begin - inherited; - KF := ParentKOLForm; - if KF = nil then Exit; - KF.FormAddAlphabet( 'FormNewScrollBar', TRUE, TRUE, '' ); - KF.FormAddNumParameter( Integer( SBBar ) ); -end; - -procedure TKOLScrollBar.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; +procedure TKOLScrollBar.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBar.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLScrollBar.SetupFirst', 0 + +@@e_signature: end; inherited; - KF := ParentKOLForm; - if SBMin <> 0 then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetSBMin', '' ); - KF.FormAddNumParameter( SBMin ); - end else - SL.Add( Prefix + AName + '.SBMin := ' + IntToStr( SBMin ) + ';' ); - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetSBMax', '' ); - KF.FormAddNumParameter( SBMax ); - end else - SL.Add( Prefix + AName + '.SBMax := ' + IntToStr( SBMax ) + ';' ); + if SBMin <> 0 then + SL.Add(Prefix + AName + '.SBMin := ' + IntToStr(SBMin) + ';'); - if SBPosition <> SBMin then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetSBPosition', '' ); - KF.FormAddNumParameter( SBPosition ); - end else - SL.Add( Prefix + AName + '.SBPosition := ' + IntToStr( SBPosition ) + ';' ); + SL.Add(Prefix + AName + '.SBMax := ' + IntToStr(SBMax) + ';'); - if SBPageSize <> 0 then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetSBPageSize', '' ); - KF.FormAddNumParameter( SBPageSize ); - end else - SL.Add( Prefix + AName + '.SBPageSize := ' + IntToStr( SBPageSize ) + ';' ); + if SBPosition <> SBMin then + SL.Add(Prefix + AName + '.SBPosition := ' + IntToStr(SBPosition) + ';'); + + if SBPageSize <> 0 then + SL.Add(Prefix + AName + '.SBPageSize := ' + IntToStr(SBPageSize) + ';'); end; -function TKOLScrollBar.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; -const ScrollerBarNames: array[ TScrollerBar ] of String = ( - 'sbHorizontal', 'sbVertical' ); +function TKOLScrollBar.SetupParams(const AName, AParent: TDelphiString): TDelphiString; +const + ScrollerBarNames: array[TScrollerBar] of string = ('sbHorizontal', 'sbVertical'); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLScrollBar.SetupParams', 0 - @@e_signature: - end; - Result := AParent + ', ' + ScrollerbarNames[ SBBar ]; -end; + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLScrollBar.SetupParams', 0 -function TKOLScrollBar.SupportsFormCompact: Boolean; -begin - Result := TRUE; +@@e_signature: + end; + Result := AParent + ', ' + ScrollerbarNames[SBBar]; end; function TKOLScrollBar.WYSIWIGPaintImplemented: Boolean; @@ -17059,12 +13044,10 @@ end; { TKOLTabPage } -function TKOLTabPage.TypeName: String; +function TKOLTabPage.TypeName: string; begin - Result := 'Panel'; + Result := 'Panel'; end; end. - - diff --git a/mckObjs.pas b/mckObjs.pas index cf971c4..e2a190f 100644 --- a/mckObjs.pas +++ b/mckObjs.pas @@ -19,25 +19,25 @@ mmmmm mmmmm mmmmm cccccccccccc kkkkk kkkkk Key Objects Library (C) 2000 by Kladov Vladimir. KOL Mirror Classes Kit (C) 2000 by Kladov Vladimir. } -unit mckObjs; +unit mckObjs; interface {$I KOLDEF.INC} -uses KOL, Classes, Forms, Controls, Dialogs, Windows, Messages, extctrls, - stdctrls, comctrls, SysUtils, Graphics, mirror, ShellAPI, - buttons, mckFileFilterEditor, +uses + KOL, Classes, Forms, Controls, Dialogs, Windows, Messages, extctrls, stdctrls, + comctrls, SysUtils, Graphics, mirror, ShellAPI, buttons, mckFileFilterEditor, ////////////////////////////////////////// {$IFDEF _D6orHigher} // - DesignIntf, DesignEditors // + DesignIntf, DesignEditors, // {$ELSE} // ////////////////////////////////////////// - DsgnIntf + DsgnIntf, ////////////////////////////////////////// {$ENDIF} // ////////////////////////////////////////// - , imglist, TypInfo, menus; + imglist, TypInfo, menus; type //============================================================================ @@ -58,21 +58,12 @@ type procedure SetPeriodic(const Value: Boolean); procedure SetResolution(const Value: Integer); protected - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); - override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); - override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; CheckOnly: Boolean ): Boolean; override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; public - function TypeName: String; override; - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; - procedure P_DoProvideFakeType( SL: TStringList ); override; + function TypeName: string; override; + constructor Create(AOwner: TComponent); override; published property Interval: Integer read FInterval write SetInterval; property Enabled: Boolean read FEnabled write SetEnabled; @@ -85,9 +76,9 @@ type //============================================================================ //---- MIRROR FOR A THREAD ---- //---- ЗЕРКАЛО ДЛЯ НИТИ ---- - TPriorityClass = ( pcNormal, pcIdle, pcHigh, pcRealTime ); - TThreadPriority = ( tpNormal, tpBelowNormal, tpLowest, tpIdle, tpAboveNormal, - tpHighest, tpCritical ); + TPriorityClass = (pcNormal, pcIdle, pcHigh, pcRealTime); + + TThreadPriority = (tpNormal, tpBelowNormal, tpLowest, tpIdle, tpAboveNormal, tpHighest, tpCritical); TKOLThread = class(TKOLObj) private @@ -108,16 +99,12 @@ type procedure SetAutoFree(const Value: Boolean); procedure SetPriorityBoost(const Value: Boolean); protected - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; function NotAutoFree: Boolean; override; - function BestEventName: String; override; + function BestEventName: string; override; public - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; override; - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + constructor Create(AOwner: TComponent); override; published property PriorityClass: TPriorityClass read FPriorityClass write SetPriorityClass; property ThreadPriority: TThreadPriority read FThreadPriority write SetThreadPriority; @@ -162,15 +149,12 @@ type procedure SetForce32bit(const Value: Boolean); protected FKOLImgList: PImageList; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - //procedure BitmapChanged( Sender: TObject ); + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; public - function Pcode_Generate: Boolean; override; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Clear; - procedure Assign( Value: TPersistent ); override; + procedure Assign(Value: TPersistent); override; property Handle: THandle read GetImageListHandle; published property ImgWidth: Integer read FImgWidth write SetImgWidth; @@ -182,8 +166,7 @@ type property Colors: TImageListColors read FColors write SetColors; property Masked: Boolean read FMasked write SetMasked; property BkColor: TColor read FBkColor write SetBkColor; - property AllowCompression: Boolean read FAllowCompression write SetAllowCompression - default TRUE; + property AllowCompression: Boolean read FAllowCompression write SetAllowCompression default TRUE; property Force32bit: Boolean read FForce32bit write SetForce32bit; end; @@ -203,45 +186,42 @@ type TKOLOpenSaveDialog = class(TKOLObj) private FOptions: TOpenSaveOptions; - FInitialDir: String; - FFilter: String; + FInitialDir: string; + FFilter: string; FFilterIndex: Integer; - FTitle: String; - FDefExtension: String; + FTitle: string; + FDefExtension: string; FOpenDialog: Boolean; - FTemplateName: String; + FTemplateName: string; FNoPlaceBar: Boolean; procedure SetOptions(const Value: TOpenSaveOptions); - procedure SetInitialDir(const Value: String); - procedure SetFilter(const Value: String); + procedure SetInitialDir(const Value: string); + procedure SetFilter(const Value: string); procedure SetFilterIndex(const Value: Integer); - procedure SetTitle(const Value: String); - procedure SetDefExtension(const Value: String); + procedure SetTitle(const Value: string); + procedure SetDefExtension(const Value: string); procedure SetOpenDialog(const Value: Boolean); - procedure SetTemplateName(const Value: String); + procedure SetTemplateName(const Value: string); procedure SetNoPlaceBar(const Value: Boolean); protected - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; public - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; + constructor Create(AOwner: TComponent); override; published property Options: TOpenSaveOptions read FOptions write SetOptions; property NoPlaceBar: Boolean read FNoPlaceBar write SetNoPlaceBar; - property Title: String read FTitle write SetTitle; - property TemplateName: String read FTemplateName write SetTemplateName; - property InitialDir: String read FInitialDir write SetInitialDir; - property Filter: String read FFilter write SetFilter; + property Title: string read FTitle write SetTitle; + property TemplateName: string read FTemplateName write SetTemplateName; + property InitialDir: string read FInitialDir write SetInitialDir; + property Filter: string read FFilter write SetFilter; property FilterIndex: Integer read FFilterIndex write SetFilterIndex; - property DefExtension: String read FDefExtension write SetDefExtension; + property DefExtension: string read FDefExtension write SetDefExtension; property OpenDialog: Boolean read FOpenDialog write SetOpenDialog; property Localizy; end; - TKOLFileFilter = class( TStringProperty ) + TKOLFileFilter = class(TStringProperty) private protected public @@ -252,37 +232,32 @@ type //---------------------------------------------------------------------------- //---- MIRROR FOR OPENDIR DIALOG ---- //---- ЗЕРКАЛО ДЛЯ ДИАЛОГА ВЫБОРА ДИРЕКТОРИЯ ---- - TKOLOpenDirDialog = class( TKOLObj ) + TKOLOpenDirDialog = class(TKOLObj) private - FTitle: String; + FTitle: string; FOptions: TOpenDirOptions; - FInitialPath: String; + FInitialPath: string; FCenterOnScreen: Boolean; FOnSelChanged: TOnODSelChange; FAltDialog: Boolean; - procedure SetTitle(const Value: String); + procedure SetTitle(const Value: string); procedure SetOptions(const Value: TOpenDirOptions); - procedure SetInitialPath(const Value: String); + procedure SetInitialPath(const Value: string); procedure SetCenterOnScreen(const Value: Boolean); procedure SetOnSelChanged(const Value: TOnODSelChange); procedure SetAltDialog(const Value: Boolean); protected - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; public - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; override; - constructor Create( AOwner: TComponent ); override; - function TypeName: String; override; - function Pcode_Generate: Boolean; override; - function AdditionalUnits: String; override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + constructor Create(AOwner: TComponent); override; + function TypeName: string; override; + function AdditionalUnits: string; override; published - property Title: String read FTitle write SetTitle; + property Title: string read FTitle write SetTitle; property Options: TOpenDirOptions read FOptions write SetOptions; - property InitialPath: String read FInitialPath write SetInitialPath; + property InitialPath: string read FInitialPath write SetInitialPath; property CenterOnScreen: Boolean read FCenterOnScreen write SetCenterOnScreen; property OnSelChanged: TOnODSelChange read FOnSelChanged write SetOnSelChanged; property Localizy; @@ -293,19 +268,17 @@ type //---------------------------------------------------------------------------- //---- MIRROR FOR COLOR CHOOSING DIALOG ---- //---- ЗЕРКАЛО ДЛЯ ДИАЛОГА ВЫБОРА ЦВЕТА ---- - TKOLColorDialog = class( TKOLObj ) + TKOLColorDialog = class(TKOLObj) private FColorCustomOption: TColorCustomOption; - FCustomColors: array[ 1..16 ] of TColor; + FCustomColors: array[1..16] of TColor; procedure SetColorCustomOption(const Value: TColorCustomOption); - function GetCustomColor( const Index: Integer ): TColor; + function GetCustomColor(const Index: Integer): TColor; procedure SetCustomColor(const Index: Integer; const Value: TColor); protected - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; public - constructor Create( AOwner: TComponent ); override; - function Pcode_Generate: Boolean; override; + constructor Create(AOwner: TComponent); override; published property ColorCustomOption: TColorCustomOption read FColorCustomOption write SetColorCustomOption; property CustomColor1: TColor index 1 read GetCustomColor write SetCustomColor; @@ -331,13 +304,13 @@ type //---- ЗЕРКАЛО ДЛЯ ДИАЛОГА ВЫБОРА ЦВЕТА ---- TKOLFontDialog = class(TKOLObj) private - FMinFontSize: Integer; - FMaxFontSize: Integer; - FDevice: KOL.TFontDialogDevice; - FFont: TKOLFont; - FOnHelp: TOnEvent; - FOnApply: TOnEvent; - FOptions: KOL.TFontDialogOptions; + FMinFontSize: Integer; + FMaxFontSize: Integer; + FDevice: KOL.TFontDialogDevice; + FFont: TKOLFont; + FOnHelp: TOnEvent; + FOnApply: TOnEvent; + FOptions: KOL.TFontDialogOptions; procedure SetMinFontSize(const Value: Integer); procedure SetMaxFontSize(const Value: Integer); procedure SetDevice(const Value: KOL.TFontDialogDevice); @@ -346,8 +319,8 @@ type procedure SetOnHelp(const Value: TOnEvent); procedure SetOptions(const Value: KOL.TFontDialogOptions); protected - procedure AssignEvents( SL: TStringList; const AName: String ); override; - procedure SetupFirst(SL: TStringList; const AName,AParent, Prefix: String); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; @@ -355,7 +328,7 @@ type property Device: KOL.TFontDialogDevice read FDevice write SetDevice; property MinFontSize: Integer read FMinFontSize write SetMinFontSize; property MaxFontSize: Integer read FmaxFontSize write SetMaxFontSize; - property Options: KOL.TFontDialogOptions read FOptions write SetOptions default [KOL.fdEffects, KOL.fdInitFont]; + property Options: KOL.TFontDialogOptions read FOptions write SetOptions; // default [KOL.fdEffects, KOL.fdInitFont]; property Font: TKOLFont read FFont write SetInitFont; property OnApply: TOnEvent read FOnApply write SetOnApply; property OnHelp: TOnEvent read FOnHelp write SetOnHelp; @@ -364,54 +337,51 @@ type //---------------------------------------------------------------------------- //---- MIRROR FOR TRAY ICON ---- //---- ЗЕРКАЛО ДЛЯ ИКОНКИ В ТРЕЕ ---- - TKOLTrayIcon = class( TKOLObj ) + TKOLTrayIcon = class(TKOLObj) private FIcon: TIcon; FActive: Boolean; - FTooltip: String; + FTooltip: string; FAutoRecreate: Boolean; FOnMouse: TOnTrayIconMouse; FNoAutoDeactivate: Boolean; procedure SetIcon(const Value: TIcon); procedure SetActive(const Value: Boolean); - procedure SetTooltip(const Value: String); + procedure SetTooltip(const Value: string); procedure SetAutoRecreate(const Value: Boolean); procedure SetOnMouse(const Value: TOnTrayIconMouse); procedure SetNoAutoDeactivate(const Value: Boolean); protected - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; CheckOnly: Boolean ): Boolean; override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; public - function Pcode_Generate: Boolean; override; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property Icon: TIcon read FIcon write SetIcon; property Active: Boolean read FActive write SetActive; property NoAutoDeactivate: Boolean read FNoAutoDeactivate write SetNoAutoDeactivate; - property Tooltip: String read FTooltip write SetTooltip; + property Tooltip: string read FTooltip write SetTooltip; property AutoRecreate: Boolean read FAutoRecreate write SetAutoRecreate; property OnMouse: TOnTrayIconMouse read FOnMouse write SetOnMouse; property Localizy; end; +type + KOLTPixelFormat = KOL.TPixelFormat; -type KOLTPixelFormat = KOL.TPixelFormat; - -function CountSystemColorsUsedInBitmap( Bmp: KOL.PBitmap; ColorList: KOL.PList ): KOLTPixelFormat; +function CountSystemColorsUsedInBitmap(Bmp: KOL.PBitmap; ColorList: KOL.PList): KOLTPixelFormat; //function SaveBitmap( Bitmap: TBitmap; const Path: String ): Boolean; -procedure GenerateBitmapResource( Bitmap: TBitmap; const RsrcName, FileName: String; - var Updated: Boolean; AllowCompression: Boolean ); -procedure GenerateIconResource( Icon: TIcon; const RsrcName, FileName: KOLString; - var Updated: Boolean ); -procedure RemoveSelection( FD: IFormDesigner ); -function String2Pascal( S: String; const Concatenator: String ): String; -function P_String2Pascal( S: String ): String; -//function GetBmpPixel( Bitmap: TBitmap; X, Y: Integer ): TColor; + +procedure GenerateBitmapResource(Bitmap: TBitmap; const RsrcName, FileName: + string; var Updated: Boolean; AllowCompression: Boolean); + +procedure GenerateIconResource(Icon: TIcon; const RsrcName, FileName: KOLString; var Updated: Boolean); + +procedure RemoveSelection(FD: IFormDesigner); + +function String2Pascal(S: string; const Concatenator: string): string; procedure Register; @@ -419,217 +389,187 @@ implementation procedure Register; begin - RegisterComponents( 'KOL', [ TKOLTimer, TKOLThread, TKOLImageList, TKOLMainMenu, TKOLPopupMenu, - TKOLOpenSaveDialog, TKOLOpenDirDialog, TKOLColorDialog, TKOLFontDialog, - TKOLTrayIcon ] ); - RegisterComponentEditor( TKOLImageList, TKOLImageListEditor ); - RegisterPropertyEditor( TypeInfo( String ), TKOLOpenSaveDialog, 'Filter', - TKOLFileFilter ); - RegisterPropertyEditor( TypeInfo( TOnODSelChange ), TKOLOpenDirDialog, 'OnSelChanged', TKOLOnEventPropEditor ); - RegisterPropertyEditor( TypeInfo( TOnTrayIconMouse ), nil, '', TKOLOnEventPropEditor ); + RegisterComponents('KOL', [TKOLTimer, TKOLThread, TKOLImageList, TKOLMainMenu, + TKOLPopupMenu, TKOLOpenSaveDialog, TKOLOpenDirDialog, TKOLColorDialog, TKOLFontDialog, TKOLTrayIcon]); + RegisterComponentEditor(TKOLImageList, TKOLImageListEditor); + RegisterPropertyEditor(TypeInfo(string), TKOLOpenSaveDialog, 'Filter', TKOLFileFilter); + RegisterPropertyEditor(TypeInfo(TOnODSelChange), TKOLOpenDirDialog, 'OnSelChanged', TKOLOnEventPropEditor); + RegisterPropertyEditor(TypeInfo(TOnTrayIconMouse), nil, '', TKOLOnEventPropEditor); end; -function String2PascalStr1( const S : String; const Concatenator: String ) : String; -var I, Strt : Integer; - function String2DoubleQuotas( const S : String ) : String; - var I, J : Integer; +function String2PascalStr1(const S: string; const Concatenator: string): string; +var + I, Strt: Integer; + + function String2DoubleQuotas(const S: string): string; + var + I, J: Integer; begin //if IndexOfChar( S, '''' ) <= 0 then - if pos( '''', S ) <= 0 then - Result := S - else - begin + if pos('''', S) <= 0 then + Result := S + else begin J := 0; - for I := 1 to Length( S ) do - if S[ I ] = '''' then Inc( J ); - SetLength( Result, Length( S ) + J ); + for I := 1 to Length(S) do + if S[I] = '''' then + Inc(J); + SetLength(Result, Length(S) + J); J := 1; - for I := 1 to Length( S ) do - begin - Result[ J ] := S[ I ]; - Inc( J ); - if S[ I ] = '''' then - begin - Result[ J ] := ''''; - Inc( J ); + for I := 1 to Length(S) do begin + Result[J] := S[I]; + Inc(J); + if S[I] = '''' then begin + Result[J] := ''''; + Inc(J); end; end; end; end; + begin Result := ''; - if S = '' then - begin + if S = '' then begin Result := ''''''; exit; end; Strt := 1; - for I := 1 to Length( S ) + 1 do - begin - if (I > Length( S )) or (S[ I ] < ' ') then - begin - if (I > Strt) and (I > 1) then - begin + for I := 1 to Length(S) + 1 do begin + if (I > Length(S)) or (S[I] < ' ') then begin + if (I > Strt) and (I > 1) then begin if Result <> '' then - Result := Result + Concatenator; - Result := Result + '''' + String2DoubleQuotas( Copy( S, Strt, I - Strt ) ) + ''''; + Result := Result + Concatenator; + Result := Result + '''' + String2DoubleQuotas(Copy(S, Strt, I - Strt)) + ''''; end; - if I > Length( S ) then break; + if I > Length(S) then + break; if Result <> '' then - Result := Result + Concatenator + Result := Result + Concatenator else - Result := Result + '''''' + Concatenator; + Result := Result + '''''' + Concatenator; // Result := Result + ''''''; //if IndexOfChar(Concatenator, ',') > 0 then - if pos( ',', Concatenator ) > 0 then - Result := Result + IntToStr( Integer( S[ I ] ) ) - else Result := Result + '#' + IntToStr( Integer( S[ I ] ) ); + if pos(',', Concatenator) > 0 then + Result := Result + IntToStr(Integer(S[I])) + else + Result := Result + '#' + IntToStr(Integer(S[I])); Strt := I + 1; end; end; end; -function String2Pascal( S: String; const Concatenator: String ): String; +function String2Pascal(S: string; const Concatenator: string): string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'String2Pascal', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'String2Pascal', 0 + +@@e_signature: end; - if Length( S ) > 0 then - begin + if Length(S) > 0 then begin Result := ''; - while S <> '' do - begin + while S <> '' do begin if Result <> '' then Result := Result + Concatenator; - Result := Result + String2PascalStr1( Copy( S, 1, 255 ), Concatenator ); - S := Copy( S, 256, MaxInt ); - end; - end - else - Result := ''''''; -end; - -function P_String2Pascal( S: String ): String; -var i: Integer; -begin - if S <> '' then - begin - if Length( S ) <= 64 then - Result := String2Pascal( S, ',' ) + ' #0' - else - begin - i := 1; - Result := ''; - while i <= Length( S ) do - begin - Result := Result + String2Pascal( Copy( S, i, 64 ), ',' ) + #13#10; - inc( i, 64 ); - end; - Result := Copy( Result, 1, Length( Result )-2 ) + ' #0'; + Result := Result + String2PascalStr1(Copy(S, 1, 255), Concatenator); + S := Copy(S, 256, MaxInt); end; end else - Result := ' #0'; + Result := ''''''; end; -procedure RemoveSelection( FD: IFormDesigner ); +procedure RemoveSelection(FD: IFormDesigner); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'RemoveSelection', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'RemoveSelection', 0 + +@@e_signature: end; try FD.NoSelection; except - Rpt( '*/\* EXCEPTION - Could not remove current selection', WHITE ); + Rpt('*/\* EXCEPTION - Could not remove current selection', WHITE); end; end; -function ColorsAreSystem16( ColorList: PList ): Boolean; -const SysColors: array[ 0..15 ] of TColor = ( 0, $800000, $8000, $808000, $80, - $800080, $8080, $808080, $C0C0C0, $FF0000, $FF00, $FFFF00, $FF, $FF00FF, - $FFFF, $FFFFFF ); -var I, J: Integer; - C: TColor; - Found: Boolean; +function ColorsAreSystem16(ColorList: PList): Boolean; +const + SysColors: array[0..15] of TColor = (0, $800000, $8000, $808000, $80, $800080, + $8080, $808080, $C0C0C0, $FF0000, $FF00, $FFFF00, $FF, $FF00FF, $FFFF, $FFFFFF); +var + I, J: Integer; + C: TColor; + Found: Boolean; begin Result := TRUE; - for I := 0 to ColorList.Count-1 do - begin - C := TColor( ColorList.Items[ I ] ); + for I := 0 to ColorList.Count - 1 do begin + C := TColor(ColorList.Items[I]); Found := FALSE; for J := 0 to 15 do - if SysColors[ J ] = C then - begin + if SysColors[J] = C then begin Found := TRUE; break; end; - if not Found then - begin - Rpt( '***** Color ' + IntToHex( C, 8 ) + ' not found in system 16 colors', - WHITE ); + if not Found then begin + Rpt('***** Color ' + IntToHex(C, 8) + ' not found in system 16 colors', WHITE); Result := FALSE; Exit; end; end; end; -function ColorsAreSystem256( ColorList: PList ): Boolean; -const SysColors8bit: array[ 0..255 ] of DWORD = ( $000000, -$C0DCC0, $800000, $808000, $008000, $008080, $000080, $800080, $808080, -$00FF00, $0000FF, $00FFFF, $C0DCC0, $000040, $400040, $000000, $A0A0A4, -$C0C0C0, $C0DCC0, $FFFBF0, $FFFBF0, $FFFBF0, $FFFBF0, $FFFFFF, $FF0000, -$FFFF00, $FF00FF, $FFFFFF, $A6CAF0, $402000, $004040, $202040, $202040, -$606040, $404040, $E08080, $E00080, $C0DCC0, $A0A0A4, $800000, $C02000, -$404000, $A04000, $E04000, $406000, $A06000, $E06000, $40A000, $202040, -$404040, $404040, $E06040, $A6CAF0, $C0DCC0, $40E000, $800000, $004000, -$604000, $C04000, $006000, $606000, $C06000, $00A000, $60A000, $A0A000, -$E0A000, $40C000, $A0C000, $E0C000, $A0E000, $00E040, $600040, $C00040, -$0000FF, $604040, $C04040, $006040, $606040, $C06040, $00A040, $C0A000, -$00C000, $60C000, $C0C000, $60E000, $C0E000, $0000FF, $A00040, $E00040, -$404040, $A04040, $E04040, $406040, $A06040, $E06040, $40A040, $60A040, -$C0A040, $00C040, $60C040, $C0C040, $40E040, $A0E040, $E0E040, $400080, -$A00080, $E00080, $404080, $A04080, $E04080, $406080, $A06080, $A0A040, -$E0A040, $40C040, $A0C040, $E0C040, $60E040, $C0E040, $000080, $600080, -$C00080, $004080, $604080, $C04080, $006080, $606080, $C06080, $00A080, -$A0C080, $E0C080, $40E080, $C0E080, $FF00FF, $A04080, $C00080, $404080, -$C04080, $006080, $604080, $C06080, $40A080, $A0A0A4, $E0A080, $40C080, -$C0C080, $00E080, $A0E080, $E000C0, $00A080, $A00080, $000080, $600080, -$E00080, $406080, $A06080, $E04080, $60A080, $C0A080, $00C080, $40C080, -$A0C080, $E0C080, $40E080, $A0E080, $E0E080, $400080, $A000C0, $004080, -$6040C0, $C040C0, $0060C0, $606080, $C060C0, $00A0C0, $60A0C0, $60C080, -$C0C080, $00E080, $60C080, $C0E080, $0000C0, $6000C0, $C000C0, $4040C0, -$A040C0, $E040C0, $4060C0, $A060C0, $E06080, $40A0C0, $A0A0C0, $C0A0C0, -$00A0C0, $60A0C0, $C0A0C0, $00C0C0, $60C0C0, $C0C0C0, $00FFFF, $60E080, -$C0DCC0, $4000C0, $A000C0, $4040C0, $A040C0, $FF00FF, $4060C0, $E0A0C0, -$40A0C0, $A0A0C0, $E0A0C0, $40C0C0, $A0C0C0, $E0A0C0, $40C0C0, $C0DCC0, -$FFFBF0, $6000C0, $0040C0, $6040C0, $C040C0, $0060C0, $6060C0, $A060C0, -$E060C0, $40A0C0, $A6CAF0, $E0A0C0, $40C0C0, $A6CAF0, $FFFBF0, $60C0C0, -$FFFFFF, $60E080, $6060C0, $A6CAF0, $606040, $808080, $C0C0C0, $C060C0, -$00A0C0, $60A0C0, $A6CAF0, $00FFFF, $60C0C0, $A6CAF0, $00FFFF, $A6CAF0, -$E06080, $E0E080, $E060C0, $A00040, $808080, $A0A0A4, $C0C0C0 ); -var I, J: Integer; - C: DWORD; +function ColorsAreSystem256(ColorList: PList): Boolean; +const + SysColors8bit: array[0..255] of DWORD = ($000000, $C0DCC0, $800000, $808000, + $008000, $008080, $000080, $800080, $808080, $00FF00, $0000FF, $00FFFF, + $C0DCC0, $000040, $400040, $000000, $A0A0A4, $C0C0C0, $C0DCC0, $FFFBF0, + $FFFBF0, $FFFBF0, $FFFBF0, $FFFFFF, $FF0000, $FFFF00, $FF00FF, $FFFFFF, + $A6CAF0, $402000, $004040, $202040, $202040, $606040, $404040, $E08080, + $E00080, $C0DCC0, $A0A0A4, $800000, $C02000, $404000, $A04000, $E04000, + $406000, $A06000, $E06000, $40A000, $202040, $404040, $404040, $E06040, + $A6CAF0, $C0DCC0, $40E000, $800000, $004000, $604000, $C04000, $006000, + $606000, $C06000, $00A000, $60A000, $A0A000, $E0A000, $40C000, $A0C000, + $E0C000, $A0E000, $00E040, $600040, $C00040, $0000FF, $604040, $C04040, + $006040, $606040, $C06040, $00A040, $C0A000, $00C000, $60C000, $C0C000, + $60E000, $C0E000, $0000FF, $A00040, $E00040, $404040, $A04040, $E04040, + $406040, $A06040, $E06040, $40A040, $60A040, $C0A040, $00C040, $60C040, + $C0C040, $40E040, $A0E040, $E0E040, $400080, $A00080, $E00080, $404080, + $A04080, $E04080, $406080, $A06080, $A0A040, $E0A040, $40C040, $A0C040, + $E0C040, $60E040, $C0E040, $000080, $600080, $C00080, $004080, $604080, + $C04080, $006080, $606080, $C06080, $00A080, $A0C080, $E0C080, $40E080, + $C0E080, $FF00FF, $A04080, $C00080, $404080, $C04080, $006080, $604080, + $C06080, $40A080, $A0A0A4, $E0A080, $40C080, $C0C080, $00E080, $A0E080, + $E000C0, $00A080, $A00080, $000080, $600080, $E00080, $406080, $A06080, + $E04080, $60A080, $C0A080, $00C080, $40C080, $A0C080, $E0C080, $40E080, + $A0E080, $E0E080, $400080, $A000C0, $004080, $6040C0, $C040C0, $0060C0, + $606080, $C060C0, $00A0C0, $60A0C0, $60C080, $C0C080, $00E080, $60C080, + $C0E080, $0000C0, $6000C0, $C000C0, $4040C0, $A040C0, $E040C0, $4060C0, + $A060C0, $E06080, $40A0C0, $A0A0C0, $C0A0C0, $00A0C0, $60A0C0, $C0A0C0, + $00C0C0, $60C0C0, $C0C0C0, $00FFFF, $60E080, $C0DCC0, $4000C0, $A000C0, + $4040C0, $A040C0, $FF00FF, $4060C0, $E0A0C0, $40A0C0, $A0A0C0, $E0A0C0, + $40C0C0, $A0C0C0, $E0A0C0, $40C0C0, $C0DCC0, $FFFBF0, $6000C0, $0040C0, + $6040C0, $C040C0, $0060C0, $6060C0, $A060C0, $E060C0, $40A0C0, $A6CAF0, + $E0A0C0, $40C0C0, $A6CAF0, $FFFBF0, $60C0C0, $FFFFFF, $60E080, $6060C0, + $A6CAF0, $606040, $808080, $C0C0C0, $C060C0, $00A0C0, $60A0C0, $A6CAF0, + $00FFFF, $60C0C0, $A6CAF0, $00FFFF, $A6CAF0, $E06080, $E0E080, $E060C0, + $A00040, $808080, $A0A0A4, $C0C0C0); +var + I, J: Integer; + C: DWORD; begin Result := FALSE; - for I := 0 to ColorList.Count-1 do - begin - C := DWORD( ColorList.Items[ I ] ); - for J := 0 to 255 do - begin - if SysColors8bit[ J ] = C then - begin + for I := 0 to ColorList.Count - 1 do begin + C := DWORD(ColorList.Items[I]); + for J := 0 to 255 do begin + if SysColors8bit[J] = C then begin C := 0; break; end; end; - if C <> 0 then - begin + if C <> 0 then begin //Rpt( '~~~ color not found: ' + Int2Hex( C, 6 ), WHITE ); Exit; end; @@ -637,16 +577,15 @@ begin Result := TRUE; end; -function ColorsAre64K( ColorList: PList ): Boolean; -var I: Integer; - C: DWORD; +function ColorsAre64K(ColorList: PList): Boolean; +var + I: Integer; + C: DWORD; begin Result := FALSE; - for I := 0 to ColorList.Count-1 do - begin - C := DWORD( ColorList.Items[ I ] ); - if (C and $E0C0E0) <> C then - begin + for I := 0 to ColorList.Count - 1 do begin + C := DWORD(ColorList.Items[I]); + if (C and $E0C0E0) <> C then begin //Rpt( '~~~ color not found: ' + Int2Hex( C, 6 ), WHITE ); Exit; end; @@ -654,44 +593,38 @@ begin Result := TRUE; end; -function CountSystemColorsUsedInBitmap( Bmp: KOL.PBitmap; ColorList: KOL.PList ): KOL.TPixelFormat; -var Y, X: Integer; - L: PDWORD; - C: TColor; - R, G, B: Byte; - not_use_16bpp: Boolean; +function CountSystemColorsUsedInBitmap(Bmp: KOL.PBitmap; ColorList: KOL.PList): KOL.TPixelFormat; +var + Y, X: Integer; + L: PDWORD; + C: TColor; + R, G, B: Byte; + not_use_16bpp: Boolean; begin - Rpt( 'CountSystemColorsUsedInBitmap()', YELLOW ); + Rpt('CountSystemColorsUsedInBitmap()', YELLOW); ColorList.Clear; ColorList.Capacity := 65537; - TRY + try not_use_16bpp := FALSE; - for Y := 0 to Bmp.Height - 1 do - begin - L := Bmp.ScanLine[ Y ]; - for X := 0 to Bmp.Width - 1 do - begin + for Y := 0 to Bmp.Height - 1 do begin + L := Bmp.ScanLine[Y]; + for X := 0 to Bmp.Width - 1 do begin C := L^ and $FFFFFF; - if ((C and $E0C0E0) <> C) and not not_use_16bpp then - begin + if ((C and $E0C0E0) <> C) and not not_use_16bpp then begin R := C and $FF; G := (C and $FF00) shr 8; B := C shr 16; - if ((R and $E0) <> R) and (R <> $FF) or - ((G and $C0) <> G) and (G <> $FF) or - ((B and $E0) <> B) and (B <> $FF) then - begin + if ((R and $E0) <> R) and (R <> $FF) or ((G and $C0) <> G) and (G <> + $FF) or ((B and $E0) <> B) and (B <> $FF) then begin //Result := KOL.pf24bit; //Rpt( '~~~ color not found: ' + Int2Hex( C, 6 ), WHITE ); //Exit; not_use_16bpp := TRUE; end; end; - if ColorList.IndexOf( Pointer( C ) ) < 0 then - begin - ColorList.Add( Pointer( C ) ); - if ColorList.Count > 65536 then - begin + if ColorList.IndexOf(Pointer(C)) < 0 then begin + ColorList.Add(Pointer(C)); + if ColorList.Count > 65536 then begin //Result := KOL.pf24bit; //Rpt( '~~~~~ pf24bit (break) ~~~~~ (' + IntToStr( ColorList.Count ) + // ')', WHITE ); @@ -700,232 +633,219 @@ begin break; end; if not_use_16bpp and (ColorList.Count > 256) then + end; - Inc( L ); + Inc(L); end; end; if (ColorList.Count <= 2) {and ((ColorList.Count = 0) or (ColorList.Count > 0) and (DWORD(ColorList.Items[ 0 ]) and $FFFFFF = $FFFFFF) and ((ColorList.Count < 2) or - (ColorList.Count = 2) and (DWORD( ColorList.Items[ 1 ] ) and $FFFFFF = 0) ))} then - begin + (ColorList.Count = 2) and (DWORD( ColorList.Items[ 1 ] ) and $FFFFFF = 0) ))} + then begin Result := KOL.pf1bit; - Rpt( '~~~~~ pf1bit ~~~~~', WHITE ); - end else if (ColorList.Count <= 16) {and ColorsAreSystem16( ColorList )} then - begin - Result := KOL.pf4bit; - Rpt( '~~~~~ pf4bit ~~~~~', WHITE ); - end else if (ColorList.Count <= 256) {and ColorsAreSystem256( ColorList )} then - begin - Result := KOL.pf8bit; - Rpt( '~~~~~ pf8bit ~~~~~', WHITE ); - end else if (ColorList.Count <= 65536) and not not_use_16bpp - and ColorsAre64K( ColorList ) then - begin - Result := KOL.pf16bit; - Rpt( '~~~~~ pf16bit ~~~~~', WHITE ); + Rpt('~~~~~ pf1bit ~~~~~', WHITE); end - else - begin + else if (ColorList.Count <= 16) {and ColorsAreSystem16( ColorList )} then begin + Result := KOL.pf4bit; + Rpt('~~~~~ pf4bit ~~~~~', WHITE); + end + else if (ColorList.Count <= 256) {and ColorsAreSystem256( ColorList )} then begin + Result := KOL.pf8bit; + Rpt('~~~~~ pf8bit ~~~~~', WHITE); + end + else if (ColorList.Count <= 65536) and not not_use_16bpp and ColorsAre64K(ColorList) then begin + Result := KOL.pf16bit; + Rpt('~~~~~ pf16bit ~~~~~', WHITE); + end + else begin Result := KOL.pf24bit; - Rpt( '~~~~~ pf24bit ~~~~~ (' + IntToStr( ColorList.Count ) + ')', WHITE ); + Rpt('~~~~~ pf24bit ~~~~~ (' + IntToStr(ColorList.Count) + ')', WHITE); end; - FINALLY - Rpt( '------ Colors in bitmap: ' + IntToStr( ColorList.Count ), YELLOW ); + finally + Rpt('------ Colors in bitmap: ' + IntToStr(ColorList.Count), YELLOW); //ColorList.Free; - END; + end; end; -procedure OptimizeKOLBitmapBeforeRLEEncoding( B: KOL.PBitmap ); -var ColorCounts: array[ 0..255 ] of Integer; - x, y, N, i, M: Integer; - Src: PByte; - C1, C2: TColor; - Tmp: KOL.PBitmap; +procedure OptimizeKOLBitmapBeforeRLEEncoding(B: KOL.PBitmap); +var + ColorCounts: array[0..255] of Integer; + x, y, N, i, M: Integer; + Src: PByte; + C1, C2: TColor; + Tmp: KOL.PBitmap; begin - FillChar( ColorCounts, Sizeof( ColorCounts ), 0 ); - N := 0; - for y := 0 to B.Height-1 do - begin - Src := B.ScanLine[y]; - if B.PixelFormat = KOL.pf4bit then - begin - x := B.Width; - while x > 0 do - begin - inc( ColorCounts[ Src^ shr 4 ] ); - if x > 1 then - inc( ColorCounts[ Src^ and 15 ] ); - dec( x, 2 ); - inc( Src ); - end; - N := 16; - end else - begin - for x := B.Width downto 1 do - begin - inc( ColorCounts[ Src^ ] ); - inc( Src ); - end; - N := 256; - end; + FillChar(ColorCounts, Sizeof(ColorCounts), 0); + N := 0; + for y := 0 to B.Height - 1 do begin + Src := B.ScanLine[y]; + if B.PixelFormat = KOL.pf4bit then begin + x := B.Width; + while x > 0 do begin + inc(ColorCounts[Src^ shr 4]); + if x > 1 then + inc(ColorCounts[Src^ and 15]); + dec(x, 2); + inc(Src); + end; + N := 16; + end + else begin + for x := B.Width downto 1 do begin + inc(ColorCounts[Src^]); + inc(Src); + end; + N := 256; end; - M := 0; - for i := 0 to N-1 do - begin - if ColorCounts[i] > ColorCounts[M] then - M := i; - end; - if M > 0 then - begin - C1 := B.DIBPalEntries[0]; - C2 := B.DIBPalEntries[M]; - Tmp := NewBitmap( 0, 0 ); - TRY - Tmp.Assign( B ); - B.DIBPalEntries[0] := C2; - B.DIBPalEntries[M] := C1; - Tmp.Draw( B.Canvas.Handle, 0, 0 ); - FINALLY - Tmp.Free; - END; + end; + M := 0; + for i := 0 to N - 1 do begin + if ColorCounts[i] > ColorCounts[M] then + M := i; + end; + if M > 0 then begin + C1 := B.DIBPalEntries[0]; + C2 := B.DIBPalEntries[M]; + Tmp := NewBitmap(0, 0); + try + Tmp.Assign(B); + B.DIBPalEntries[0] := C2; + B.DIBPalEntries[M] := C1; + Tmp.Draw(B.Canvas.Handle, 0, 0); + finally + Tmp.Free; end; + end; end; // This version of GenerateBitmapResource provided by Alex Pravdin. // It does not use brcc32.exe, and creates res-file directly, so // it is fast and has no restrictions on bitmap format at all. -procedure GenerateBitmapResource( Bitmap: TBitmap; const RsrcName, FileName: - String; var Updated: Boolean; AllowCompression: Boolean ); +procedure GenerateBitmapResource(Bitmap: TBitmap; const RsrcName, FileName: + string; var Updated: Boolean; AllowCompression: Boolean); var - HD1: packed record // First part of RESOURCEHEADER structure before + HD1: packed record // First part of RESOURCEHEADER structure before // Unicode string contained bitmap resource name - DataSize: cardinal; - HeaderSize: cardinal; - NFFFF: word; - DataType: word; - end; - - HD2: packed record // Second part of RESOURCEHEADER - DataVersion: cardinal; - MemFlags: word; - PrimaryLang: byte; - SubLang: byte; - Version: cardinal; - Charact: cardinal; - end; - - br, hFR, hFtm, DIBLen, WLen, RLen, tm: DWORD; - Buf1, Buf2: PByteArray; - FE: boolean; - Res: String; - Bmp: String; - tmStr: WideString; - - KOLBmp: KOL.PBitmap; - KOLPF: KOL.TPixelFormat; - ColorList: KOL.PList; - N, i: Integer; - Mem, MemRLE: KOL.PStream; + DataSize: cardinal; + HeaderSize: cardinal; + NFFFF: word; + DataType: word; + end; + HD2: packed record // Second part of RESOURCEHEADER + DataVersion: cardinal; + MemFlags: word; + PrimaryLang: byte; + SubLang: byte; + Version: cardinal; + Charact: cardinal; + end; + br, hFR, hFtm, DIBLen, WLen, RLen, tm: DWORD; + Buf1, Buf2: PByteArray; + FE: boolean; + Res: string; + Bmp: string; + tmStr: WideString; + KOLBmp: KOL.PBitmap; + KOLPF: KOL.TPixelFormat; + ColorList: KOL.PList; + N, i: Integer; + Mem, MemRLE: KOL.PStream; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'GenerateBitmapResource', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'GenerateBitmapResource', 0 + +@@e_signature: end; Res := ProjectSourcePath + FileName + '.res'; Bmp := ProjectSourcePath + FileName + '.bmp'; - FE := FileExists( Res ); + FE := FileExists(Res); - Rpt( 'Generating resource ' + RsrcName, YELLOW ); + Rpt('Generating resource ' + RsrcName, YELLOW); //Bitmap.SaveToFile( Bmp ); - KOLBmp := KOL.NewDIBBitmap( Bitmap.Width, Bitmap.Height, KOL.pf32bit ); - BitBlt( KOLBmp.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, - Bitmap.Canvas.Handle, 0, 0, SRCCOPY ); + KOLBmp := KOL.NewDIBBitmap(Bitmap.Width, Bitmap.Height, KOL.pf32bit); + BitBlt(KOLBmp.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle, 0, 0, SRCCOPY); KOLBmp.HandleType := KOL.bmDIB; KOLBmp.PixelFormat := KOL.pf32bit; ColorList := NewList; - TRY - KOLPF := CountSystemColorsUsedInBitmap( KOLBmp, ColorList ); - if ColorList.Count > 0 then - begin - KOLBmp.PixelFormat := KOLPF; - KOLBmp.HandleType := KOL.bmDIB; - N := 0; - CASE KOLPF OF - KOL.pf1bit: N := 2; - KOL.pf4bit: N := 16; - KOL.pf8bit: N := 256; - END; - if N > 0 then - begin - for i := 0 to min( ColorList.Count, N )-1 do - begin - KOLBmp.DIBPalEntries[i] := Integer( ColorList.Items[i] ); - end; - // - BitBlt( KOLBmp.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, - Bitmap.Canvas.Handle, 0, 0, SRCCOPY ); - // - end; - //KOLBmp.SaveToFile( Bmp ); - Mem := NewMemoryStream; - MemRLE := NewMemoryStream; - TRY - if AllowCompression then - KOLBmp.CoreSaveToStream( Mem ) - else KOLBmp.SaveToStream( Mem ); - if (N > 0) and AllowCompression then - begin - if KOLPF = KOL.pf1bit then - KOLBmp.PixelFormat := KOL.pf4bit; - OptimizeKOLBitmapBeforeRLEEncoding( KOLBmp ); - KOLBmp.RLESaveToStream( MemRLE ); - end; - if (MemRLE.Size > 0) and (MemRLE.Size < Mem.Size) then - KOL.Swap( PtrInt( Mem ), PtrInt( MemRLE ) ); - Mem.Position := 0; - Mem.SaveToFile( Bmp, 0, Mem.Size ); - FINALLY - Mem.Free; - MemRLE.Free; - END; - end - else - begin - Bitmap.SaveToFile( Bmp ); + try + KOLPF := CountSystemColorsUsedInBitmap(KOLBmp, ColorList); + if ColorList.Count > 0 then begin + KOLBmp.PixelFormat := KOLPF; + KOLBmp.HandleType := KOL.bmDIB; + N := 0; + case KOLPF of + KOL.pf1bit: + N := 2; + KOL.pf4bit: + N := 16; + KOL.pf8bit: + N := 256; end; - Rpt( 'Bitmap saved to ' + Bmp, YELLOW ); - KOLBmp.Free; - FINALLY - ColorList.Free; - END; - - if FE then - begin - DeleteFile( PChar( Res + '_tmp' ) ); - CopyFile( PChar(Res), PChar( (Res+'_tmp') ), False ); + if N > 0 then begin + for i := 0 to min(ColorList.Count, N) - 1 do begin + KOLBmp.DIBPalEntries[i] := Integer(ColorList.Items[i]); + end; + // + BitBlt(KOLBmp.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle, 0, 0, SRCCOPY); + // + end; + //KOLBmp.SaveToFile( Bmp ); + Mem := NewMemoryStream; + MemRLE := NewMemoryStream; + try + if AllowCompression then + KOLBmp.CoreSaveToStream(Mem) + else + KOLBmp.SaveToStream(Mem); + if (N > 0) and AllowCompression then begin + if KOLPF = KOL.pf1bit then + KOLBmp.PixelFormat := KOL.pf4bit; + OptimizeKOLBitmapBeforeRLEEncoding(KOLBmp); + KOLBmp.RLESaveToStream(MemRLE); + end; + if (MemRLE.Size > 0) and (MemRLE.Size < Mem.Size) then + KOL.Swap(PtrInt(Mem), PtrInt(MemRLE)); + Mem.Position := 0; + Mem.SaveToFile(Bmp, 0, Mem.Size); + finally + Mem.Free; + MemRLE.Free; + end; + end + else begin + Bitmap.SaveToFile(Bmp); + end; + Rpt('Bitmap saved to ' + Bmp, YELLOW); + KOLBmp.Free; + finally + ColorList.Free; end; - hFR := CreateFile( PChar(Res), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, - nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0 ); + if FE then begin + DeleteFile(PChar(Res + '_tmp')); + CopyFile(PChar(Res), PChar((Res + '_tmp')), False); + end; + + hFR := CreateFile(PChar(Res), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, + nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); if hFR = INVALID_HANDLE_VALUE then begin - Rpt( 'Can not create file ' + Res + #13#10'Error: ' + SysErrorMessage( GetLastError ), RED ); - Exit; + Rpt('Can not create file ' + Res + #13#10'Error: ' + SysErrorMessage(GetLastError), RED); + Exit; end; - hFtm := CreateFile( PChar(Bmp), GENERIC_READ, FILE_SHARE_READ, nil, - OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 ); + hFtm := CreateFile(PChar(Bmp), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); - DIBLen := GetFileSize( hFtm, nil ) - 14{SizeOf( TBITMAPFILEHEADER )}; - WLen := ( Length( RsrcName ) + 1 ) * 2; + DIBLen := GetFileSize(hFtm, nil) - 14{SizeOf( TBITMAPFILEHEADER )}; + WLen := (Length(RsrcName) + 1) * 2; HD1.DataSize := DIBLen; - HD1.HeaderSize := 12{SizeOf( HD1 )} + 16{SizeOf( HD2 )} + WLen; + HD1.HeaderSize := 12{SizeOf( HD1 )} + 16{SizeOf( HD2 )} + WLen; HD1.NFFFF := $FFFF; HD1.DataType := 2; // RT_BITMAP HD2.DataVersion := 0; @@ -936,67 +856,73 @@ begin HD2.Charact := 0; RLen := HD1.HeaderSize + DIBLen + 32; - GetMem( Buf1, RLen ); - FillChar( Buf1[0], RLen, 0 ); + GetMem(Buf1, RLen); + FillChar(Buf1[0], RLen, 0); - Buf1[4]:=$20; Buf1[8]:=$FF; Buf1[9]:=$FF; Buf1[12]:=$FF; Buf1[13]:=$FF; + Buf1[4] := $20; + Buf1[8] := $FF; + Buf1[9] := $FF; + Buf1[12] := $FF; + Buf1[13] := $FF; - tmStr := UpperCase( RsrcName ) + #0; - CopyMemory( @Buf1[32], @HD1, 12 ); - CopyMemory( @Buf1[32+12], @tmStr[1], WLen ); - CopyMemory( @Buf1[32+12+WLen], @HD2, 16 ); + tmStr := UpperCase(RsrcName) + #0; + CopyMemory(@Buf1[32], @HD1, 12); + CopyMemory(@Buf1[32 + 12], @tmStr[1], WLen); + CopyMemory(@Buf1[32 + 12 + WLen], @HD2, 16); - SetFilePointer( hFtm, 14{SizeOf( TBITMAPFILEHEADER )}, nil, FILE_BEGIN); - ReadFile( hFtm, Buf1[32+12+16+WLen], DIBLen, br, nil ); + SetFilePointer(hFtm, 14{SizeOf( TBITMAPFILEHEADER )}, nil, FILE_BEGIN); + ReadFile(hFtm, Buf1[32 + 12 + 16 + WLen], DIBLen, br, nil); - WriteFile( hFR, Buf1[0], RLen, br, nil ); - CloseHandle( hFtm ); - CloseHandle( hFR ); + WriteFile(hFR, Buf1[0], RLen, br, nil); + CloseHandle(hFtm); + CloseHandle(hFR); //------------------------------------------------ - DeleteFile( Bmp ); + DeleteFile(Bmp); if FE then begin - hFtm := CreateFile( PChar( (Res+'_tmp') ), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 ); - tm := GetFileSize( hFtm, nil ); - GetMem( Buf2, tm ); - ReadFile( hFtm, Buf2[0], tm, br, nil ); - CloseHandle( hFtm ); - DeleteFile( Res + '_tmp' ); - if ( RLen <> tm ) or (not CompareMem( @Buf1[0], @Buf2[0], Min( RLen, tm ) )) then begin - Rpt( 'Resource ' + Res + ' changed.', WHITE ); - Updated := True; - end; - FreeMem( Buf2 ); + hFtm := CreateFile(PChar((Res + '_tmp')), GENERIC_READ, FILE_SHARE_READ, nil, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); + tm := GetFileSize(hFtm, nil); + GetMem(Buf2, tm); + ReadFile(hFtm, Buf2[0], tm, br, nil); + CloseHandle(hFtm); + DeleteFile(Res + '_tmp'); + if (RLen <> tm) or (not CompareMem(@Buf1[0], @Buf2[0], Min(RLen, tm))) then begin + Rpt('Resource ' + Res + ' changed.', WHITE); + Updated := True; + end; + FreeMem(Buf2); end; - FreeMem( Buf1 ); + FreeMem(Buf1); end; -function SaveIcon( Icon: TIcon; const Path: String ): Boolean; -var MS, MS2: TMemoryStream; +function SaveIcon(Icon: TIcon; const Path: string): Boolean; +var + MS, MS2: TMemoryStream; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'SaveIcon', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'SaveIcon', 0 + +@@e_signature: end; Result := TRUE; MS := TMemoryStream.Create; MS2 := TMemoryStream.Create; try - Icon.SaveToStream( MS ); - if FileExists( Path ) then - begin - MS2.LoadFromFile( Path ); - if (MS.Size = MS2.Size) and CompareMem( MS.Memory, MS2.Memory, MS.Size ) then + Icon.SaveToStream(MS); + if FileExists(Path) then begin + MS2.LoadFromFile(Path); + if (MS.Size = MS2.Size) and CompareMem(MS.Memory, MS2.Memory, MS.Size) then Exit; - if FileExists( Path + '.$$$' ) then - DeleteFile( Path + '.$$$' ); - MoveFile( PChar( Path ), PChar( Path + '.$$$' ) ); + if FileExists(Path + '.$$$') then + DeleteFile(Path + '.$$$'); + MoveFile(PChar(Path), PChar(Path + '.$$$')); end; MS.Position := 0; - MS.SaveToFile( Path ); + MS.SaveToFile(Path); //Result := True; //Rpt( 'Icon stored to ' + Path ); finally @@ -1005,96 +931,93 @@ begin end; end; -procedure GenerateIconResource( Icon: TIcon; const RsrcName, FileName: KOLString; - var Updated: Boolean ); -var RL: TStringList; - Buf1, Buf2: PKOLChar; - S: String; - I, J: Integer; - F: THandle; +procedure GenerateIconResource(Icon: TIcon; const RsrcName, FileName: KOLString; var Updated: Boolean); +var + RL: TStringList; + Buf1, Buf2: PKOLChar; + S: string; + I, J: Integer; + F: THandle; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'GenerateIconResource', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'GenerateIconResource', 0 + +@@e_signature: end; {if not SaveIcon( Icon, ProjectSourcePath + FileName + '.ico' ) and FileExists( ProjectSourcePath + FileName + '.res' ) then Exit;} - if not SaveIcon( Icon, ProjectSourcePath + FileName + '.ico' ) then - Exit; + if not SaveIcon(Icon, ProjectSourcePath + FileName + '.ico') then + Exit; RL := TStringList.Create; - RL.Add( KOLUpperCase( RsrcName ) + ' ICON "' + FileName + '.ico"' ); - RL.SaveToFile( ProjectSourcePath + FileName + '.rc' ); + RL.Add(KOLUpperCase(RsrcName) + ' ICON "' + FileName + '.ico"'); + RL.SaveToFile(ProjectSourcePath + FileName + '.rc'); RL.Free; Buf1 := nil; Buf2 := nil; - I := 0; J := 0; + I := 0; + J := 0; S := ProjectSourcePath + FileName + '.res'; - if FileExists( S ) then - begin - I := FileSize( S ); - if I > 0 then - begin - GetMem( Buf1, I ); - F := KOL.FileCreate( S, ofOpenRead or ofShareDenyWrite or ofOpenExisting ); - if F <> THandle( -1 ) then - begin - KOL.FileRead( F, Buf1^, I ); - KOL.FileClose( F ); + if FileExists(S) then begin + I := FileSize(S); + if I > 0 then begin + GetMem(Buf1, I); + F := KOL.FileCreate(S, ofOpenRead or ofShareDenyWrite or ofOpenExisting); + if F <> THandle(-1) then begin + KOL.FileRead(F, Buf1^, I); + KOL.FileClose(F); end; end; end; {ShellExecute( 0, 'open', PChar( ExtractFilePath( Application.ExeName ) + 'brcc32.exe' ), PChar( ProjectSourcePath + FileName + '.rc' ), PChar( ProjectSourcePath ), SW_HIDE );} - ExecuteWait( ExtractFilePath( Application.ExeName ) + 'brcc32.exe', - '"' + ProjectSourcePath + FileName + '.rc"', - ProjectSourcePath, SW_HIDE, INFINITE, nil ); - if FileExists( S ) then - begin - J := FileSize( S ); - if J > 0 then - begin - GetMem( Buf2, J ); - F := KOL.FileCreate( S, ofOpenRead or ofShareDenyWrite or ofOpenExisting ); - if F <> THandle( -1 ) then - begin - KOL.FileRead( F, Buf2^, J ); - KOL.FileClose( F ); + ExecuteWait(ExtractFilePath(Application.ExeName) + 'brcc32.exe', '"' + + ProjectSourcePath + FileName + '.rc"', ProjectSourcePath, SW_HIDE, INFINITE, nil); + if FileExists(S) then begin + J := FileSize(S); + if J > 0 then begin + GetMem(Buf2, J); + F := KOL.FileCreate(S, ofOpenRead or ofShareDenyWrite or ofOpenExisting); + if F <> THandle(-1) then begin + KOL.FileRead(F, Buf2^, J); + KOL.FileClose(F); end; end; end; - if (Buf1 = nil) or (I <> J) or - (Buf2 <> nil) and not CompareMem( Buf1, Buf2, J ) then - begin + if (Buf1 = nil) or (I <> J) or (Buf2 <> nil) and not CompareMem(Buf1, Buf2, J) then begin Updated := TRUE; end; - if Buf1 <> nil then FreeMem( Buf1 ); - if Buf2 <> nil then FreeMem( Buf2 ); + if Buf1 <> nil then + FreeMem(Buf1); + if Buf2 <> nil then + FreeMem(Buf2); end; { TKOLTimer } -procedure TKOLTimer.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLTimer.AssignEvents(SL: TStringList; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTimer.AssignEvents', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTimer.AssignEvents', 0 + +@@e_signature: end; inherited; - DoAssignEvents( SL, AName, [ 'OnTimer' ], [ @OnTimer ] ); + DoAssignEvents(SL, AName, ['OnTimer'], [@OnTimer]); end; constructor TKOLTimer.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTimer.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTimer.Create', 0 + +@@e_signature: end; inherited; fInterval := 1000; @@ -1103,85 +1026,14 @@ begin FResolution := 0; end; -function TKOLTimer.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLTimer.P_AssignEvents(SL: TStringList; const AName: String; CheckOnly: Boolean): Boolean; -begin - Result := inherited P_AssignEvents( SL, AName, CheckOnly ); - {P}SL.Add( ' //inherited P_AssignEvents called:' + IntToStr( Integer( Result ) ) ); - if Result and CheckOnly then Exit; - if P_DoAssignEvents( SL, AName, [ 'OnTimer' ], [ @OnTimer ], [ FALSE ], CheckOnly ) - and CheckOnly then Exit; - Result := FALSE; -end; - -procedure TKOLTimer.P_DoProvideFakeType(SL: TStringList); -begin - if not Multimedia then - P_ProvideFakeType( SL, 'type TTimer_ = object(KOL.TTimer) end;' ) - else - P_ProvideFakeType( SL, 'type TMMTimer_ = object(KOL.TMMTimer) end;' ); -end; - -procedure TKOLTimer.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTimer.SetupFirst', 0 - @@e_signature: - end; - if Multimedia then - begin - //SL.Add( Prefix + AName + ' := NewMMTimer( ' + IntToStr( Interval ) + ' );' ); - {P}SL.Add( ' L(' + IntToStr( Interval ) + ') NewMMTimer<1> ' + - ' RESULT DUP LoadSELF ' + - 'AddWord_Store ##T' + ParentKOLForm.formName + '.' + Name ); - if not Periodic then - //SL.Add( Prefix + 'PMMTimer(' + AName + ').Periodic := FALSE;' ); - {P}SL.Add( ' L(0) C1 TMMTimer_.SetPeriodic<2>' ); - if Resolution > 0 then - //SL.Add( Prefix + 'PMMTimer(' + AName + ').Resolution := ' + IntToStr( Resolution ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( Resolution ) + - ') C1 AddByte_Store #TMMTimer_.fResolution' ); - end - else - //SL.Add( Prefix + AName + ' := NewTimer( ' + IntToStr( Interval ) + ' );' ); - {P}SL.Add( ' L(' + IntToStr( Interval ) + ') NewTimer<1> ' + - ' RESULT DUP LoadSELF ' + - 'AddWord_Store ##T' + ParentKOLForm.formName + '.' + Name ); - P_GenerateTag( SL, AName, Prefix ); -end; - -procedure TKOLTimer.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTimer.P_SetupLast', 0 - @@e_signature: - end; - if Enabled then - //SL.Add( Prefix + AName + '.Enabled := True;' ); - begin - {P}SL.Add( ' L(1) ' + - 'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name + - ' TTimer_.SetEnabled<2>' ); - end; -end; - procedure TKOLTimer.SetEnabled(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTimer.SetEnabled', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTimer.SetEnabled', 0 + +@@e_signature: end; FEnabled := Value; Change; @@ -1190,10 +1042,11 @@ end; procedure TKOLTimer.SetInterval(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTimer.SetInterval', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTimer.SetInterval', 0 + +@@e_signature: end; FInterval := Value; Change; @@ -1208,10 +1061,11 @@ end; procedure TKOLTimer.SetOnTimer(const Value: TOnEvent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTimer.SetOnTimer', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTimer.SetOnTimer', 0 + +@@e_signature: end; FOnTimer := Value; Change; @@ -1229,82 +1083,85 @@ begin Change; end; -procedure TKOLTimer.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); +procedure TKOLTimer.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTimer.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTimer.SetupFirst', 0 + +@@e_signature: end; - if Multimedia then - begin - SL.Add( Prefix + AName + ' := NewMMTimer( ' + IntToStr( Interval ) + ' );' ); + if Multimedia then begin + SL.Add(Prefix + AName + ' := NewMMTimer( ' + IntToStr(Interval) + ' );'); if not Periodic then - SL.Add( Prefix + 'PMMTimer(' + AName + ').Periodic := FALSE;' ); + SL.Add(Prefix + 'PMMTimer(' + AName + ').Periodic := FALSE;'); if Resolution > 0 then - SL.Add( Prefix + 'PMMTimer(' + AName + ').Resolution := ' + IntToStr( Resolution ) + ';' ); + SL.Add(Prefix + 'PMMTimer(' + AName + ').Resolution := ' + IntToStr(Resolution) + ';'); end else - SL.Add( Prefix + AName + ' := NewTimer( ' + IntToStr( Interval ) + ' );' ); + SL.Add(Prefix + AName + ' := NewTimer( ' + IntToStr(Interval) + ' );'); //AssignEvents( SL, AName ); - GenerateTag( SL, AName, Prefix ); + GenerateTag(SL, AName, Prefix); end; -procedure TKOLTimer.SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); +procedure TKOLTimer.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTimer.SetupLast', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTimer.SetupLast', 0 + +@@e_signature: end; if Enabled then - SL.Add( Prefix + AName + '.Enabled := True;' ); + SL.Add(Prefix + AName + '.Enabled := True;'); end; -function TKOLTimer.TypeName: String; +function TKOLTimer.TypeName: string; begin - if Multimedia then Result := 'MMTimer' - else Result := inherited TypeName; + if Multimedia then + Result := 'MMTimer' + else + Result := inherited TypeName; end; { TKOLImageList } procedure TKOLImageList.Assign(Value: TPersistent); -var IL: TKOLImageList; +var + IL: TKOLImageList; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.Assign', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.Assign', 0 + +@@e_signature: end; - if (Value <> nil) and (Value is TKOLImageList) then - begin + if (Value <> nil) and (Value is TKOLImageList) then begin IL := Value as TKOLImageList; FImgWidth := IL.ImgWidth; FImgHeight := IL.ImgHeight; FCount := IL.Count; - FBitmap.Assign( IL.Bitmap ); + FBitmap.Assign(IL.Bitmap); FSystemImageList := IL.SystemImageList; FTransparentColor := IL.TransparentColor; end - else + else inherited; Change; end; procedure TKOLImageList.AssignBitmapToKOLImgList; -var R: Integer; - TmpBmp: TBitmap; +var + R: Integer; + TmpBmp: TBitmap; begin - if FKOLImgList = nil then Exit; - if Bitmap <> nil then - begin + if FKOLImgList = nil then + Exit; + if Bitmap <> nil then begin //Bitmap.SaveToFile( 'c:\test1.bmp' ); //ShowMessage( 'Bitmap.Handle=' + IntToStr( Bitmap.Handle ) ); FKOLImgList.Clear; @@ -1315,28 +1172,25 @@ begin {Bitmap.HandleType := bmDIB; Bitmap.PixelFormat := pf24bit;} //ShowMessage( Int2Hex( Color2RGB( BkColor ), 8 ) ); - if not Bitmap.Empty then - begin + if not Bitmap.Empty then begin //Bitmap.SaveToFile( 'c:\test2.bmp' ); TmpBmp := TBitmap.Create; - TRY - TmpBmp.Assign( Bitmap ); + try + TmpBmp.Assign(Bitmap); if Masked then - R := FKOLImgList.AddMasked( TmpBmp.Handle, Color2RGB( TransparentColor ) ) - else - begin + R := FKOLImgList.AddMasked(TmpBmp.Handle, Color2RGB(TransparentColor)) + else begin FKOLImgList.Masked := FALSE; - R := FKOLImgList.Add( TmpBmp.Handle, 0 ); + R := FKOLImgList.Add(TmpBmp.Handle, 0); end; if R < 0 then - ShowMessage( 'Error adding bitmap: ' + SysErrorMessage( GetLastError ) ) - else - begin - DoNotifyLinkedComponents( noChanged ); + ShowMessage('Error adding bitmap: ' + SysErrorMessage(GetLastError)) + else begin + DoNotifyLinkedComponents(noChanged); end; - FINALLY + finally TmpBmp.Free; - END; + end; //Bitmap.SaveToFile( 'c:\test3.bmp' ); //ShowMessage( 'Result := ' + IntToStr( R ) ); //ShowMessage( 'FKOLImgList.Handle=' + IntToStr( FKOLImgList.Handle ) ); @@ -1352,28 +1206,29 @@ end;} procedure TKOLImageList.Clear; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.Clear', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.Clear', 0 + +@@e_signature: end; - if FBitmap <> nil then - begin + if FBitmap <> nil then begin FBitmap.Width := 0; FBitmap.Height := 0; end; FCount := 0; end; -constructor TKOLImageList.Create( AOwner: TComponent ); +constructor TKOLImageList.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.Create', 0 + +@@e_signature: end; - inherited Create( AOwner ); + inherited Create(AOwner); FBkColor := clNone; FBitmap := TBitmap.Create; //FBitmap.OnChange := BitmapChanged; @@ -1390,10 +1245,11 @@ end; destructor TKOLImageList.Destroy; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.Destroy', 0 + +@@e_signature: end; FKOLImgList.Free; FBitmap.Free; @@ -1403,10 +1259,11 @@ end; function TKOLImageList.GetBitmap: TBitmap; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.GetBitmap', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.GetBitmap', 0 + +@@e_signature: end; if SystemImageList then Result := nil @@ -1416,9 +1273,8 @@ end; function TKOLImageList.GetImageListHandle: THandle; begin - if FKOLImgList = nil then - begin - FKOLImgList := NewImageList( nil ); + if FKOLImgList = nil then begin + FKOLImgList := NewImageList(nil); AssignBitmapToKOLImgList; end; Result := FKOLImgList.Handle; @@ -1427,95 +1283,23 @@ end; function TKOLImageList.GetTransparentColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.GetTransparentColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.GetTransparentColor', 0 + +@@e_signature: end; Result := FTransparentColor; if Result = clDefault then - if FBitmap <> nil then - if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then - Result := FBitmap.Canvas.Pixels[ 0, FBitmap.Height - 1 ]; -end; - -function TKOLImageList.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLImageList.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -const Booleans: array[ Boolean ] of String = ( 'False', 'True' ); -const ColorsValues: array[ TImageListColors ] of String = ( 'ilcColor', 'ilcColor4', - 'ilcColor8', 'ilcColor16', 'ilcColor24', 'ilcColor32', 'ilcColorDDB', - 'ilcDefault' ); -var RsrcName, RsrcFile: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.P_SetupFirst', 0 - @@e_signature: - end; - //SL.Add( Prefix + AName + ' := NewImageList( ' + AParent + ' );' ); - {P}SL.Add( ' DUP NewImageList<1> RESULT DUP LoadSELF AddWord_Store ##T' + - ParentKOLForm.FormName + '.' + Name ); - P_GenerateTag( SL, AName, Prefix ); - if SystemImageList then - //SL.Add( Prefix + AName + '.LoadSystemIcons( ' + Booleans[ ImgHeight = 16 ] + ' );' ) - {P}SL.Add( ' L(' + IntToStr( Integer( ImgHeight = 16 ) ) + ') C1 ' + - ' TImageList.LoadSystemIcons<2>' ) - else - begin - if Colors <> ilcDefault then - //SL.Add( Prefix + AName + '.Colors := ' + ColorsValues[ Colors ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( Colors ) ) + ') C1 TImageList_.SetColors<2>' ); - if not Masked then - begin - //SL.Add( Prefix + AName + '.Masked := FALSE;' ); - {P}SL.Add( ' L(0) C1 TImageList_.SetMasked<2>' ); - if BkColor <> clNone then - //SL.Add( Prefix + AName + '.BkColor := ' + Color2Str( BkColor ) + ';' ); - {P}SL.Add( ' L($' + IntToHex( BkColor, 6 ) + ') C1 TImageList_.SetBkColor<2>' ); - end; - if FImgWidth <> 32 then - //SL.Add( Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr( FImgWidth ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( FImgWidth ) + ') C1 TImageList_.SetImgWidth<2>' ); - if FImgHeight <> 32 then - //SL.Add( Prefix + ' ' + AName + '.ImgHeight := ' + IntToStr( FImgHeight ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( FImgHeight ) + ') C1 TImageList_.SetImgHeight<2>' ); - end; - if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then - begin - if (FImgHeight = 32) and (FImgWidth <> FImgHeight) then - //SL.Add( Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr( FImgWidth ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( FImgWidth ) + ') C1 TImageList_.SetImgWidth<2>' ); - RsrcName := UpperCase( ParentKOLForm.FormName + '_' + Name ); - RsrcFile := ParentKOLForm.FormName + '_' + Name; - SL.Add( Prefix + ' {$R ' + RsrcFile + '.res}' ); - if Masked then - {SL.Add( Prefix + AName + '.AddMasked( LoadBmp( hInstance, ''' + - RsrcName + ''', ' + - AName + ' ), ' + Color2Str( TransparentColor ) + ' );' )} - {P}SL.Add( ' L($' + IntToHex( TransparentColor, 6 ) + ')' + - ' C1 LoadStr ''' + RsrcName + ''' #0 LoadHInstance' + - ' LoadBmp<3> RESULT' + - ' C2 TImageList.AddMasked<3>' ) - else - {SL.Add( Prefix + AName + '.Add( LoadBmp( hInstance, ''' + - RsrcName + ''', ' + - AName + ' ), 0 );' );} - {P}SL.Add( ' L(0) C1 LoadStr ''' + RsrcName + ''' #0 LoadHInstance' + - ' LoadBmp<3> RESULT C2 TImageList.Add<3>' ); - //Rpt( 'Generating resource: ' + ProjectSourcePath + RsrcFile + '.res' ); - GenerateBitmapResource( FBitmap, RsrcName, RsrcFile, fUpdated, AllowCompression ); - end; + if FBitmap <> nil then + if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then + Result := FBitmap.Canvas.Pixels[0, FBitmap.Height - 1]; end; procedure TKOLImageList.SetAllowCompression(const Value: Boolean); begin - if FAllowCompression = Value then Exit; + if FAllowCompression = Value then + Exit; FAllowCompression := Value; Change; end; @@ -1523,36 +1307,46 @@ end; procedure TKOLImageList.SetBitmap(const Value: TBitmap); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetBitmap', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetBitmap', 0 + +@@e_signature: end; - if FBitmap = Value then Exit; - FBitmap.Assign( Value ); - if (FBitmap.Height <> 0) and (FBitmap.Width <> 0) then - begin + if FBitmap = Value then + Exit; + FBitmap.Assign(Value); + if (FBitmap.Height <> 0) and (FBitmap.Width <> 0) then begin FImgHeight := FBitmap.Height; - {AK->}if FImgWidth<=0 then{<-AK} FImgWidth := FImgHeight; + {AK->} if FImgWidth <= 0 then{<-AK} + FImgWidth := FImgHeight; FCount := FBitmap.Width div FImgWidth; end; if FBitmap.HandleType = bmDDB then Colors := ilcColorDDB - else - begin + else begin //if Colors = ilcDefault then case FBitmap.PixelFormat of - pf1bit, - pf4bit: if Colors < ilcColor4 then Colors := ilcColor4; - pf8bit: if Colors < ilcColor8 then Colors := ilcColor8; - pf15bit, pf16bit: if Colors < ilcColor16 then Colors := ilcColor16; - pf32bit:if Colors < ilcColor32 then Colors := ilcColor32; + pf1bit, pf4bit: + if Colors < ilcColor4 then + Colors := ilcColor4; + pf8bit: + if Colors < ilcColor8 then + Colors := ilcColor8; + pf15bit, pf16bit: + if Colors < ilcColor16 then + Colors := ilcColor16; + pf32bit: + if Colors < ilcColor32 then + Colors := ilcColor32; //pf24bit: - else if Colors < ilcColor24 then Colors := ilcColor24; + else + if Colors < ilcColor24 then + Colors := ilcColor24; end; end; if (FBitmap.Height <> 0) and (FBitmap.Width <> 0) then begin - TransparentColor := FBitmap.Canvas.Pixels[ 0, FBitmap.Height - 1 ]; + TransparentColor := FBitmap.Canvas.Pixels[0, FBitmap.Height - 1]; end; if FKOLImgList <> nil then AssignBitmapToKOLImgList; @@ -1562,10 +1356,11 @@ end; procedure TKOLImageList.SetBkColor(const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetBkColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetBkColor', 0 + +@@e_signature: end; FBkColor := Value; AssignBitmapToKOLImgList; @@ -1573,73 +1368,85 @@ begin end; procedure TKOLImageList.SetColors(const Value: TImageListColors); -var KOLBmp: KOL.PBitmap; +var + KOLBmp: KOL.PBitmap; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetColors', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetColors', 0 + +@@e_signature: end; - if FColors = Value then Exit; + if FColors = Value then + Exit; FColors := Value; - if FBitmap = nil then Exit; - if FBitmap.Width * FBitmap.Height = 0 then Exit; - KOLBmp := NewBitmap( FBitmap.Width, FBitmap.Height ); - TRY + if FBitmap = nil then + Exit; + if FBitmap.Width * FBitmap.Height = 0 then + Exit; + KOLBmp := NewBitmap(FBitmap.Width, FBitmap.Height); + try KOLBmp.HandleType := KOL.bmDIB; KOLBmp.PixelFormat := KOL.pf32bit; - BitBlt( KOLBmp.Canvas.Handle, 0, 0, FBitmap.Width, FBitmap.Height, - FBitmap.Canvas.Handle, 0, 0, SrcCopy ); + BitBlt(KOLBmp.Canvas.Handle, 0, 0, FBitmap.Width, FBitmap.Height, FBitmap.Canvas.Handle, 0, 0, SrcCopy); case Value of - ilcColor4: KOLBmp.PixelFormat := KOL.pf4bit; - ilcColor8: KOLBmp.PixelFormat := KOL.pf8bit; - ilcColor24: KOLBmp.PixelFormat := KOL.pf24bit; - ilcColor32: KOLBmp.PixelFormat := KOL.pf32bit; - else KOLBmp.HandleType := KOL.bmDDB; + ilcColor4: + KOLBmp.PixelFormat := KOL.pf4bit; + ilcColor8: + KOLBmp.PixelFormat := KOL.pf8bit; + ilcColor24: + KOLBmp.PixelFormat := KOL.pf24bit; + ilcColor32: + KOLBmp.PixelFormat := KOL.pf32bit; + else + KOLBmp.HandleType := KOL.bmDDB; end; FBitmap.Handle := KOLBmp.ReleaseHandle; - FINALLY + finally KOLBmp.Free; - END; + end; Change; end; procedure TKOLImageList.SetCount(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetCount', 0 + +@@e_signature: end; FCount := Value; - if Value > 0 then - begin - {AK->} if FImgWidth <= 0 then {<-AK} // change by Andrzej Kubaszek 28-Jan-2002 + if Value > 0 then begin + {AK->} if FImgWidth <= 0 then {<-AK} // change by Andrzej Kubaszek 28-Jan-2002 FImgWidth := FImgHeight; if FBitmap <> nil then - if FBitmap.Width > 0 then - FImgWidth := FBitmap.Width div FCount; + if FBitmap.Width > 0 then + FImgWidth := FBitmap.Width div FCount; end; Change; end; procedure TKOLImageList.SetForce32bit(const Value: Boolean); begin - if FForce32bit = Value then Exit; + if FForce32bit = Value then + Exit; FForce32bit := Value; Change; end; procedure TKOLImageList.SetImgHeight(Value: Integer); -var I: Integer; +var + I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetImgHeight', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetImgHeight', 0 + +@@e_signature: end; if Value < 0 then Value := 0; @@ -1648,26 +1455,24 @@ begin Value := 32 else Value := 16 - else - if FBitmap <> nil then - begin + else if FBitmap <> nil then begin if not FBitmap.Empty then - if (FBitmap.Height <> 0) and (FBitmap.Width <> 0) then - if Value <> FBitmap.Height then - Value := FBitmap.Height; + if (FBitmap.Height <> 0) and (FBitmap.Width <> 0) then + if Value <> FBitmap.Height then + Value := FBitmap.Height; end; - if FImgHeight = Value then Exit; + if FImgHeight = Value then + Exit; if Count > 0 then - if not( csLoading in ComponentState ) then - begin - I := MessageBox( 0, 'Changing image list height will lead to clearing it. Are ' + - 'You sure You want to change height now?', - 'TKOLImageList.ImgHeight change', MB_YESNO or - MB_DEFBUTTON2 or MB_SETFOREGROUND ); - if I = ID_NO then Exit; - Clear; - end; + if not (csLoading in ComponentState) then begin + I := MessageBox(0, + 'Changing image list height will lead to clearing it. Are ' + 'You sure You want to change height now?', + 'TKOLImageList.ImgHeight change', MB_YESNO or MB_DEFBUTTON2 or MB_SETFOREGROUND); + if I = ID_NO then + Exit; + Clear; + end; FImgHeight := Value; if SystemImageList then FImgWidth := FImgHeight; @@ -1675,42 +1480,42 @@ begin end; procedure TKOLImageList.SetImgWidth(Value: Integer); -var I: Integer; +var + I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetImgWidth', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetImgWidth', 0 + +@@e_signature: end; - if Value < 0 then Value := 0; - if SystemImageList then - begin + if Value < 0 then + Value := 0; + if SystemImageList then begin if Value >= 32 then Value := 32 else Value := 16; end - else - if FBitmap <> nil then - begin + else if FBitmap <> nil then begin if not FBitmap.Empty then - if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then - if Value > FBitmap.Width then - Value := FBitmap.Width; + if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then + if Value > FBitmap.Width then + Value := FBitmap.Width; end; - if FImgWidth = Value then Exit; + if FImgWidth = Value then + Exit; if Count > 0 then - if not( csLoading in ComponentState ) then - begin - I := MessageBox( 0, 'Changing image list width will lead to clearing it. Are ' + - 'You sure You want to change width now?', - 'TKOLImageList.ImgWidth change', MB_YESNO or - MB_DEFBUTTON2 or MB_SETFOREGROUND ); - if I = ID_NO then Exit; - Clear; - end; + if not (csLoading in ComponentState) then begin + I := MessageBox(0, + 'Changing image list width will lead to clearing it. Are ' + 'You sure You want to change width now?', + 'TKOLImageList.ImgWidth change', MB_YESNO or MB_DEFBUTTON2 or MB_SETFOREGROUND); + if I = ID_NO then + Exit; + Clear; + end; FImgWidth := Value; if SystemImageList then FImgHeight := FImgWidth; @@ -1720,10 +1525,11 @@ end; procedure TKOLImageList.SetMasked(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetMasked', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetMasked', 0 + +@@e_signature: end; FMasked := Value; Change; @@ -1732,20 +1538,21 @@ end; procedure TKOLImageList.SetSystemImageList(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetSystemImageList', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetSystemImageList', 0 + +@@e_signature: end; - if Value = FSystemImageList then Exit; + if Value = FSystemImageList then + Exit; FSystemImageList := Value; - if Value then - begin + if Value then begin Clear; - SetImgHeight( ImgHeight ); - SetImgWidth( ImgHeight ); + SetImgHeight(ImgHeight); + SetImgWidth(ImgHeight); end - else + else Clear; Change; end; @@ -1753,129 +1560,134 @@ end; procedure TKOLImageList.SetTransparentColor(const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetTransparentColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetTransparentColor', 0 + +@@e_signature: end; FTransparentColor := Value; AssignBitmapToKOLImgList; Change; end; -procedure TKOLImageList.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -const Booleans: array[ Boolean ] of String = ( 'False', 'True' ); -const ColorsValues: array[ TImageListColors ] of String = ( 'ilcColor', 'ilcColor4', - 'ilcColor8', 'ilcColor16', 'ilcColor24', 'ilcColor32', 'ilcColorDDB', - 'ilcDefault' ); -var RsrcName, RsrcFile, is32: String; +procedure TKOLImageList.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +const + Booleans: array[Boolean] of string = ('False', 'True'); +const + ColorsValues: array[TImageListColors] of string = ('ilcColor', 'ilcColor4', + 'ilcColor8', 'ilcColor16', 'ilcColor24', 'ilcColor32', 'ilcColorDDB', 'ilcDefault'); +var + RsrcName, RsrcFile, is32: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageList.SetupFirst', 0 - @@e_signature: - end; - SL.Add( Prefix + AName + ' := NewImageList( ' + AParent + ' );' ); + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageList.SetupFirst', 0 - GenerateTag( SL, AName, Prefix ); +@@e_signature: + end; + SL.Add(Prefix + AName + ' := NewImageList( ' + AParent + ' );'); + + GenerateTag(SL, AName, Prefix); if SystemImageList then - SL.Add( Prefix + AName + '.LoadSystemIcons( ' + Booleans[ ImgHeight = 16 ] + ' );' ) - else - begin + SL.Add(Prefix + AName + '.LoadSystemIcons( ' + Booleans[ImgHeight = 16] + ' );') + else begin if Colors <> ilcDefault then - SL.Add( Prefix + AName + '.Colors := ' + ColorsValues[ Colors ] + ';' ); - if not Masked then - begin - SL.Add( Prefix + AName + '.Masked := FALSE;' ); + SL.Add(Prefix + AName + '.Colors := ' + ColorsValues[Colors] + ';'); + if not Masked then begin + SL.Add(Prefix + AName + '.Masked := FALSE;'); if BkColor <> clNone then - SL.Add( Prefix + AName + '.BkColor := ' + Color2Str( BkColor ) + - ';' ); + SL.Add(Prefix + AName + '.BkColor := ' + Color2Str(BkColor) + ';'); end; if FImgWidth <> 32 then - SL.Add( Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr( FImgWidth ) + ';' ); + SL.Add(Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr(FImgWidth) + ';'); if FImgHeight <> 32 then - SL.Add( Prefix + ' ' + AName + '.ImgHeight := ' + IntToStr( FImgHeight ) + ';' ); + SL.Add(Prefix + ' ' + AName + '.ImgHeight := ' + IntToStr(FImgHeight) + ';'); end; is32 := ''; - if Force32bit then is32 := '32'; - if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then - begin - if (FImgHeight = 32) and (FImgWidth <> FImgHeight) then - SL.Add( Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr( FImgWidth ) + ';' ); - RsrcName := UpperCase( ParentKOLForm.FormName + '_' + Name ); + if Force32bit then + is32 := '32'; + if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then begin + if (FImgHeight = 32) and (FImgWidth <> FImgHeight) then + SL.Add(Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr(FImgWidth) + ';'); + RsrcName := UpperCase(ParentKOLForm.FormName + '_' + Name); RsrcFile := ParentKOLForm.FormName + '_' + Name; - SL.Add( Prefix + ' {$R ' + RsrcFile + '.res}' ); + SL.Add(Prefix + ' {$R ' + RsrcFile + '.res}'); if Masked then - SL.Add( Prefix + AName + '.AddMasked( LoadBmp' + is32 + '( hInstance, ''' + - RsrcName + ''', ' + - AName + ' ), ' + Color2Str( TransparentColor ) + ' );' ) + SL.Add(Prefix + AName + '.AddMasked( LoadBmp' + is32 + '( hInstance, ''' + + RsrcName + ''', ' + AName + ' ), ' + Color2Str(TransparentColor) + ' );') else - SL.Add( Prefix + AName + '.Add( LoadBmp' + is32 + '( hInstance, ''' + - RsrcName + ''', ' + - AName + ' ), 0 );' ); + SL.Add(Prefix + AName + '.Add( LoadBmp' + is32 + '( hInstance, ''' + + RsrcName + ''', ' + AName + ' ), 0 );'); //Rpt( 'Generating resource: ' + ProjectSourcePath + RsrcFile + '.res' ); - GenerateBitmapResource( FBitmap, RsrcName, RsrcFile, fUpdated, AllowCompression ); + GenerateBitmapResource(FBitmap, RsrcName, RsrcFile, fUpdated, AllowCompression); end; end; { TKOLImageListEditor } procedure TKOLImageListEditor.Edit; -var IL: TImageList; //Invisible; +var + IL: TImageList; //Invisible; {$IFDEF _D6orHigher} - ILCE: IComponentEditor; + ILCE: IComponentEditor; {$ELSE} - ILCE: TComponentEditor; + ILCE: TComponentEditor; {$ENDIF} - ILH: THandle; - KIL: TKOLImageList; - KName: String; - I: Integer; + ILH: THandle; + KIL: TKOLImageList; + KName: string; + I: Integer; //TrColor: TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageListEditor.Edit', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageListEditor.Edit', 0 + +@@e_signature: end; - if Component = nil then Exit; - if not ( Component is TKOLImageList ) then Exit; + if Component = nil then + Exit; + if not (Component is TKOLImageList) then + Exit; KIL := Component as TKOLImageList; - if KIL.SystemImageList then - begin - ShowMessage( 'It is not possible to edit system image list!' ); + if KIL.SystemImageList then begin + ShowMessage('It is not possible to edit system image list!'); Exit; end; - IL := TImageList{Invisible}.Create( {KIL.ParentForm} KIL ); + IL := TImageList{Invisible}.Create( {KIL.ParentForm} KIL); KName := KIL.Name; IL.Name := KName + '_edit'; {IL.Width := KIL.ImgWidth; IL.Height := KIL.ImgHeight;} try - CASE KIL.Colors OF - ilcColor4 : I := ILC_COLOR4; - ilcColor8 : I := ILC_COLOR8; - ilcColor16 : I := ILC_COLOR16; - ilcColor24 : I := ILC_COLOR24; - ilcColor32 : I := ILC_COLOR32; - else I := ILC_COLOR; - END; + case KIL.Colors of + ilcColor4: + I := ILC_COLOR4; + ilcColor8: + I := ILC_COLOR8; + ilcColor16: + I := ILC_COLOR16; + ilcColor24: + I := ILC_COLOR24; + ilcColor32: + I := ILC_COLOR32; + else + I := ILC_COLOR; + end; if KIL.TransparentColor = clNone then - ILH := ImageList_Create( KIL.ImgWidth, KIL.ImgHeight, I, KIL.Count, 1 ) + ILH := ImageList_Create(KIL.ImgWidth, KIL.ImgHeight, I, KIL.Count, 1) else - ILH := ImageList_Create( KIL.ImgWidth, KIL.ImgHeight, I or ILC_MASK, - KIL.Count, 1 ); - if ILH <> 0 then - begin + ILH := ImageList_Create(KIL.ImgWidth, KIL.ImgHeight, I or ILC_MASK, KIL.Count, 1); + if ILH <> 0 then begin if KIL.Masked then - ImageList_AddMasked( ILH, KIL.Bitmap.Handle, Color2RGB( KIL.TransparentColor ) ) + ImageList_AddMasked(ILH, KIL.Bitmap.Handle, Color2RGB(KIL.TransparentColor)) else - ImageList_Add( ILH, KIL.Bitmap.Handle, 0 ); + ImageList_Add(ILH, KIL.Bitmap.Handle, 0); { if KIL.TransparentColor = clNone then ImageList_Add( ILH, KIL.Bitmap.Handle, 0 ) @@ -1899,26 +1711,24 @@ begin IL.Handle := ILH; IL.ShareImages := False; //Rpt( 'Attempt to get component editor' ); - ILCE := GetComponentEditor( IL, Designer ); + ILCE := GetComponentEditor(IL, Designer); if ILCE <> nil then try //Rpt( 'ILCE obtained, try to call editor' ); ILCE.Edit; - Rpt( 'Image list ' + KIL.Name + ' edited.', WHITE ); - if KIL.Bitmap.Empty then - begin + Rpt('Image list ' + KIL.Name + ' edited.', WHITE); + if KIL.Bitmap.Empty then begin KIL.Bitmap := TBitmap.Create; //KIL.Bitmap.PixelFormat := pf24bit; - Rpt( 'Bitmap was empty - created.', WHITE ); + Rpt('Bitmap was empty - created.', WHITE); end; KIL.Bitmap.Height := IL.Height; KIL.Bitmap.Width := IL.Width * IL.Count; KIL.Bitmap.Canvas.Brush.Color := KIL.TransparentColor; - KIL.Bitmap.Canvas.FillRect( Rect( 0, 0, KIL.Bitmap.Width, KIL.Bitmap.Height ) ); + KIL.Bitmap.Canvas.FillRect(Rect(0, 0, KIL.Bitmap.Width, KIL.Bitmap.Height)); for I := 0 to IL.Count - 1 do - IL.Draw( KIL.Bitmap.Canvas, I * IL.Width, 0, I ); - + IL.Draw(KIL.Bitmap.Canvas, I * IL.Width, 0, I); KIL.FCount := IL.Count; KIL.AssignBitmapToKOLImgList; @@ -1937,10 +1747,11 @@ end; procedure TKOLImageListEditor.ExecuteVerb(Index: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageListEditor.ExecuteVerb', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageListEditor.ExecuteVerb', 0 + +@@e_signature: end; Edit; end; @@ -1948,10 +1759,11 @@ end; function TKOLImageListEditor.GetVerb(Index: Integer): string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageListEditor.GetVerb', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageListEditor.GetVerb', 0 + +@@e_signature: end; Result := '&Editor'; end; @@ -1959,10 +1771,11 @@ end; function TKOLImageListEditor.GetVerbCount: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLImageListEditor.GetVerbCount', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLImageListEditor.GetVerbCount', 0 + +@@e_signature: end; Result := 1; end; @@ -1972,141 +1785,38 @@ end; constructor TKOLOpenSaveDialog.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.Create', 0 + +@@e_signature: end; inherited; Options := DefOpenSaveDlgOptions; OpenDialog := TRUE; end; -function TKOLOpenSaveDialog.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLOpenSaveDialog.P_SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); +procedure TKOLOpenSaveDialog.SetDefExtension(const Value: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.P_SetupFirst', 0 - @@e_signature: - end; - (*S := ''; - if Options <> DefOpenSaveDlgOptions then - begin - if OSCreatePrompt in Options then - S := 'OSCreatePrompt'; - if OSExtensionDiffent in Options then - S := S + ', OSExtensionDiffent'; - if OSFileMustExist in Options then - S := S + ', OSFileMustExist'; - if OSHideReadonly in Options then - S := S + ', OSHideReadonly'; - if OSNoChangedir in Options then - S := S + ', OSNoChangedir'; - if OSNoReferenceLinks in Options then - S := S + ', OSNoReferenceLinks'; - if OSAllowMultiSelect in Options then - S := S + ', OSAllowMultiSelect'; - if OSNoNetworkButton in Options then - S := S + ', OSNoNetworkButton'; - if OSNoReadonlyReturn in Options then - S := S + ', OSNoReadonlyReturn'; - if OSOverwritePrompt in Options then - S := S + ', OSOverwritePrompt'; - if OSPathMustExist in Options then - S := S + ', OSPathMustExist'; - if OSReadonly in Options then - S := S + ', OSReadonly'; - if OSNoValidate in Options then - S := S + ', OSNoValidate'; - if OSTemplate in Options then - S := S + ', OSTemplate'; - if OSHook in Options then - S := S + ', OSHook'; - if S <> '' then - if S[ 1 ] = ',' then - S := Trim( Copy( S, 2, MaxInt ) ); - end; - SL.Add( Prefix + AName + ' := NewOpenSaveDialog( ' + StringConstant( 'Title', Title ) - + ', ' + StringConstant( 'InitialDir', InitialDir ) + ', [ ' + S + ' ] );' ); - *) - {P}SL.Add( ' L(' + IntToStr( PWord( @ Options )^ ) + ') ' + - P_StringConstant( 'InitialDir', InitialDir ) + ' C2R ' + - P_StringConstant( 'Title', Title ) + ' C2R ' + - ' NewOpenSaveDialog<3> RESULT DUP LoadSELF AddWord_Store ##T' + - ParentKOLForm.FormName + '.' + Name + - ' L(2) R2CN DelAnsiStr DelAnsiStr' ); - //GenerateTag( SL, AName, Prefix ); - {P}P_GenerateTag( SL, AName, Prefix ); - if Filter <> '' then - //SL.Add( Prefix + ' ' + AName + '.Filter := ' + StringConstant( 'Filter', Filter ) + ';' ); - {P}SL.Add( P_StringConstant( 'Filter', Filter ) + - ' C2 AddByte_Store #TOpenSaveDialog_.FFilter DEL' ); - if not OpenDialog then - //SL.Add( Prefix + ' ' + AName + '.OpenDialog := FALSE;' ); - {P}SL.Add( ' L(0) C1 AddByte_StoreB #TOpenSaveDialog_.FOpenDialog' ); - if DefExtension <> '' then - //SL.Add( Prefix + ' ' + AName + '.DefExtension := ' + StringConstant( 'DefExtension', DefExtension ) + ';' ); - {P}SL.Add( P_StringConstant( 'DefExtension', DefExtension ) + - ' C2 AddByte_Store #TOpenSaveDialog_.FDefExtension DEL' ); - if TemplateName <> '' then - //SL.Add( Prefix + ' ' + AName + '.TemplateName := ' + StringConstant( 'TemplateName', TemplateName ) + ';' ); - {P}SL.Add( P_StringConstant( 'TemplateName', TemplateName ) + - ' C2 AddByte_Store #TOpenSaveDialog_.FTemplateName DEL' ); - if NoPlaceBar then - begin - //SL.Add( '{$IFDEF OpenSaveDialog_Extended}' ); - {P}SL.Add( ' IFDEF(OpenSaveDialog_Extended)' ); - //SL.Add( Prefix + ' ' + AName + '.NoPlaceBar := TRUE;' ); - {P}SL.Add( ' L(1) C1 AddByte_StoreB #TOpenSaveDialog_.NoPlaceBar' ); - //SL.Add( '{$ENDIF}' ); - {P}SL.Add( ' ENDIF' ); - end; + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.SetDefExtension', 0 -end; - -procedure TKOLOpenSaveDialog.P_SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetupLast', 0 - @@e_signature: - end; - //SL.Add( Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;' ); - P_ProvideFakeType( SL, 'type TOpenSaveDialog_ = object(TOpenSaveDialog) end;' ); - {P}SL.Add( ' LoadSELF AddByte_LoadRef #T' + ParentKOLForm.FormName + '.Form' + - ' TControl.GetWindowHandle<1> RESULT ' + - 'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name + - ' AddWord_Store ##TOpenSaveDialog_.fWnd' ); -end; - -procedure TKOLOpenSaveDialog.SetDefExtension(const Value: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetDefExtension', 0 - @@e_signature: +@@e_signature: end; FDefExtension := Value; Change; end; -procedure TKOLOpenSaveDialog.SetFilter(const Value: String); +procedure TKOLOpenSaveDialog.SetFilter(const Value: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetFilter', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.SetFilter', 0 + +@@e_signature: end; FFilter := Value; Change; @@ -2115,10 +1825,11 @@ end; procedure TKOLOpenSaveDialog.SetFilterIndex(const Value: Integer); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetFilterIndex', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.SetFilterIndex', 0 + +@@e_signature: end; FFilterIndex := Value; if FFilterIndex < 0 then @@ -2126,13 +1837,14 @@ begin Change; end; -procedure TKOLOpenSaveDialog.SetInitialDir(const Value: String); +procedure TKOLOpenSaveDialog.SetInitialDir(const Value: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetInitialDir', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.SetInitialDir', 0 + +@@e_signature: end; FInitialDir := Value; Change; @@ -2147,10 +1859,11 @@ end; procedure TKOLOpenSaveDialog.SetOpenDialog(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetOpenDialog', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.SetOpenDialog', 0 + +@@e_signature: end; FOpenDialog := Value; Change; @@ -2159,53 +1872,54 @@ end; procedure TKOLOpenSaveDialog.SetOptions(const Value: TOpenSaveOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.SetOptions', 0 + +@@e_signature: end; FOptions := Value; Change; end; -procedure TKOLOpenSaveDialog.SetTemplateName(const Value: String); +procedure TKOLOpenSaveDialog.SetTemplateName(const Value: string); begin FTemplateName := Value; Change; end; -procedure TKOLOpenSaveDialog.SetTitle(const Value: String); +procedure TKOLOpenSaveDialog.SetTitle(const Value: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetTitle', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.SetTitle', 0 + +@@e_signature: end; FTitle := Value; Change; end; -procedure TKOLOpenSaveDialog.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); +procedure TKOLOpenSaveDialog.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); var {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} -S: String; + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.SetupFirst', 0 + +@@e_signature: end; S := ''; - if Options <> DefOpenSaveDlgOptions then - begin + if Options <> DefOpenSaveDlgOptions then begin if OSCreatePrompt in Options then S := 'OSCreatePrompt'; if OSExtensionDiffent in Options then @@ -2237,73 +1951,76 @@ begin if OSHook in Options then S := S + ', OSHook'; if S <> '' then - if S[ 1 ] = ',' then - S := Trim( Copy( S, 2, MaxInt ) ); + if S[1] = ',' then + S := Trim(Copy(S, 2, MaxInt)); end; - if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - C := StringConstant( 'Title', Title ) + if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then + C := StringConstant('Title', Title) else - C := ''''''; + C := ''''''; {$IFDEF _D2009orHigher} - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+IntToStr(ord(C[i])); - C := C2; + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + IntToStr(ord(C[i])); + C := C2; {$ENDIF} - if C = '' then C := ''''''; - SL.Add( Prefix + AName + ' := NewOpenSaveDialog( ' + C - + ', ' + StringConstant( 'InitialDir', InitialDir ) + ', [ ' + S + ' ] );' ); + if C = '' then + C := ''''''; + SL.Add(Prefix + AName + ' := NewOpenSaveDialog( ' + C + ', ' + StringConstant('InitialDir', + InitialDir) + ', [ ' + S + ' ] );'); - GenerateTag( SL, AName, Prefix ); + GenerateTag(SL, AName, Prefix); if (Filter <> '') and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - SL.Add( Prefix + ' ' + AName + '.Filter := ' + StringConstant( 'Filter', Filter ) + ';' ); + SL.Add(Prefix + ' ' + AName + '.Filter := ' + StringConstant('Filter', Filter) + ';'); if not OpenDialog then - SL.Add( Prefix + ' ' + AName + '.OpenDialog := FALSE;' ); + SL.Add(Prefix + ' ' + AName + '.OpenDialog := FALSE;'); if DefExtension <> '' then - SL.Add( Prefix + ' ' + AName + '.DefExtension := ' + StringConstant( 'DefExtension', DefExtension ) + ';' ); + SL.Add(Prefix + ' ' + AName + '.DefExtension := ' + StringConstant('DefExtension', DefExtension) + ';'); if TemplateName <> '' then - SL.Add( Prefix + ' ' + AName + '.TemplateName := ' + StringConstant( 'TemplateName', TemplateName ) + ';' ); - if NoPlaceBar then - begin - SL.Add( '{$IFDEF OpenSaveDialog_Extended}' ); - SL.Add( Prefix + ' ' + AName + '.NoPlaceBar := TRUE;' ); - SL.Add( '{$ENDIF}' ); + SL.Add(Prefix + ' ' + AName + '.TemplateName := ' + StringConstant('TemplateName', TemplateName) + ';'); + if NoPlaceBar then begin + SL.Add('{$IFDEF OpenSaveDialog_Extended}'); + SL.Add(Prefix + ' ' + AName + '.NoPlaceBar := TRUE;'); + SL.Add('{$ENDIF}'); end; end; { TKOLFileFilter } -procedure TKOLOpenSaveDialog.SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); +procedure TKOLOpenSaveDialog.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenSaveDialog.SetupLast', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenSaveDialog.SetupLast', 0 + +@@e_signature: end; - SL.Add( Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;' ); + SL.Add(Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;'); end; { TKOLFileFilter } procedure TKOLFileFilter.Edit; -var Dlg: TfmFileFilterEditor; +var + Dlg: TfmFileFilterEditor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLFileFilter.Edit', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLFileFilter.Edit', 0 + +@@e_signature: end; - if GetComponent( 0 ) = nil then Exit; - Dlg := TfmFileFilterEditor.Create( Application ); - Dlg.Caption := (GetComponent( 0 ) as TComponent).Name + '.Filter'; + if GetComponent(0) = nil then + Exit; + Dlg := TfmFileFilterEditor.Create(Application); + Dlg.Caption := (GetComponent(0) as TComponent).Name + '.Filter'; Dlg.Filter := GetStrValue; Dlg.ShowModal; - if Dlg.ModalResult = mrOK then - begin - SetStrValue( Dlg.Filter ); + if Dlg.ModalResult = mrOK then begin + SetStrValue(Dlg.Filter); end; Dlg.Free; end; @@ -2311,176 +2028,49 @@ end; function TKOLFileFilter.GetAttributes: TPropertyAttributes; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLFileFilter.GetAttributes', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLFileFilter.GetAttributes', 0 + +@@e_signature: end; - Result := [ paDialog, paReadOnly ]; + Result := [paDialog, paReadOnly]; end; { TKOLOpenDirDialog } -function TKOLOpenDirDialog.AdditionalUnits: String; +function TKOLOpenDirDialog.AdditionalUnits: string; begin Result := ''; if AltDialog then Result := ', KOLDirDlgEx'; end; -procedure TKOLOpenDirDialog.AssignEvents(SL: TStringList; - const AName: String); +procedure TKOLOpenDirDialog.AssignEvents(SL: TStringList; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.AssignEvents', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenDirDialog.AssignEvents', 0 + +@@e_signature: end; inherited; if not AltDialog then - DoAssignEvents( SL, AName, - [ 'OnSelChanged' ], - [ @ OnSelChanged ] ); + DoAssignEvents(SL, AName, ['OnSelChanged'], [@OnSelChanged]); end; constructor TKOLOpenDirDialog.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenDirDialog.Create', 0 + +@@e_signature: end; inherited; - Options := [ odOnlySystemDirs ]; -end; - -function TKOLOpenDirDialog.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLOpenDirDialog.P_AssignEvents(SL: TStringList; - const AName: String; CheckOnly: Boolean): Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.P_AssignEvents', 0 - @@e_signature: - end; - Result := inherited P_AssignEvents( SL, AName, CheckOnly ); - if Result and CheckOnly then Exit; - if AltDialog then Exit; - - if P_DoAssignEvents( SL, AName, - [ 'OnSelChanged' ], - [ @ OnSelChanged ], - [ TRUE ], CheckOnly ) then Exit; - Result := FALSE; -end; - -procedure TKOLOpenDirDialog.P_SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -//var S: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.P_SetupFirst', 0 - @@e_signature: - end; - {if Options <> [ odOnlySystemDirs ] then - begin - S := ''; - if odBrowseForComputer in Options then - S := 'odBrowseForComputer'; - if odBrowseForPrinter in Options then - S := S + ', odBrowseForPrinter'; - if odDontGoBelowDomain in Options then - S := S + ', odDontGoBelowDomain'; - if odOnlyFileSystemAncestors in Options then - S := S + ', odOnlyFileSystemAncestors'; - if odOnlySystemDirs in Options then - S := S + ', odOnlySystemDirs'; - if odStatusText in Options then - S := S + ', odStatusText'; - if odBrowseIncludeFiles in Options then - S := S + ', odBrowseIncludeFiles'; - if odEditBox in Options then - S := S + ', odEditBox'; - if odNewDialogStyle in Options then - S := S + ', odNewDialogStyle'; - if S <> '' then - if S[ 1 ] = ',' then - S := Trim( Copy( S, 2, MaxInt ) ); - end; - if AltDialog then - begin - SL.Add( Prefix + AName + ' := NewOpenDirDialogEx;' ); - if Title <> '' then - SL.Add( Prefix + AName + '.Title := ' + StringConstant( 'Title', Title ) + - ';' ); - end - else - SL.Add( Prefix + AName + ' := NewOpenDirDialog( ' + StringConstant( 'Title', Title ) + - ', [ ' + S + ' ] );' );} - if AltDialog then - begin - {P}SL.Add( ' NewOpenDirDialogEx<0> RESULT DUP LoadSELF AddWord_Store ##T' + - ParentKOLForm.FormName + '.' + Name ); - if Title <> '' then - {P}SL.Add( P_StringConstant( 'Title', Title ) + - ' C2 AddByte_Store #TOpenDirDialogEx_.Title DEL' ); - end - else - begin - {P}SL.Add( ' L(' + IntToStr( PByte( @ Options )^ ) + ') ' + - P_StringConstant( 'Title', Title ) + ' C2R' + - ' NewOpenDirDialog<2> RESULT DUP LoadSELF AddWord_Store ##T' + - ParentKOLForm.FormName + '.' + Name + - ' R2C DelAnsiStr' ); - end; - - //GenerateTag( SL, AName, Prefix ); - {P}P_GenerateTag( SL, AName, Prefix ); - if InitialPath <> '' then - begin - //SL.Add( Prefix + ' ' + AName + '.InitialPath := ' + StringConstant( 'InitialPath', InitialPath ) - // + ';' ); - {P}SL.Add( P_StringConstant( 'InitialPath', InitialPath ) + - ' C2 ' ); - if AltDialog then - {P}SL.Add( ' TOpenDirDialogEx_.SetPath<2> DelAnsiStr' ) - else - {P}SL.Add( ' TOpenDirDialog_.SetInitialPath<2> DelAnsiStr' ); - end; - if CenterOnScreen and not AltDialog then - //SL.Add( Prefix + ' ' + AName + '.CenterOnScreen := TRUE;' ); - {P}SL.Add( ' L(1) C1 TOpenDirDialog_.SetCenterOnScreen<2>' ); -end; - -procedure TKOLOpenDirDialog.P_SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.SetupLast', 0 - @@e_signature: - end; - //SL.Add( Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;' ); - if AltDialog then - P_ProvideFakeType( SL, 'type TOpenDirDialogEx_ = object(TOpenDirDialogEx) end;' ) - else - begin - P_ProvideFakeType( SL, 'type TOpenDirDialog_ = object(TOpenDirDialog) end;' ); - {P}SL.Add( ' LoadSELF AddByte_LoadRef #T' + ParentKOLForm.formName + '.Form' ); - {P}SL.Add( ' TControl.GetWindowHandle<1> RESULT ' + - 'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name + - ' AddWord_Store ##TOpenDirDialog_.fWnd' ); - end; + Options := [odOnlySystemDirs]; end; procedure TKOLOpenDirDialog.SetAltDialog(const Value: Boolean); @@ -2492,22 +2082,24 @@ end; procedure TKOLOpenDirDialog.SetCenterOnScreen(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.SetCenterOnScreen', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenDirDialog.SetCenterOnScreen', 0 + +@@e_signature: end; FCenterOnScreen := Value; Change; end; -procedure TKOLOpenDirDialog.SetInitialPath(const Value: String); +procedure TKOLOpenDirDialog.SetInitialPath(const Value: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.SetInitialPath', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenDirDialog.SetInitialPath', 0 + +@@e_signature: end; FInitialPath := Value; Change; @@ -2516,10 +2108,11 @@ end; procedure TKOLOpenDirDialog.SetOnSelChanged(const Value: TOnODSelChange); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.SetOnSelChanged', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenDirDialog.SetOnSelChanged', 0 + +@@e_signature: end; FOnSelChanged := Value; Change; @@ -2528,46 +2121,47 @@ end; procedure TKOLOpenDirDialog.SetOptions(const Value: TOpenDirOptions); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.SetOptions', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenDirDialog.SetOptions', 0 + +@@e_signature: end; FOptions := Value; Change; end; -procedure TKOLOpenDirDialog.SetTitle(const Value: String); +procedure TKOLOpenDirDialog.SetTitle(const Value: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.SetTitle', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenDirDialog.SetTitle', 0 + +@@e_signature: end; FTitle := Value; Change; end; -procedure TKOLOpenDirDialog.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); +procedure TKOLOpenDirDialog.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); var {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} - S: String; + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenDirDialog.SetupFirst', 0 + +@@e_signature: end; - if Options <> [ odOnlySystemDirs ] then - begin + if Options <> [odOnlySystemDirs] then begin S := ''; if odBrowseForComputer in Options then S := 'odBrowseForComputer'; @@ -2588,61 +2182,62 @@ begin if odNewDialogStyle in Options then S := S + ', odNewDialogStyle'; if S <> '' then - if S[ 1 ] = ',' then - S := Trim( Copy( S, 2, MaxInt ) ); + if S[1] = ',' then + S := Trim(Copy(S, 2, MaxInt)); end; - if AltDialog then - begin - SL.Add( Prefix + AName + ' := NewOpenDirDialogEx;' ); - if (Title <> '') and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - begin - C := StringConstant( 'Title', Title ); + if AltDialog then begin + SL.Add(Prefix + AName + ' := NewOpenDirDialogEx;'); + if (Title <> '') and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then begin + C := StringConstant('Title', Title); {$IFDEF _D2009orHigher} - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+IntToStr(ord(C[i])); - C := C2; + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + IntToStr(ord(C[i])); + C := C2; {$ENDIF} - if C = '' then C := ''''''; - SL.Add( Prefix + AName + '.Title := ' + C + ';' ); - end; - end else - begin - if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then - C := StringConstant( 'Title', Title ) - else - C := ''''''; + if C = '' then + C := ''''''; + SL.Add(Prefix + AName + '.Title := ' + C + ';'); + end; + end + else begin + if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then + C := StringConstant('Title', Title) + else + C := ''''''; {$IFDEF _D2009orHigher} - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+IntToStr(ord(C[i])); - C := C2; + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + IntToStr(ord(C[i])); + C := C2; {$ENDIF} - if C = '' then C := ''''''; - SL.Add( Prefix + AName + ' := NewOpenDirDialog( ' + C + ', [ ' + S + ' ] );' ); + if C = '' then + C := ''''''; + SL.Add(Prefix + AName + ' := NewOpenDirDialog( ' + C + ', [ ' + S + ' ] );'); end; - GenerateTag( SL, AName, Prefix ); + GenerateTag(SL, AName, Prefix); if InitialPath <> '' then - SL.Add( Prefix + ' ' + AName + '.InitialPath := ' + StringConstant( 'InitialPath', InitialPath ) - + ';' ); + SL.Add(Prefix + ' ' + AName + '.InitialPath := ' + StringConstant('InitialPath', InitialPath) + ';'); if CenterOnScreen and not AltDialog then - SL.Add( Prefix + ' ' + AName + '.CenterOnScreen := TRUE;' ); + SL.Add(Prefix + ' ' + AName + '.CenterOnScreen := TRUE;'); //AssignEvents( SL, AName ); end; -procedure TKOLOpenDirDialog.SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); +procedure TKOLOpenDirDialog.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLOpenDirDialog.SetupLast', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLOpenDirDialog.SetupLast', 0 + +@@e_signature: end; if not AltDialog then - SL.Add( Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;' ); + SL.Add(Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;'); end; -function TKOLOpenDirDialog.TypeName: String; +function TKOLOpenDirDialog.TypeName: string; begin Result := inherited TypeName; if AltDialog then @@ -2652,111 +2247,80 @@ end; { TKOLColorDialog } constructor TKOLColorDialog.Create(AOwner: TComponent); -var I: Integer; +var + I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLColorDialog.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLColorDialog.Create', 0 + +@@e_signature: end; inherited; - for I := 1 to 16 do - FCustomColors[ I ] := clWhite; -end; - -function TKOLColorDialog.GetCustomColor( const Index: Integer ): TColor; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLColorDialog.GetCustomColor', 0 - @@e_signature: - end; - Result := FCustomColors[ Index ]; -end; - -function TKOLColorDialog.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLColorDialog.P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); -var I: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLColorDialog.P_SetupFirst', 0 - @@e_signature: - end; - //SL.Add( Prefix + AName + ' := NewColorDialog( ' + ColorDialogOptions[ ColorCustomOption ] + - // ' );' ); - {P}SL.Add( ' L(' + IntToStr( Integer( ColorCustomOption ) ) + ')' + - ' NewColorDialog<1> RESULT' + - ' DUP LoadSELF AddWord_Store ##T' + ParentKOLForm.FormName + - '.' + Name ); - //GenerateTag( SL, AName, Prefix ); - P_GenerateTag( SL, AName, Prefix ); for I := 1 to 16 do - begin - if FCustomColors[ I ] <> clWhite then - //SL.Add( Prefix + ' ' + AName + '.CustomColors[ ' + IntToStr( I ) + ' ] := ' + - // Color2Str( FCustomColors[ I ] ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( FCustomColors[ I ] ) + ')' + - ' C2 L($' + IntToHex( I*4, 6 ) + ') AddWord_Store ##TColorDialog.' + - 'CustomColors' ); - end; + FCustomColors[I] := clWhite; end; -procedure TKOLColorDialog.SetColorCustomOption( - const Value: TColorCustomOption); +function TKOLColorDialog.GetCustomColor(const Index: Integer): TColor; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLColorDialog.SetColorCustomOption', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLColorDialog.GetCustomColor', 0 + +@@e_signature: + end; + Result := FCustomColors[Index]; +end; + +procedure TKOLColorDialog.SetColorCustomOption(const Value: TColorCustomOption); +begin + asm + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLColorDialog.SetColorCustomOption', 0 + +@@e_signature: end; FColorCustomOption := Value; Change; end; -procedure TKOLColorDialog.SetCustomColor(const Index: Integer; - const Value: TColor); +procedure TKOLColorDialog.SetCustomColor(const Index: Integer; const Value: TColor); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLColorDialog.SetCustomColor', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLColorDialog.SetCustomColor', 0 + +@@e_signature: end; - FCustomColors[ Index ] := Value; + FCustomColors[Index] := Value; Change; end; -procedure TKOLColorDialog.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); +procedure TKOLColorDialog.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); const - ColorDialogOptions: array[ TColorCustomOption ] of String = ( 'ccoFullOpen', - 'ccoShortOpen', 'ccoPreventFullOpen' ); -var I: Integer; + ColorDialogOptions: array[TColorCustomOption] of string = ('ccoFullOpen', + 'ccoShortOpen', 'ccoPreventFullOpen'); +var + I: Integer; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLColorDialog.SetupFirst', 0 - @@e_signature: - end; - SL.Add( Prefix + AName + ' := NewColorDialog( ' + ColorDialogOptions[ ColorCustomOption ] + - ' );' ); + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLColorDialog.SetupFirst', 0 - GenerateTag( SL, AName, Prefix ); - for I := 1 to 16 do - begin - if FCustomColors[ I ] <> clWhite then - SL.Add( Prefix + ' ' + AName + '.CustomColors[ ' + IntToStr( I ) + ' ] := ' + - Color2Str( FCustomColors[ I ] ) + ';' ); +@@e_signature: + end; + SL.Add(Prefix + AName + ' := NewColorDialog( ' + ColorDialogOptions[ColorCustomOption] + ' );'); + + GenerateTag(SL, AName, Prefix); + for I := 1 to 16 do begin + if FCustomColors[I] <> clWhite then + SL.Add(Prefix + ' ' + AName + '.CustomColors[ ' + IntToStr(I) + ' ] := ' + + Color2Str(FCustomColors[I]) + ';'); end; end; @@ -2774,27 +2338,26 @@ begin inherited; end; -procedure TKOLFontDialog.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +procedure TKOLFontDialog.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); const - OpenOption: array [KOL.TFontDialogOption] of String = - ('fdAnsiOnly', 'fdTrueTypeOnly', 'fdEffects', 'fdFixedPitchOnly', - 'fdForceFontExist', 'fdNoFaceSel', 'fdNoOEMFonts', 'fdNoSimulations', - 'fdNoSizeSel', 'fdNoStyleSel', 'fdNoVectorFonts', {'fdShowHelp',} - 'fdWysiwyg', 'fdLimitSize', 'fdScalableOnly', {'fdApplyButton',} 'fdInitFont'); - Device2Str: array[KOL.TFontDialogDevice] of String = ('fdBoth', 'fdScreen', 'fdPrinter'); - + OpenOption: array[KOL.TFontDialogOption] of string = ('fdAnsiOnly', + 'fdTrueTypeOnly', 'fdEffects', 'fdFixedPitchOnly', 'fdForceFontExist', + 'fdNoFaceSel', 'fdNoOEMFonts', 'fdNoSimulations', 'fdNoSizeSel', + 'fdNoStyleSel', 'fdNoVectorFonts', {'fdShowHelp',} + 'fdWysiwyg', 'fdLimitSize', 'fdScalableOnly', {'fdApplyButton',} 'fdInitFont'); + Device2Str: array[KOL.TFontDialogDevice] of string = ('fdBoth', 'fdScreen', 'fdPrinter'); var - PfxName: String; - SOpts: String; - opt: KOL.TFontDialogOption; + PfxName: string; + SOpts: string; + opt: KOL.TFontDialogOption; begin PfxName := Prefix + AName; SL.Add(''); SL.Add(PfxName + ' := NewFontDialog(' + AParent + ');'); - SL.Add(PfxName + '.MinFontSize := ' + Int2Str(FMinFontSize) + ';'); - SL.Add(PfxName + '.MaxFontSize := ' + Int2Str(FMaxFontSize) + ';'); - SL.Add(PfxName + '.Device := ' + Device2Str[FDevice] + ';'); + SL.Add(PfxName + '.MinFontSize := ' + Int2Str(FMinFontSize) + ';'); + SL.Add(PfxName + '.MaxFontSize := ' + Int2Str(FMaxFontSize) + ';'); + SL.Add(PfxName + '.Device := ' + Device2Str[FDevice] + ';'); SOpts := ''; for opt := Low(opt) to High(opt) do begin @@ -2807,19 +2370,19 @@ begin FFont.GenerateCode(SL, AName, nil); end; -procedure TKOLFontDialog.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLFontDialog.AssignEvents(SL: TStringList; const AName: string); begin inherited; DoAssignEvents(SL, AName, ['OnHelp', 'OnApply'], [@OnHelp, @OnApply]); end; -procedure TKOLFontDialog.SetMinFontSize(const Value:Integer); +procedure TKOLFontDialog.SetMinFontSize(const Value: Integer); begin FMinFontSize := Value; Change; end; -procedure TKOLFontDialog.SetMaxFontSize(const Value:Integer); +procedure TKOLFontDialog.SetMaxFontSize(const Value: Integer); begin FMaxFontSize := Value; Change; @@ -2857,25 +2420,27 @@ end; { TKOLTrayIcon } -procedure TKOLTrayIcon.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLTrayIcon.AssignEvents(SL: TStringList; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.AssignEvents', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.AssignEvents', 0 + +@@e_signature: end; inherited; - DoAssignEvents( SL, AName, [ 'OnMouse' ], [ @ OnMouse ] ); + DoAssignEvents(SL, AName, ['OnMouse'], [@OnMouse]); end; constructor TKOLTrayIcon.Create(AOwner: TComponent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.Create', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.Create', 0 + +@@e_signature: end; inherited; FIcon := TIcon.Create; @@ -2886,116 +2451,24 @@ end; destructor TKOLTrayIcon.Destroy; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.Destroy', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.Destroy', 0 + +@@e_signature: end; FIcon.Free; inherited; end; -function TKOLTrayIcon.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLTrayIcon.P_AssignEvents(SL: TStringList; const AName: String; - CheckOnly: Boolean): Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.P_AssignEvents', 0 - @@e_signature: - end; - Result := inherited P_AssignEvents( SL, AName, CheckOnly ); - if Result and CheckOnly then Exit; - if P_DoAssignEvents( SL, AName, [ 'OnMouse' ], [ @OnMouse ], [ FALSE ], CheckOnly ) - and CheckOnly then Exit; - Result := FALSE; -end; - -procedure TKOLTrayIcon.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var RsrcName, RsrcFile: KOLString; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.SetupFirst', 0 - @@e_signature: - end; - if not Icon.Empty then - begin - RsrcName := UpperCase( 'z' + ParentKOLForm.FormName + '_' + Name ); - RsrcFile := ParentKOLForm.FormName + '_' + Name; - GenerateIconResource( Icon, RsrcName, RsrcFile, fUpdated ); - SL.Add( Prefix + ' {$R ' + RsrcFile + '.RES}' ); - end; - if Icon.Empty or not Active then - //SL.Add( Prefix + AName + ' := NewTrayIcon( Applet, 0 );' ) - {P}SL.Add( ' L(0) LoadVar ####Applet NewTrayIcon<2> RESULT' + - ' DUP LoadSELF AddWord_Store ##T' + ParentKOLForm.FormName + - '.' + Name ) - else - //SL.Add( Prefix + AName + ' := NewTrayIcon( Applet, LoadIcon( hInstance, ' + - // String2Pascal( RsrcName, ' + ' ) + ' ) );' ); - {P}SL.Add( ' LoadStr ''' + RsrcName + ''' #0 LoadHInstance' + - ' LoadIcon<0> RESULT LoadVar ####Applet NewTrayIcon<2> RESULT' + - ' DUP LoadSELF AddWord_Store ##T' + ParentKOLForm.FormName + - '.' + Name ); - if not Active then - begin - //SL.Add( Prefix + AName + '.Active := FALSE;' ); - {P}SL.Add( ' L(0) C1 TTrayIcon_.SetActive<2>' ); - if not Icon.Empty then - //SL.Add( Prefix + AName + '.Icon := LoadIcon( hInstance, ' + - // String2Pascal( RsrcName, ' + ' ) + ' );' ) - {P}SL.Add( ' LoadStr ''' + RsrcName + ''' #0 LoadHInstance' + - ' LoadIcon<0> RESULT' + - ' C1 TTrayIcon_.SetIcon<2>' ); - end; - if NoAutoDeactivate then - //SL.Add( Prefix + AName + '.NoAutoDeactivate := TRUE;' ); - {P}SL.Add( ' L(1) C1 AddByte_StoreB #TTrayIcon_.FNoAutoDeactivate' ); - if Tooltip <> '' then - //SL.Add( Prefix + AName + '.Tooltip := ' + StringConstant( 'Tooltip', Tooltip ) + ';' ); - {P}SL.Add( P_StringConstant( 'Tooltip', Tooltip ) + - ' C2 TTrayIcon_.SetTooltip<2> DelAnsiStr' ); - if AutoRecreate then - //SL.Add( Prefix + AName + '.AutoRecreate := TRUE;' ); - {P}SL.Add( ' L(1) C1 TTrayIcon_.SetAutoRecreate<2>' ); - //GenerateTag( SL, AName, Prefix ); - P_GenerateTag( SL, AName, Prefix ); -end; - -procedure TKOLTrayIcon.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.P_SetupLast', 0 - @@e_signature: - end; - if Active then - //SL.Add( Prefix + AName + '.Active := TRUE;' ); - begin - P_ProvideFakeType( SL, 'type TTrayIcon_ = object(TTrayIcon) end;' ); - {P}SL.Add( ' L(1) ' + - 'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name + - ' TTrayIcon_.SetActive<2>' ); - end; -end; - procedure TKOLTrayIcon.SetActive(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.SetActive', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.SetActive', 0 + +@@e_signature: end; FActive := Value; Change; @@ -3004,10 +2477,11 @@ end; procedure TKOLTrayIcon.SetAutoRecreate(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.SetAutoRecreate', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.SetAutoRecreate', 0 + +@@e_signature: end; FAutoRecreate := Value; Change; @@ -3016,15 +2490,15 @@ end; procedure TKOLTrayIcon.SetIcon(const Value: TIcon); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.SetIcon', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.SetIcon', 0 + +@@e_signature: end; if Value <> nil then - FIcon.Assign( Value ) - else - begin + FIcon.Assign(Value) + else begin FIcon.Free; FIcon := TIcon.Create; end; @@ -3040,116 +2514,117 @@ end; procedure TKOLTrayIcon.SetOnMouse(const Value: TOnTrayIconMouse); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.SetOnMouse', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.SetOnMouse', 0 + +@@e_signature: end; FOnMouse := Value; Change; end; -procedure TKOLTrayIcon.SetTooltip(const Value: String); +procedure TKOLTrayIcon.SetTooltip(const Value: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.SetTooltip', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.SetTooltip', 0 + +@@e_signature: end; FTooltip := Value; - if Length( FTooltip ) > 64 then - FTooltip := Copy( FTooltip, 1, 64 ); // 64 characters maximum allowed + if Length(FTooltip) > 64 then + FTooltip := Copy(FTooltip, 1, 64); // 64 characters maximum allowed Change; end; -procedure TKOLTrayIcon.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); +procedure TKOLTrayIcon.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); var {$IFDEF _D2009orHigher} C, C2: WideString; - i : integer; + i: integer; {$ELSE} C: string; {$ENDIF} -RsrcName, RsrcFile: String; + RsrcName, RsrcFile: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.SetupFirst', 0 + +@@e_signature: end; - if not Icon.Empty then - begin - RsrcName := UpperCase( 'z' + ParentKOLForm.FormName + '_' + Name ); + if not Icon.Empty then begin + RsrcName := UpperCase('z' + ParentKOLForm.FormName + '_' + Name); RsrcFile := ParentKOLForm.FormName + '_' + Name; - GenerateIconResource( Icon, RsrcName, RsrcFile, fUpdated ); - SL.Add( Prefix + ' {$R ' + RsrcFile + '.RES}' ); + GenerateIconResource(Icon, RsrcName, RsrcFile, fUpdated); + SL.Add(Prefix + ' {$R ' + RsrcFile + '.RES}'); end; if Icon.Empty or not Active then - SL.Add( Prefix + AName + ' := NewTrayIcon( Applet, 0 );' ) + SL.Add(Prefix + AName + ' := NewTrayIcon( Applet, 0 );') else - SL.Add( Prefix + AName + ' := NewTrayIcon( Applet, LoadIcon( hInstance, ' + - String2Pascal( RsrcName, ' + ' ) + ' ) );' ); + SL.Add(Prefix + AName + ' := NewTrayIcon( Applet, LoadIcon( hInstance, ' + + String2Pascal(RsrcName, ' + ') + ' ) );'); - if not Active then - begin - SL.Add( Prefix + AName + '.Active := FALSE;' ); + if not Active then begin + SL.Add(Prefix + AName + '.Active := FALSE;'); if not Icon.Empty then - SL.Add( Prefix + AName + '.Icon := LoadIcon( hInstance, ' + - String2Pascal( RsrcName, ' + ' ) + ' );' ) + SL.Add(Prefix + AName + '.Icon := LoadIcon( hInstance, ' + String2Pascal(RsrcName, ' + ') + ' );') end; if NoAutoDeactivate then - SL.Add( Prefix + AName + '.NoAutoDeactivate := TRUE;' ); - if Tooltip <> '' then - begin - C := StringConstant( 'Tooltip', Tooltip ); + SL.Add(Prefix + AName + '.NoAutoDeactivate := TRUE;'); + if Tooltip <> '' then begin + C := StringConstant('Tooltip', Tooltip); {$IFDEF _D2009orHigher} - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+IntToStr(ord(C[i])); - C := C2; + C2 := ''; + for i := 2 to Length(C) - 1 do + C2 := C2 + '#' + IntToStr(ord(C[i])); + C := C2; {$ENDIF} - if C = '' then C := ''''''; - SL.Add( Prefix + AName + '.Tooltip := ' + C + ';' ); - end; + if C = '' then + C := ''''''; + SL.Add(Prefix + AName + '.Tooltip := ' + C + ';'); + end; if AutoRecreate then - SL.Add( Prefix + AName + '.AutoRecreate := TRUE;' ); - GenerateTag( SL, AName, Prefix ); + SL.Add(Prefix + AName + '.AutoRecreate := TRUE;'); + GenerateTag(SL, AName, Prefix); end; -procedure TKOLTrayIcon.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); +procedure TKOLTrayIcon.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLTrayIcon.SetupLast', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLTrayIcon.SetupLast', 0 + +@@e_signature: end; if Active then - SL.Add( Prefix + AName + '.Active := TRUE;' ); + SL.Add(Prefix + AName + '.Active := TRUE;'); end; { TKOLThread } -procedure TKOLThread.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLThread.AssignEvents(SL: TStringList; const AName: string); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.AssignEvents', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.AssignEvents', 0 + +@@e_signature: end; // end; -function TKOLThread.BestEventName: String; +function TKOLThread.BestEventName: string; begin Result := 'OnExecute'; end; -constructor TKOLThread.Create( AOwner: TComponent ); +constructor TKOLThread.Create(AOwner: TComponent); begin inherited; FPriorityBoost := TRUE; @@ -3158,125 +2633,23 @@ end; function TKOLThread.NotAutoFree: Boolean; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.NotAutoFree', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.NotAutoFree', 0 + +@@e_signature: end; Result := F_AutoFree; end; -function TKOLThread.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - -function TKOLThread.P_AssignEvents(SL: TStringList; const AName: String; - CheckOnly: Boolean): Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.P_AssignEvents', 0 - @@e_signature: - end; - Result := FALSE; -end; - -procedure TKOLThread.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -//var S: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.P_SetupFirst', 0 - @@e_signature: - end; - P_ProvideFakeType( SL, 'type TThread_ = object(TThread) end;' ); - if startSuspended or (@OnSuspend <> nil) or - (@OnResume <> nil) or (@OnDestroy <> nil) or - AutoFree or (PriorityClass <> pcNormal) or (ThreadPriority <> tpNormal) - or (Tag <> 0) then - begin - if AutoFree then - //SL.Add( Prefix + AName + ' := NewThreadAutoFree( nil );' ) - {P}SL.Add( ' L(0) NewThreadAutoFree<1> RESULT DUP LoadSELF AddWord_Store ##T' + - ParentKOLForm.formName + '.' + Name ) - else - //SL.Add( Prefix + AName + ' := NewThread;' ); - {P}SL.Add( ' NewThread<0> RESULT DUP LoadSELF AddWord_Store ##T' + - ParentKOLForm.formName + '.' + Name ); - P_SetupName( SL ); - if @OnExecute <> nil then - //SL.Add( Prefix + AName + '.OnExecute := Result.' + - // ParentForm.MethodName( @OnExecute ) + ';' ); - {P}SL.Add( ' Load4 ####T' + ParentKOLForm.FormName + - '.' + ParentForm.MethodName( @ OnExecute ) + - ' C1 AddByte_Store #TThread_.FOnExecute.TMethod.Code' + - ' LoadSELF C1 AddByte_Store #TThread_.FOnExecute.TMethod.Data' ); - if @OnSuspend <> nil then - //SL.Add( Prefix + AName + '.OnSuspend := Result.' + - // ParentForm.MethodName( @OnSuspend ) + ';' ); - {P}SL.Add( ' Load4 ####T' + ParentKOLForm.formName + - '.' + ParentForm.MethodName( @OnSuspend ) + - ' C1 AddByte_Store #TThread_.FOnSuspend.TMethod.Code' + - ' LoadSELF C1 AddByte_Store #TThread_.FOnSuspend.TMethod.Data' ); - if @OnResume <> nil then - //SL.Add( Prefix + AName + '.OnResume := Result.' + - // ParentForm.MethodName( @OnResume ) + ';' ); - {P}SL.Add( ' Load4 ####T' + ParentKOLForm.FormName + - '.' + ParentForm.MethodName( @OnResume ) + - ' C1 AddByte_Store #TThread_.FOnResume.TMethod.Code' + - ' LoadSELF C1 AddByte_Store #TThread_.FOnResume.TMethod.Data' ); - if @OnDestroy <> nil then - //SL.Add( Prefix + AName + '.OnDestroy := Result.' + - // ParentForm.MethodName( @OnDestroy ) + ';' ); - {P}SL.Add( ' Load4 ####T' + ParentKOLForm.FormName + - '.' + ParentForm.MethodName( @OnDestroy ) + - ' C1 AddByte_Store #TThread_.FOnDestroy.TMethod.Code' + - ' LoadSELF C1 AddByte_Store #TThread_.FOnDestroy.TMethod.Data' ); - if PriorityClass <> pcNormal then - //SL.Add( Prefix + AName + '.PriorityClass := ' + - // PriorityClasses[ PriorityClass ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( PriorityClass ) ) + ')' + - ' C1 TThread_.SetPriorityClass<2>' ); - if ThreadPriority <> tpNormal then - //SL.Add( Prefix + AName + '.ThreadPriority := ' + - // ThreadPriorities[ ThreadPriority ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( ThreadPriority ) ) + ')' + - ' C1 TThread_.SetThreadPriority<2>' ); - GenerateTag( SL, AName, Prefix ); - if not startSuspended then - //SL.Add( Prefix + AName + '.Resume;' ); - {P}SL.Add( ' DUP TThread.Resume<1>' ); - end - else - begin - {S := 'nil'; - if @OnExecute <> nil then - S := 'Result.' + ParentForm.MethodName( @OnExecute ); - SL.Add( Prefix + AName + ' := NewThreadEx( ' + S + ' );' );} - if @OnExecute <> nil then - {P}SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + - ParentForm.MethodName( @OnExecute ) ) - else - {P}SL.Add( ' L(0) L(0)' ); - {P}SL.Add( ' NewThreadEx<0> RESULT DUP LoadSELF AddWord_Store ##T' + - ParentKOLForm.FormName + '.' + Name ); - end; - if not PriorityBoost then - //SL.Add( Prefix + AName + '.PriorityBoost := FALSE;' ); - {P}SL.Add( ' L(0) C1 TThread_.SetPriorityBoost<2>' ); -end; - procedure TKOLThread.SetAutoFree(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.SetAutoFree', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.SetAutoFree', 0 + +@@e_signature: end; F_AutoFree := Value; Change; @@ -3285,10 +2658,11 @@ end; procedure TKOLThread.SetOnExecute(const Value: TOnThreadExecute); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.SetOnExecute', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.SetOnExecute', 0 + +@@e_signature: end; FOnExecute := Value; Change; @@ -3297,10 +2671,11 @@ end; procedure TKOLThread.SetOnResume(const Value: TOnEvent); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.SetOnResume', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.SetOnResume', 0 + +@@e_signature: end; FOnResume := Value; Change; @@ -3309,10 +2684,11 @@ end; procedure TKOLThread.SetOnSuspend(const Value: TObjectMethod); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.SetOnSuspend', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.SetOnSuspend', 0 + +@@e_signature: end; FOnSuspend := Value; Change; @@ -3327,10 +2703,11 @@ end; procedure TKOLThread.SetPriorityClass(const Value: TPriorityClass); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.SetPriorityClass', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.SetPriorityClass', 0 + +@@e_signature: end; FPriorityClass := Value; Change; @@ -3339,10 +2716,11 @@ end; procedure TKOLThread.SetstartSuspended(const Value: Boolean); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.SetstartSuspended', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.SetstartSuspended', 0 + +@@e_signature: end; FstartSuspended := Value; Change; @@ -3351,74 +2729,67 @@ end; procedure TKOLThread.SetThreadPriority(const Value: TThreadPriority); begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.SetThreadPriority', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.SetThreadPriority', 0 + +@@e_signature: end; FThreadPriority := Value; Change; end; -procedure TKOLThread.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -const PriorityClasses: array[ TPriorityClass ] of String = - ( 'NORMAL_PRIORITY_CLASS', 'IDLE_PRIORITY_CLASS', 'HIGH_PRIORITY_CLASS', - 'REALTIME_PRIORITY_CLASS' ); - ThreadPriorities: array[ TThreadPriority ] of String = - ( 'THREAD_PRIORITY_NORMAL', 'THREAD_PRIORITY_BELOW_NORMAL', - 'THREAD_PRIORITY_LOWEST', 'THREAD_PRIORITY_IDLE', - 'THREAD_PRIORITY_ABOVE_NORMAL', 'THREAD_PRIORITY_HIGHEST', - 'THREAD_PRIORITY_CRITICAL' ); -var S: String; +procedure TKOLThread.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +const + PriorityClasses: array[TPriorityClass] of string = ('NORMAL_PRIORITY_CLASS', + 'IDLE_PRIORITY_CLASS', 'HIGH_PRIORITY_CLASS', 'REALTIME_PRIORITY_CLASS'); + ThreadPriorities: array[TThreadPriority] of string = ('THREAD_PRIORITY_NORMAL', + 'THREAD_PRIORITY_BELOW_NORMAL', 'THREAD_PRIORITY_LOWEST', + 'THREAD_PRIORITY_IDLE', 'THREAD_PRIORITY_ABOVE_NORMAL', + 'THREAD_PRIORITY_HIGHEST', 'THREAD_PRIORITY_CRITICAL'); +var + S: string; begin asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLThread.SetupFirst', 0 - @@e_signature: + jmp @@e_signature + DB '#$signature$#', 0 + DB 'TKOLThread.SetupFirst', 0 + +@@e_signature: end; - if startSuspended or (@OnSuspend <> nil) or - (@OnResume <> nil) or (@OnDestroy <> nil) or - AutoFree or (PriorityClass <> pcNormal) or (ThreadPriority <> tpNormal) - or (Tag <> 0) then - begin + if startSuspended or (@OnSuspend <> nil) or (@OnResume <> nil) or (@OnDestroy + <> nil) or AutoFree or (PriorityClass <> pcNormal) or (ThreadPriority <> + tpNormal) or (Tag <> 0) then begin if AutoFree then - SL.Add( Prefix + AName + ' := NewThreadAutoFree( nil );' ) + SL.Add(Prefix + AName + ' := NewThreadAutoFree( nil );') else - SL.Add( Prefix + AName + ' := NewThread;' ); - SetupName( SL, AName, AParent, Prefix ); + SL.Add(Prefix + AName + ' := NewThread;'); + SetupName(SL, AName, AParent, Prefix); if @OnExecute <> nil then - SL.Add( Prefix + AName + '.OnExecute := Result.' + - ParentForm.MethodName( @OnExecute ) + ';' ); + SL.Add(Prefix + AName + '.OnExecute := Result.' + ParentForm.MethodName(@OnExecute) + ';'); if @OnSuspend <> nil then - SL.Add( Prefix + AName + '.OnSuspend := Result.' + - ParentForm.MethodName( @OnSuspend ) + ';' ); + SL.Add(Prefix + AName + '.OnSuspend := Result.' + ParentForm.MethodName(@OnSuspend) + ';'); if @OnResume <> nil then - SL.Add( Prefix + AName + '.OnResume := Result.' + - ParentForm.MethodName( @OnResume ) + ';' ); + SL.Add(Prefix + AName + '.OnResume := Result.' + ParentForm.MethodName(@OnResume) + ';'); if @OnDestroy <> nil then - SL.Add( Prefix + AName + '.OnDestroy := Result.' + - ParentForm.MethodName( @OnDestroy ) + ';' ); + SL.Add(Prefix + AName + '.OnDestroy := Result.' + ParentForm.MethodName(@OnDestroy) + ';'); if PriorityClass <> pcNormal then - SL.Add( Prefix + AName + '.PriorityClass := ' + - PriorityClasses[ PriorityClass ] + ';' ); + SL.Add(Prefix + AName + '.PriorityClass := ' + PriorityClasses[PriorityClass] + ';'); if ThreadPriority <> tpNormal then - SL.Add( Prefix + AName + '.ThreadPriority := ' + - ThreadPriorities[ ThreadPriority ] + ';' ); - GenerateTag( SL, AName, Prefix ); + SL.Add(Prefix + AName + '.ThreadPriority := ' + ThreadPriorities[ThreadPriority] + ';'); + GenerateTag(SL, AName, Prefix); if not startSuspended then - SL.Add( Prefix + AName + '.Resume;' ); + SL.Add(Prefix + AName + '.Resume;'); end - else - begin + else begin S := 'nil'; if @OnExecute <> nil then - S := 'Result.' + ParentForm.MethodName( @OnExecute ); - SL.Add( Prefix + AName + ' := NewThreadEx( ' + S + ' );' ); + S := 'Result.' + ParentForm.MethodName(@OnExecute); + SL.Add(Prefix + AName + ' := NewThreadEx( ' + S + ' );'); end; if not PriorityBoost then - SL.Add( Prefix + AName + '.PriorityBoost := FALSE;' ); + SL.Add(Prefix + AName + '.PriorityBoost := FALSE;'); end; end. + diff --git a/mirror.pas b/mirror.pas index c1ad01b..7f7d18f 100644 --- a/mirror.pas +++ b/mirror.pas @@ -21,7 +21,7 @@ mmmmm mmmmm mmmmm cccccccccccc kkkkk kkkkk ******************************************************** * VERSION 3.20 ******************************************************** -} + } unit mirror; { This unit contains definitions of mirror classes reflecting to objects of @@ -37,89 +37,68 @@ interface {$I KOLDEF.INC} {$IFNDEF USE_KOLCTRLWRAPPER} - {$DEFINE NOT_USE_KOLCTRLWRAPPER} +{$DEFINE NOT_USE_KOLCTRLWRAPPER} {$ENDIF} {$IFDEF NOT_USE_KOLCTRLWRAPPER} - {$IFDEF _KOLCTRLWRAPPER_} - {$UNDEF _KOLCTRLWRAPPER_} - {$ENDIF} +{$IFDEF _KOLCTRLWRAPPER_} +{$UNDEF _KOLCTRLWRAPPER_} {$ENDIF} - -{$IFNDEF NO_NEWIF} - {$IFDEF _D6orHigher} //{$IFDEF _D2005orHigher} - { directive $IF appears at least in Delphi6 } - {$DEFINE NEWIF} - {$ENDIF} {$ENDIF} uses olectrls, KOL, KOLadd, Classes, Forms, Controls, Dialogs, Windows, Messages, extctrls, - stdctrls, comctrls, SysUtils, Graphics, -////////////////////////////////////////////////// - ExptIntf, ToolIntf, EditIntf, // DsgnIntf -////////////////////////////////////////////////// - {$IFDEF _D6orHigher} // - DesignIntf, DesignEditors, DesignConst, // - Variants // - {$ELSE} // - DsgnIntf // - {$ENDIF} // -////////////////////////////////////////////////// - , ToolsAPI, TypInfo, Consts, mckMenuEditor, mckAccEditor, mckActionListEditor; + stdctrls, comctrls, SysUtils, Graphics, + ////////////////////////////////////////////////// + ExptIntf, ToolIntf, EditIntf, + ////////////////////////////////////////////////// +{$IFDEF _D6orHigher} + DesignIntf, DesignEditors, DesignConst, Variants, +{$ELSE} + DsgnIntf, +{$ENDIF} + ////////////////////////////////////////////////// + ToolsAPI, TypInfo, Consts, mckMenuEditor, mckAccEditor, mckActionListEditor; const WM_USER_ALIGNCHILDREN = WM_USER + 1; cKOLTag = -999; LIGHT = FOREGROUND_INTENSITY; - WHITE = FOREGROUND_RED or FOREGROUND_BLUE or FOREGROUND_GREEN; - RED = FOREGROUND_INTENSITY or FOREGROUND_RED; - GREEN = FOREGROUND_INTENSITY or FOREGROUND_GREEN; - BLUE = FOREGROUND_BLUE; - CYAN = FOREGROUND_BLUE or FOREGROUND_GREEN; + WHITE = FOREGROUND_RED or FOREGROUND_BLUE or FOREGROUND_GREEN; + RED = FOREGROUND_INTENSITY or FOREGROUND_RED; + GREEN = FOREGROUND_INTENSITY or FOREGROUND_GREEN; + BLUE = FOREGROUND_BLUE; + CYAN = FOREGROUND_BLUE or FOREGROUND_GREEN; YELLOW = FOREGROUND_INTENSITY or FOREGROUND_GREEN or FOREGROUND_RED; type - {$IFDEF _D2009orHigher} - TDelphiString = WideString; - {$ELSE} - TDelphiString = String; - {$ENDIF} +{$IFDEF _D2009orHigher} + TDelphiString = WideString; +{$ELSE} + TDelphiString = string; +{$ENDIF} -////////////////////////////////////////////////////////// - {$IFDEF _D6orHigher} // - TDesignerSelectionList = TDesignerSelections; // - {$ENDIF} // -////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////// +{$IFDEF _D6orHigher} // + TDesignerSelectionList = TDesignerSelections; // +{$ENDIF} // + ////////////////////////////////////////////////////////// - - - - TFormStringList = class( TStringList ) + TFormStringList = class(TStringList) private FCallingOnAdd: Boolean; FOnAdd: TNotifyEvent; procedure SetOnAdd(const Value: TNotifyEvent); public - property OnAdd: TNotifyEvent read FOnAdd write SetOnAdd; - function Add( const s: String ): Integer; override; + property OnAdd: TNotifyEvent read FOnAdd write SetOnAdd; + function Add(const s: string): Integer; override; end; - - - - - - - - TKOLActionList = class; TKOLAction = class; - - - TPaintType = ( ptWYSIWIG, ptWYSIWIGFrames, ptSchematic, ptWYSIWIGCustom ); {YS} + TPaintType = (ptWYSIWIG, ptWYSIWIGFrames, ptSchematic, ptWYSIWIGCustom); {YS} TKOLForm = class; TKOLFont = class; @@ -133,17 +112,17 @@ type // один раз в проекте). Он отвечает за генерацию кода и содержит доступные // из ObjectInspector-а настройки (общие для всего проекта), используемые // при генерации кода dpr-файла. - TKOLProject = class( TComponent ) + TKOLProject = class(TComponent) private - fProjectName: String; - FProjectDest: String; + fProjectName: string; + FProjectDest: string; fSourcePath: TFileName; fDprResource: Boolean; fProtect: Boolean; fShowReport: Boolean; fBuild: Boolean; fIsKOL: Integer; - fOutdcuPath: String; + fOutdcuPath: string; fAutoBuild: Boolean; fTimer: TTimer; fAutoBuilding: Boolean; @@ -155,20 +134,17 @@ type fChangingNow: Boolean; FSupportAnsiMnemonics: LCID; FPaintType: TPaintType; - FHelpFile: String; + FHelpFile: string; FLocalizy: Boolean; FShowHint: Boolean; FIsDestroying: Boolean; - FCallPCompiler: String; FReportDetailed: Boolean; - FGeneratePCode: Boolean; FDefaultFont: TKOLFont; - FFormCompactDisabled: Boolean; - FAutoCreateForms: String; - function GetProjectName: String; - procedure SetProjectDest(const Value: String); + FAutoCreateForms: string; + function GetProjectName: string; + procedure SetProjectDest(const Value: string); - function ConvertVCL2KOL( ConfirmOK: Boolean; ForceAllForms: Boolean ): Boolean; + function ConvertVCL2KOL(ConfirmOK: Boolean; ForceAllForms: Boolean): Boolean; function OwnerKOLForm: TKOLForm; {$IFDEF _D2007orHigher} @@ -176,7 +152,7 @@ type {$ENDIF} function UpdateConfig: Boolean; function GetSourcePath: TFileName; - function GetProjectDest: String; + function GetProjectDest: string; function GetBuild: Boolean; procedure SetBuild(const Value: Boolean); function GetIsKOLProject: Boolean; @@ -190,40 +166,38 @@ type procedure SetLocked(const Value: Boolean); procedure SetSupportAnsiMnemonics(const Value: LCID); procedure SetPaintType(const Value: TPaintType); - procedure SetHelpFile(const Value: String); + procedure SetHelpFile(const Value: string); procedure SetLocalizy(const Value: Boolean); procedure SetShowHint(const Value: Boolean); - procedure SetCallPCompiler(const Value: String); procedure SetReportDetailed(const Value: Boolean); - procedure SetGeneratePCode(const Value: Boolean); - function getNewIf: Boolean; - procedure setNewIf(const Value: Boolean); procedure SetDefaultFont(const Value: TKOLFont); - procedure SetFormCompactDisabled(const Value: Boolean); - procedure SetAutoCreateForms(const Value: String); + procedure SetAutoCreateForms(const Value: string); + procedure Prepare_0inc(const Path: String; const IsDLL: Boolean; const AForms: TStringList; + var AParent: KOLString; var Updated: Boolean); + procedure Prepare_134inc(const Path: string; var Updated: Boolean); + procedure Prepare_2inc(const Path: String; const IsDLL: Boolean; const AForms: TStringList; + var AParent: KOLString; var Updated: Boolean; const FormsToAutoCreate: TStringList); protected FLocked: Boolean; - FNewIF: Boolean; - function GenerateDPR( const Path: String ): Boolean; virtual; - procedure BeforeGenerateDPR( const SL: TStringList; var Updated: Boolean ); virtual; - procedure AfterGenerateDPR( const SL: TStringList; var Updated: Boolean ); virtual; - procedure TimerTick( Sender: TObject ); + function GenerateDPR(const Path: string): Boolean; virtual; + procedure BeforeGenerateDPR(const SL: TStringList; var Updated: Boolean); virtual; + procedure AfterGenerateDPR(const SL: TStringList; var Updated: Boolean); virtual; + procedure TimerTick(Sender: TObject); property AutoBuilding: Boolean read fAutoBuilding write fAutoBuilding; procedure BroadCastPaintTypeToAllForms; procedure Loaded; override; procedure SetName(const NewName: TComponentName); override; protected ResStrings: TStringList; - function StringConstant( const Propname, Value: String ): String; - function P_StringConstant( const Propname, Value: String ): String; - procedure MakeResourceString( const ResourceConstName, Value: String ); + function StringConstant(const Propname, Value: string): string; + procedure MakeResourceString(const ResourceConstName, Value: string); public procedure Change; procedure ChangeAllForms; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - procedure Report(const Txt: String; Color: Integer ); + procedure Report(const Txt: string; Color: Integer); property Building: Boolean read FBuilding; published property Locked: Boolean read FLocked write SetLocked; @@ -235,13 +209,13 @@ type // // Имя проекта (зеркального, т.е. исходного). Определяется просто - по // заголовку окна Delphi IDE. Можно изменить руками. - property projectName: String read GetProjectName write fProjectName; + property projectName: string read GetProjectName write fProjectName; // Project name for converted (KOL) project. Must be entered manually, // and it must not much project name. // Имя проекта после конверсии в KOL. Требуется ввести руками. // Ни в коем случае не должен совпадать с именем самого проекта. - property projectDest: String read GetProjectDest write SetProjectDest; + property projectDest: string read GetProjectDest write SetProjectDest; // Path to source (=mirror) project. When TKOLProject component is // dropped onto form, a dialog is appear to select path to a directory @@ -294,21 +268,17 @@ type property PaintType: TPaintType read FPaintType write SetPaintType; - property HelpFile: String read FHelpFile write SetHelpFile; + property HelpFile: string read FHelpFile write SetHelpFile; property ShowHint: Boolean read FShowHint write SetShowHint; {* To provide tooltip (hint) showing, it is necessary to define conditional symbol USE_MHTOOLTIP in Project|Options|Directories/Conditionals|Conditional Defines. } - property CallPCompiler: String read FCallPCompiler write SetCallPCompiler; property ReportDetailed: Boolean read FReportDetailed write SetReportDetailed; - property GeneratePCode: Boolean read FGeneratePCode write SetGeneratePCode; - property NewIF: Boolean read getNewIf write setNewIf; property DefaultFont: TKOLFont read FDefaultFont write SetDefaultFont; - property FormCompactDisabled: Boolean read FFormCompactDisabled write SetFormCompactDisabled; - property AutoCreateForms: String read FAutoCreateForms write SetAutoCreateForms; + property AutoCreateForms: string read FAutoCreateForms write SetAutoCreateForms; end; - TKOLProjectBuilder = class( TComponentEditor ) + TKOLProjectBuilder = class(TComponentEditor) private protected public @@ -318,31 +288,7 @@ type function GetVerbCount: Integer; override; end; - - - - - - - - - - - - - - - - - - - - - - - - - TKOLFont = class( TPersistent ) + TKOLFont = class(TPersistent) private fOwner: TComponent; FFontCharset: Byte; @@ -350,7 +296,7 @@ type FFontWidth: Integer; FFontHeight: Integer; FFontWeight: Integer; - FFontName: String; + FFontName: string; FColor: TColor; FFontPitch: TFontPitch; FFontStyle: TFontStyles; @@ -359,7 +305,7 @@ type procedure SetColor(const Value: TColor); procedure SetFontCharset(const Value: Byte); procedure SetFontHeight(const Value: Integer); - procedure SetFontName(const Value: String); + procedure SetFontName(const Value: string); procedure SetFontOrientation(Value: Integer); procedure SetFontPitch(const Value: TFontPitch); procedure SetFontStyle(const Value: TFontStyles); @@ -370,11 +316,10 @@ type procedure Changing; public procedure Change; - constructor Create( AOwner: TComponent ); - function Equal2( AFont: TKOLFont ): Boolean; - procedure GenerateCode( SL: TStrings; const AName: String; AFont: TKOLFont ); - procedure P_GenerateCode( SL: TStrings; const AName: String; AFont: TKOLFont ); - procedure Assign( Value: TPersistent ); override; + constructor Create(AOwner: TComponent); + function Equal2(AFont: TKOLFont): Boolean; + procedure GenerateCode(SL: TStrings; const AName: string; AFont: TKOLFont); + procedure Assign(Value: TPersistent); override; property Owner: TComponent read fOwner; published property Color: TColor read FColor write SetColor; @@ -382,14 +327,14 @@ type property FontHeight: Integer read FFontHeight write SetFontHeight; property FontWidth: Integer read FFontWidth write SetFontWidth; property FontWeight: Integer read FFontWeight write SetFontWeight; - property FontName: String read FFontName write SetFontName; + property FontName: string read FFontName write SetFontName; property FontOrientation: Integer read FFontOrientation write SetFontOrientation; property FontCharset: Byte read FFontCharset write SetFontCharset; property FontPitch: TFontPitch read FFontPitch write SetFontPitch; property FontQuality: TFontQuality read FFontQuality write SetFontQuality; end; - TKOLBrush = class( TPersistent ) + TKOLBrush = class(TPersistent) private fOwner: TComponent; FBrushStyle: TBrushStyle; @@ -402,51 +347,32 @@ type procedure SetColor(const Value: TColor); procedure SetAllowBitmapCompression(const Value: Boolean); protected - procedure GenerateCode( SL: TStrings; const AName: String ); - procedure P_GenerateCode( SL: TStrings; const AName: String ); + procedure GenerateCode(SL: TStrings; const AName: string); public procedure Change; - constructor Create( AOwner: TComponent ); + constructor Create(AOwner: TComponent); destructor Destroy; override; - procedure Assign( Value: TPersistent ); override; + procedure Assign(Value: TPersistent); override; published property Color: TColor read FColor write SetColor; property BrushStyle: TBrushStyle read FBrushStyle write SetBrushStyle; property Bitmap: TBitmap read FBitmap write SetBitmap; property AllowBitmapCompression: Boolean read FAllowBitmapCompression write SetAllowBitmapCompression - default TRUE; + default True; end; - - - - - - - - - - - - - - - //============================================================================ - // Mirror class, corresponding to unnecessary in KOL application - // taskbar button (variable Applet). - // + // Mirror class, corresponding to unnecessary in KOL application taskbar button (variable Applet). // Зеркальный класс, соответствующий необязательному в KOL - // приложению (окну, представляющему кнопку приложения на панели - // задач) - TKOLApplet = class( TComponent ) + // приложению (окну, представляющему кнопку приложения на панели задач) + TKOLApplet = class(TComponent) private FLastWarnTimeAbtMainForm: Integer; FShowingWarnAbtMainForm: Boolean; FOnMessage: TOnMessage; FOnDestroy: TOnEvent; FOnClose: TOnEventAccept; - FIcon: String; + FIcon: string; fChangingNow: Boolean; FOnQueryEndSession: TOnEventAccept; FOnMinimize: TOnEvent; @@ -456,13 +382,13 @@ type FForceIcon16x16: Boolean; FTabulate: Boolean; FTabulateEx: Boolean; - procedure SetCaption(const Value: String); + procedure SetCaption(const Value: string); procedure SetVisible(const Value: Boolean); procedure SetEnabled(const Value: Boolean); procedure SetOnMessage(const Value: TOnMessage); procedure SetOnDestroy(const Value: TOnEvent); procedure SetOnClose(const Value: TOnEventAccept); - procedure SetIcon(const Value: String); + procedure SetIcon(const Value: string); procedure SetOnQueryEndSession(const Value: TOnEventAccept); procedure SetOnMinimize(const Value: TOnEvent); procedure SetOnRestore(const Value: TOnEvent); @@ -472,13 +398,13 @@ type procedure SetTabulate(const Value: Boolean); procedure SetTabulateEx(const Value: Boolean); protected - fCaption: String; + fCaption: string; fVisible, fEnabled: Boolean; FChanged: Boolean; - fSourcePath: String; - fIsDestroying: Boolean; + fSourcePath: string; + FIsDestroying: Boolean; //Creating_DoNotGenerateCode: Boolean; - procedure GenerateRun( SL: TStringList; const AName: String ); virtual; + procedure GenerateRun(SL: TStringList; const AName: string); virtual; function AutoCaption: Boolean; virtual; procedure ChangeDPR; virtual; @@ -489,32 +415,25 @@ type // Процедура присваивания значений назначенным событиям. Вызывается из // SetupFirst и фактически должна (после вызова inherited) передать // в процедуру DoAssignEvents список (дополнительных) событий. - procedure AssignEvents( SL: TStringList; const AName: String ); virtual; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; virtual; - + procedure AssignEvents(SL: TStringList; const AName: string); virtual; protected FEventDefs: TStringList; FAssignOnlyUserEvents: Boolean; FAssignOnlyWinEvents: Boolean; public - procedure DefineFormEvents( const EventNamesAndDefs: array of String ); - procedure DoAssignEvents( SL: TStringList; const AName: String; - EventNames: array of PChar; EventHandlers: array of Pointer ); - function P_DoAssignEvents( SL: TStringList; const AName: String; - EventNames: array of PAnsiChar; EventHandlers: array of Pointer; - EventAssignProc: array of Boolean; CheckOnly: Boolean ): Boolean; - function BestEventName: String; virtual; + procedure DefineFormEvents(const EventNamesAndDefs: array of string); + procedure DoAssignEvents(SL: TStringList; const AName: string; + EventNames: array of PChar; EventHandlers: array of Pointer); + function BestEventName: string; virtual; public - procedure Change( Sender: TComponent ); virtual; - constructor Create( AOwner: TComponent ); override; + procedure Change(Sender: TComponent); virtual; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Enabled: Boolean read fEnabled write SetEnabled; - function Pcode_Generate: Boolean; virtual; published - property Icon: String read FIcon write SetIcon; + property Icon: string read FIcon write SetIcon; property ForceIcon16x16: Boolean read FForceIcon16x16 write SetForceIcon16x16; - property Caption: String read fCaption write SetCaption; + property Caption: string read fCaption write SetCaption; property Visible: Boolean read fVisible write SetVisible; property OnMessage: TOnMessage read FOnMessage write SetOnMessage; property OnDestroy: TOnEvent read FOnDestroy write SetOnDestroy; @@ -526,7 +445,7 @@ type property Tag: Integer read FTag write SetTag; property Tabulate: Boolean read FTabulate write SetTabulate; property TabulateEx: Boolean read FTabulateEx write SetTabulateEx; - property UnitSourcePath: String read fSourcePath write fSourcePath; + property UnitSourcePath: string read fSourcePath write fSourcePath; end; // Special class to avoid conflict with Left and Top properties of @@ -534,7 +453,7 @@ type // // Специальный класс, чтобы обойти конфликт со свойствами Left / Top // в Bounds формы (в компоненте TKOLForm). - TFormBounds = class( TPersistent ) + TFormBounds = class(TPersistent) private fOwner: TComponent; fTimer: TTimer; @@ -547,7 +466,7 @@ type procedure SetLeft(const Value: Integer); procedure SetTop(const Value: Integer); procedure SetWidth(const Value: Integer); - procedure CheckFormSize( Sender: TObject ); + procedure CheckFormSize(Sender: TObject); procedure SetOwner(const Value: TComponent); protected public @@ -563,31 +482,6 @@ type property Height: Integer read GetHeight write SetHeight stored False; end; - - - - - - - - - - - - - - - - - - - - - - - - - //============================================================================ // Mirror component, corresponding to KOL's form. It must be present // on each of mirror project's form to provide generating of corresponding @@ -601,14 +495,14 @@ type TKOLCustomControl = class; TKOLPopupMenu = class; - TLocalizyOptions = ( loForm, loNo, loYes ); + TLocalizyOptions = (loForm, loNo, loYes); - TKOLFormBorderStyle = ( fbsNone, fbsSingle, fbsDialog, fbsToolWindow ); {YS} + TKOLFormBorderStyle = (fbsNone, fbsSingle, fbsDialog, fbsToolWindow); {YS} - TKOLForm = class( TKOLApplet ) + TKOLForm = class(TKOLApplet) private fFormMain: Boolean; - fFormUnit: String; + fFormUnit: string; fBounds: TFormBounds; fDefaultSize: Boolean; fMargin: Integer; @@ -641,8 +535,8 @@ type FMaximizeIcon: Boolean; FMinimizeIcon: Boolean; FCloseIcon: Boolean; - FIcon: String; - FCursor: String; + FIcon: string; + FCursor: string; fFont: TKOLFont; fBrush: TKOLBrush; FOnFormCreate: TOnEvent; @@ -682,18 +576,17 @@ type FhelpContextIcon: Boolean; FOnHelp: TOnHelp; fDefaultBtnCtl, fCancelBtnCtl: TKOLCustomControl; - FborderStyle: TKOLFormBorderStyle; {YS} + FborderStyle: TKOLFormBorderStyle; {YS} FGetShowHint: Boolean; FOnBeforeCreateWindow: TOnEvent; {YS} FKeyPreview: Boolean; FFontDefault: Boolean; - FFormCompact: Boolean; FGenerateCtlNames: Boolean; FUnicode: Boolean; FOverrideScrollbars: Boolean; fAssignTextToControls: Boolean; FAssignTabOrders: Boolean; - fFormCurrentParent: String; + fFormCurrentParent: string; fCenterOnCurScrn: Boolean; function GetFormUnit: KOLString; procedure SetFormMain(const Value: Boolean); @@ -732,8 +625,8 @@ type procedure SetMaximizeIcon(const Value: Boolean); procedure SetMinimizeIcon(const Value: Boolean); procedure SetCloseIcon(const Value: Boolean); - procedure SetCursor(const Value: String); - procedure SetIcon(const Value: String); + procedure SetCursor(const Value: string); + procedure SetIcon(const Value: string); function Get_Color: TColor; procedure Set_Color(const Value: TColor); procedure SetFont(const Value: TKOLFont); @@ -782,70 +675,52 @@ type procedure SetOnBeforeCreateWindow(const Value: TOnEvent); {YS} procedure SetKeyPreview(const Value: Boolean); procedure SetFontDefault(const Value: Boolean); - procedure SetFormCompact(const Value: Boolean); procedure SetGenerateCtlNames(const Value: Boolean); procedure SetUnicode(const Value: Boolean); procedure SetOverrideScrollbars(const Value: Boolean); procedure Set_Bounds(const Value: TFormBounds); procedure SetAssignTextToControls(const Value: Boolean); procedure SetAssignTabOrders(const Value: Boolean); - function GetFormCompact: Boolean; - procedure SetFormCurrentParent(const Value: String); + procedure SetFormCurrentParent(const Value: string); procedure SetCenterOnCurScrn(const Value: Boolean); protected fUniqueID: Integer; FLocked: Boolean; - function AdditionalUnits: String; virtual; - function FormTypeName: String; virtual; + function AdditionalUnits: string; virtual; + function FormTypeName: string; virtual; function AppletOnForm: Boolean; function GetCaption: TDelphiString; virtual; procedure SetFormCaption(const Value: TDelphiString); virtual; function GetFormName: KOLString; procedure SetFormName(const Value: KOLString); - function GenerateTransparentInits: String; virtual; - function P_GenerateTransparentInits: String; virtual; - function Result_Form: String; virtual; + function GenerateTransparentInits: string; virtual; + function Result_Form: string; virtual; - function StringConstant( const Propname, Value: String ): String; - function P_StringConstant( const Propname, Value: String ): String; + function StringConstant(const Propname, Value: string): string; public - procedure Change( Sender: TComponent ); override; + procedure Change(Sender: TComponent); override; // Methods to generate code of unit, containing form definition. // Методы, в которых генерится код модуля, содержащего форму procedure DoChangeNow; - function GenerateUnit( const Path: String ): Boolean; virtual; - function Pcode_Generate: Boolean; override; + function GenerateUnit(const Path: string): Boolean; virtual; protected FNameSetuped: Boolean; - fP_NameSetuped: Boolean; - function GeneratePAS( const Path: String; var Updated: Boolean ): Boolean; virtual; - function AfterGeneratePas( SL: TStringList ): Boolean; virtual; - function GenerateINC( const Path: String; var Updated: Boolean ): Boolean; virtual; - procedure GenerateChildren( SL: TStringList; OfParent: TComponent; - const OfParentName: String; const Prefix: String; - var Updated: Boolean ); - procedure P_GenerateChildren( SL: TStringList; OfParent: TComponent; - const OfParentName: String; const Prefix: String; - var Updated: Boolean ); - procedure GenerateCreateForm( SL: TStringList ); virtual; - procedure ClearBeforeGenerateForm( SL: TStringList ); - procedure P_GenerateCreateForm( SL: TStringList ); virtual; - procedure GenerateDestroyAfterRun( SL: TStringList ); virtual; - procedure GenerateAdd2AutoFree( SL: TStringList; const AName: String; AControl: Boolean; - Add2AutoFreeProc: String; Obj: TObject ); virtual; - procedure P_GenerateAdd2AutoFree( SL: TStringList; const AName: String; AControl: Boolean; - Add2AutoFreeProc: String; Obj: TObject ); virtual; + function GeneratePAS(const Path: string; var Updated: Boolean): Boolean; virtual; + function AfterGeneratePas(SL: TStringList): Boolean; virtual; + function GenerateINC(const Path: string; var Updated: Boolean): Boolean; virtual; + procedure GenerateChildren(SL: TStringList; OfParent: TComponent; + const OfParentName: string; const Prefix: string; + var Updated: Boolean); + procedure GenerateCreateForm(SL: TStringList); virtual; + procedure GenerateDestroyAfterRun(SL: TStringList); virtual; + procedure GenerateAdd2AutoFree(SL: TStringList; const AName: string; AControl: Boolean; + Add2AutoFreeProc: string; Obj: TObject); virtual; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; - - procedure SetupName( SL: TStringList; const AName, AParent, Prefix: String ); - procedure P_SetupName( SL: TStringList ); + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); virtual; + procedure SetupName(SL: TStringList; const AName, AParent, Prefix: string); // Is called after constructing of all child controls and objects // to generate final initialization if needed (only for form object @@ -855,10 +730,7 @@ type // Вызывается уже после генерации конструирования всех // дочерних контролов и объектов формы - для генерации какой-либо // завершающей инициализации (самой формы): - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); virtual; // Method to assign values to assigned events. Is called in SetupFirst // and actually should call DoAssignEvents, passing a list of (additional) @@ -867,30 +739,26 @@ type // Процедура присваивания значений назначенным событиям. Вызывается из // SetupFirst и фактически должна (после вызова inherited) передать // в процедуру DoAssignEvents список (дополнительных) событий. - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; override; - + procedure AssignEvents(SL: TStringList; const AName: string); override; property PaintType: TPaintType read FPaintType write SetPaintType; procedure InvalidateControls; procedure Loaded; override; procedure GetPaintTypeFromProjectOrOtherForms; function DoNotGenerateSetPosition: Boolean; virtual; - procedure RealignTimerTick( Sender: TObject ); - procedure ChangeTimerTick( Sender: TObject ); - + procedure RealignTimerTick(Sender: TObject); + procedure ChangeTimerTick(Sender: TObject); public - function BestEventName: String; override; + function BestEventName: string; override; protected fCreating: Boolean; fOrderControl: Integer; ResStrings: TStringList; - procedure MakeResourceString( const ResourceConstName, Value: String ); + procedure MakeResourceString(const ResourceConstName, Value: string); public AllowRealign: Boolean; FRealigning: Integer; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; function NextUniqueID: Integer; @@ -916,7 +784,7 @@ type property Form: TKOLForm read GetSelf; property ModalResult: Integer read FModalResult write SetModalResult; property Margin: Integer read fMargin write SetMargin; - procedure AlignChildren( PrntCtrl: TKOLCustomControl; Recursive: Boolean ); + procedure AlignChildren(PrntCtrl: TKOLCustomControl; Recursive: Boolean); function HasMainMenu: Boolean; published property Locked: Boolean read FLocked write SetLocked; @@ -987,13 +855,13 @@ type // В дизайнере свойства Icon и Cursor являются строками, представляющими // собой имена соответствующих ресурсов. Для подключения файлов, содержащих // эти ресурсы, используйте в своем проекте директиву $R. - property Icon: String read FIcon write SetIcon; - property Cursor: String read FCursor write SetCursor; + property Icon: string read FIcon write SetIcon; + property Cursor: string read FCursor write SetCursor; property Color: TColor read Get_Color write Set_Color; property Font: TKOLFont read fFont write SetFont; property FontDefault: Boolean read FFontDefault write SetFontDefault; - property Brush: TKOLBrush read FBrush write SetBrush; + property Brush: TKOLBrush read fBrush write SetBrush; property DoubleBuffered: Boolean read FDoubleBuffered write SetDoubleBuffered; property PreventResizeFlicks: Boolean read FPreventResizeFlicks write SetPreventResizeFlicks; @@ -1056,67 +924,29 @@ type property OnBeforeCreateWindow: TOnEvent read FOnBeforeCreateWindow write SetOnBeforeCreateWindow; protected FFormAlphabet: TStringList; - FFormCommandsAndParams: String; + FFormCommandsAndParams: string; FFormCtlParams: TStringList; public - FormCurrentCtlForTransparentCalls: String; + FormCurrentCtlForTransparentCalls: string; FormCurrentParentCtl: TKOLCustomControl; FormIndexFlush: Integer; FormFlushedUntil: Integer; FormFunArrayIdx: Integer; FormControlsList: TStringList; IsFormFlushing: Boolean; - property FormCurrentParent: String read fFormCurrentParent write SetFormCurrentParent; - function FormIndexOfControl( const CtlName: String ): Integer; - function EncodeFormNumParameter( I: Integer ): String; - function FormAddAlphabet( const funname: String; creates_ctrl, add_call: Boolean; - const Comment: String ): Integer; - procedure FormAddCtlCommand( const CtlName, FunName, Comment: String ); - procedure FormAddNumParameter( N: Integer ); - procedure FormAddStrParameter( const S: String ); - procedure FormAddCtlParameter( const S: String ); - procedure FormFlushCompact( SL: TFormStringList ); - function FormFlushedCompact: Boolean; - procedure DoFlushFormCompact( Sender: TObject ); - procedure GenerateTransparentInits_Compact; virtual; + property FormCurrentParent: string read fFormCurrentParent write SetFormCurrentParent; + function FormIndexOfControl(const CtlName: string): Integer; + function EncodeFormNumParameter(I: Integer): string; published - property FormCompact: Boolean read GetFormCompact write SetFormCompact; property GenerateCtlNames: Boolean read FGenerateCtlNames write SetGenerateCtlNames; property Unicode: Boolean read FUnicode write SetUnicode; property OverrideScrollbars: Boolean read FOverrideScrollbars write SetOverrideScrollbars; property AssignTextToControls: Boolean read fAssignTextToControls - write SetAssignTextToControls default TRUE; + write SetAssignTextToControls default True; property AssignTabOrders: Boolean read FAssignTabOrders write SetAssignTabOrders; end; - - - - - - - - - - - - - - - - - - - - - - - - - - - TNotifyOperation = ( noRenamed, noRemoved, noChanged ); - + TNotifyOperation = (noRenamed, noRemoved, noChanged); //============================================================================ // Mirror class TKOLObj approximately corresponds to TObj type in @@ -1126,19 +956,17 @@ type // Зеркальный класс TKOLObj приблизительно соответствует типу TObj // в иерархии объектов KOL. От него производятся классы, зеркальные // невизуальным объектам KOL. - TKOLObj = class( TComponent ) + TKOLObj = class(TComponent) private FOnDestroy: TOnEvent; F_Tag: Integer; FLocalizy: TLocalizyOptions; - function Get_Tag:Integer ; + function Get_Tag: Integer; procedure SetOnDestroy(const Value: TOnEvent); procedure Set_Tag(const Value: Integer); procedure SetLocalizy(const Value: TLocalizyOptions); protected FNameSetuped: Boolean; - fP_NameSetuped: Boolean; - fUpdated: Boolean; // A list of components which are linked to the TKOLObj component @@ -1161,11 +989,10 @@ type // вроде ImageList'а, которые разрушают себя сами). NeedFree: Boolean; - procedure SetName( const NewName: TComponentName ); override; + procedure SetName(const NewName: TComponentName); override; procedure FirstCreate; virtual; - function AdditionalUnits: String; virtual; - procedure GenerateTag( SL: TStringList; const AName, APrefix: String ); - procedure P_GenerateTag( SL: TStringList; const AName, APrefix: String ); + function AdditionalUnits: string; virtual; + procedure GenerateTag(SL: TStringList; const AName, APrefix: string); // This method adds operators of creation of object to the end of SL // and following ones for adjusting object properties and events. @@ -1173,20 +1000,11 @@ type // Процедура, которая добавляет в конец SL (:TStringList) операторы // создания объекта и те операторы настройки его свойств, которые // должны исполняться немедленно вслед за конструированием объекта: - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; - procedure SetupName( SL: TStringList; const AName, AParent, - Prefix: String ); virtual; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; - procedure P_SetupName( SL: TStringList ); virtual; - procedure P_SetupFirstFinalizy( SL: TStringList ); virtual; - - procedure P_ProvideFakeType( SL: TStrings; const Declaration: String ); - + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); virtual; + procedure SetupName(SL: TStringList; const AName, AParent, Prefix: string); virtual; public ObjInStack: Boolean; - procedure ProvideObjInStack( SL: TStrings ); + procedure ProvideObjInStack(SL: TStrings); protected // The same as above, but is called after generating of code to // create all child controls and objects - to insert final initialization @@ -1195,56 +1013,43 @@ type // Аналогично, но вызывается уже после генерации конструирования всех // дочерних контролов и объектов формы - для генерации какой-либо // завершающей инициализации: - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); virtual; - procedure DoGenerateConstants( SL: TStringList ); virtual; + procedure DoGenerateConstants(SL: TStringList); virtual; - procedure AssignEvents( SL: TStringList; const AName: String ); virtual; - function P_AssignEvents( SL: TStringList; const AName: String; CheckOnly: Boolean ): Boolean; virtual; + procedure AssignEvents(SL: TStringList; const AName: string); virtual; - procedure DoAssignEvents( SL: TStringList; const AName: String; - const EventNames: array of PAnsiChar; const EventHandlers: array of Pointer ); - function P_DoAssignEvents( SL: TStringList; const AName: String; - const EventNames: array of PAnsiChar; const EventHandlers: array of Pointer; - const EventAssignProc: array of Boolean; CheckOnly: Boolean ): Boolean; - function BestEventName: String; virtual; + procedure DoAssignEvents(SL: TStringList; const AName: string; + const EventNames: array of PAnsiChar; const EventHandlers: array of Pointer); + function BestEventName: string; virtual; function NotAutoFree: Boolean; virtual; - function CompareFirst(c, n: string): boolean; virtual; - function StringConstant( const Propname, Value: String ): String; - function P_StringConstant( const Propname, Value: String ): String; + function CompareFirst(c, N: string): Boolean; virtual; + function StringConstant(const Propname, Value: string): string; public procedure Change; virtual; function ParentKOLForm: TKOLForm; - function OwnerKOLForm( AOwner: TComponent ): TKOLForm; + function OwnerKOLForm(AOwner: TComponent): TKOLForm; function ParentForm: TForm; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - procedure AddToNotifyList( Sender: TComponent ); + procedure AddToNotifyList(Sender: TComponent); // procedure which is called by linked components, when those are // renamed or removed at design time. - procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); - virtual; - procedure DoNotifyLinkedComponents( Operation: TNotifyOperation ); + procedure NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); virtual; + procedure DoNotifyLinkedComponents(Operation: TNotifyOperation); // Returns type name without prefix. (TKOLTimer -> Timer). // // Данная функция возвращает имя типа объекта KOL (например, // зеркальный класс TKOLImageList соответствует типу TImageList в // KOL, возвращается 'ImageList'). - function TypeName: String; virtual; + function TypeName: string; virtual; property Localizy: TLocalizyOptions read FLocalizy write SetLocalizy; property CreationPriority: Integer read fCreationPriority; - - function Pcode_Generate: Boolean; virtual; - procedure P_DoProvideFakeType( SL: TStringList ); virtual; - published property Tag: Integer read Get_Tag write Set_Tag default 0; property OnDestroy: TOnEvent read FOnDestroy write SetOnDestroy; @@ -1252,37 +1057,37 @@ type CacheLines_SetupFirst: TStringList; end; - TKOLObjectCompEditor = class( TDefaultEditor ) + TKOLObjectCompEditor = class(TDefaultEditor) private protected FContinue: Boolean; FCount: Integer; - BestEventName: String; -////////////////////////////////////////////////////////// -{$IFDEF _D6orHigher} // + BestEventName: string; + ////////////////////////////////////////////////////////// +{$IFDEF _D6orHigher} // FFirst: IProperty; FBest: IProperty; - procedure CountEvents(const PropertyEditor: IProperty ); + procedure CountEvents(const PropertyEditor: IProperty); procedure CheckEdit(const PropertyEditor: IProperty); procedure EditProperty(const PropertyEditor: IProperty; - var Continue: Boolean); override; -//////////// -{$ELSE} // -////////////////////////////////////////////////////////// + var Continue: Boolean); override; + //////////// +{$ELSE} // + ////////////////////////////////////////////////////////// FFirst: TPropertyEditor; FBest: TPropertyEditor; - procedure CountEvents( PropertyEditor: TPropertyEditor ); + procedure CountEvents(PropertyEditor: TPropertyEditor); procedure CheckEdit(PropertyEditor: TPropertyEditor); procedure EditProperty(PropertyEditor: TPropertyEditor; var Continue, FreeEditor: Boolean); override; -////////////////////////////////////////////////////////// -{$ENDIF} // -////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////// +{$ENDIF} // + ////////////////////////////////////////////////////////// public procedure Edit; override; end; - TKOLOnEventPropEditor = class( TMethodProperty ) + TKOLOnEventPropEditor = class(TMethodProperty) private protected public @@ -1295,26 +1100,26 @@ type TKOLMenu = class; TKOLMenuItem = class; - TKOLAccPrefixes = ( kapShift, kapControl, kapAlt, kapNoinvert ); + TKOLAccPrefixes = (kapShift, kapControl, kapAlt, kapNoinvert); TKOLAccPrefix = set of TKOLAccPrefixes; - TVirtualKey = ( vkNotPresent, vkBACK, vkTAB, vkCLEAR, vkENTER, vkPAUSE, vkCAPITAL, - vkESCAPE, vkSPACE, vkPGUP, vkPGDN, vkEND, vkHOME, vkLEFT, - vkUP, vkRIGHT, vkDOWN, vkSELECT, vkEXECUTE, vkPRINTSCREEN, - vkINSERT, vkDELETE, vkHELP, vk0, vk1, vk2, vk3, vk4, vk5, - vk6, vk7, vk8, vk9, vkA, vkB, vkC, vkD, vkE, vkF, vkG, vkH, - vkI, vkJ, vkK, vkL, vkM, vkN, vkO, vkP, vkQ, vkR, vkS, vkT, - vkU, vkV, vkW, vkX, vkY, vkZ, vkLWIN, vkRWIN, vkAPPS, - vkNUM0, vkNUM1, vkNUM2, vkNUM3, vkNUM4, vkNUM5, vkNUM6, - vkNUM7, vkNUM8, vkNUM9, vkMULTIPLY, vkADD, vkSEPARATOR, - vkSUBTRACT, vkDECIMAL, vkDIVIDE, vkF1, vkF2, vkF3, vkF4, - vkF5, vkF6, vkF7, vkF8, vkF9, vkF10, vkF11, vkF12, vkF13, - vkF14, vkF15, vkF16, vkF17, vkF18, vkF19, vkF20, vkF21, - vkF22, vkF23, vkF24, vkNUMLOCK, vkSCROLL, vkATTN, vkCRSEL, - vkEXSEL, vkEREOF, vkPLAY, vkZOOM, vkPA1, vkOEMCLEAR ); + TVirtualKey = (vkNotPresent, vkBACK, vkTAB, vkCLEAR, vkENTER, vkPAUSE, vkCAPITAL, + vkESCAPE, vkSPACE, vkPGUP, vkPGDN, vkEND, vkHOME, vkLEFT, + vkUP, vkRIGHT, vkDOWN, vkSELECT, vkEXECUTE, vkPRINTSCREEN, + vkINSERT, vkDELETE, vkHELP, vk0, vk1, vk2, vk3, vk4, vk5, + vk6, vk7, vk8, vk9, vkA, vkB, vkC, vkD, vkE, vkF, vkG, vkH, + vkI, vkJ, vkK, vkL, vkM, vkN, vkO, vkP, vkQ, vkR, vkS, vkT, + vkU, vkV, vkW, vkX, vkY, vkZ, vkLWIN, vkRWIN, vkAPPS, + vkNUM0, vkNUM1, vkNUM2, vkNUM3, vkNUM4, vkNUM5, vkNUM6, + vkNUM7, vkNUM8, vkNUM9, vkMULTIPLY, vkADD, vkSEPARATOR, + vkSUBTRACT, vkDECIMAL, vkDIVIDE, vkF1, vkF2, vkF3, vkF4, + vkF5, vkF6, vkF7, vkF8, vkF9, vkF10, vkF11, vkF12, vkF13, + vkF14, vkF15, vkF16, vkF17, vkF18, vkF19, vkF20, vkF21, + vkF22, vkF23, vkF24, vkNUMLOCK, vkSCROLL, vkATTN, vkCRSEL, + vkEXSEL, vkEREOF, vkPLAY, vkZOOM, vkPA1, vkOEMCLEAR); TKOLAccelerator = class(TPersistent) private - FOwner: TComponent; + fOwner: TComponent; FPrefix: TKOLAccPrefix; FKey: TVirtualKey; procedure SetKey(const Value: TVirtualKey); @@ -1322,13 +1127,13 @@ type protected public procedure Change; - function AsText: String; + function AsText: string; published property Prefix: TKOLAccPrefix read FPrefix write SetPrefix; property Key: TVirtualKey read FKey write SetKey; end; - TKOLAcceleratorPropEditor = class( TPropertyEditor ) + TKOLAcceleratorPropEditor = class(TPropertyEditor) private protected public @@ -1340,15 +1145,15 @@ type TKOLMenuItem = class(TComponent) private - FCaption: TDelphiString; + fCaption: TDelphiString; FBitmap: TBitmap; FSubitems: TList; FChecked: Boolean; //FRadioItem: Boolean; - FEnabled: Boolean; - FVisible: Boolean; + fEnabled: Boolean; + fVisible: Boolean; FOnMenu: TOnMenuItem; - FOnMenuMethodName: String; + FOnMenuMethodName: string; FSeparator: Boolean; FAccelerator: TKOLAccelerator; FParent: TComponent; @@ -1394,74 +1199,71 @@ type protected FDestroying: Boolean; FSubItemCount: Integer; - procedure SetName( const NewName: TComponentName ); override; - procedure DefProps( const Prefix: String; Filer: TFiler ); - procedure LoadName( R: TReader ); - procedure SaveName( W: TWriter ); - procedure LoadCaption( R: TReader ); - procedure SaveCaption( W: TWriter ); - procedure LoadEnabled( R: TReader ); - procedure SaveEnabled( W: TWriter ); - procedure LoadVisible( R: TReader ); - procedure SaveVisible( W: TWriter ); - procedure LoadChecked( R: TReader ); - procedure SaveChecked( W: TWriter ); - procedure LoadRadioGroup( R: TReader ); - procedure SaveRadioGroup( W: TWriter ); - procedure LoadOnMenu( R: TReader ); - procedure SaveOnMenu( W: TWriter ); - procedure LoadSubItemCount( R: TReader ); - procedure SaveSubItemCount( W: TWriter ); - procedure LoadBitmap( R: TReader ); - procedure SaveBitmap( W: TWriter ); - procedure LoadSeparator( R: TReader ); - procedure SaveSeparator( W: TWriter ); - procedure LoadAccel( R: TReader ); - procedure SaveAccel( W: TWriter ); - procedure LoadWindowMenu( R: TReader ); - procedure SaveWindowMenu( W: TWriter ); - procedure LoadHelpContext( R: TReader ); - procedure SaveHelpContext( W: TWriter ); - procedure LoadOwnerDraw( R: TReader ); - procedure SaveOwnerDraw( W: TWriter ); - procedure LoadMenuBreak( R: TReader ); - procedure SaveMenuBreak( W: TWriter ); - procedure LoadTag( R: TReader ); - procedure SaveTag( W: TWriter ); - procedure LoadDefault( R: TReader ); - procedure SaveDefault( W: TWriter ); - procedure LoadAction( R: TReader ); - procedure SaveAction( W: TWriter ); + procedure SetName(const NewName: TComponentName); override; + procedure DefProps(const Prefix: string; Filer: TFiler); + procedure LoadName(R: TReader); + procedure SaveName(W: TWriter); + procedure LoadCaption(R: TReader); + procedure SaveCaption(W: TWriter); + procedure LoadEnabled(R: TReader); + procedure SaveEnabled(W: TWriter); + procedure LoadVisible(R: TReader); + procedure SaveVisible(W: TWriter); + procedure LoadChecked(R: TReader); + procedure SaveChecked(W: TWriter); + procedure LoadRadioGroup(R: TReader); + procedure SaveRadioGroup(W: TWriter); + procedure LoadOnMenu(R: TReader); + procedure SaveOnMenu(W: TWriter); + procedure LoadSubItemCount(R: TReader); + procedure SaveSubItemCount(W: TWriter); + procedure LoadBitmap(R: TReader); + procedure SaveBitmap(W: TWriter); + procedure LoadSeparator(R: TReader); + procedure SaveSeparator(W: TWriter); + procedure LoadAccel(R: TReader); + procedure SaveAccel(W: TWriter); + procedure LoadWindowMenu(R: TReader); + procedure SaveWindowMenu(W: TWriter); + procedure LoadHelpContext(R: TReader); + procedure SaveHelpContext(W: TWriter); + procedure LoadOwnerDraw(R: TReader); + procedure SaveOwnerDraw(W: TWriter); + procedure LoadMenuBreak(R: TReader); + procedure SaveMenuBreak(W: TWriter); + procedure LoadTag(R: TReader); + procedure SaveTag(W: TWriter); + procedure LoadDefault(R: TReader); + procedure SaveDefault(W: TWriter); + procedure LoadAction(R: TReader); + procedure SaveAction(W: TWriter); procedure Notification(AComponent: TComponent; Operation: TOperation); override; -// procedure Loaded; override; + // procedure Loaded; override; public procedure Change; property Parent: TComponent read FParent; - constructor Create( AOwner: TComponent; AParent, Before: TKOLMenuItem ); reintroduce; + constructor Create(AOwner: TComponent; AParent, Before: TKOLMenuItem); reintroduce; destructor Destroy; override; property MenuComponent: TKOLMenu read GetMenuComponent; property UplevelMenuItem: TKOLMenuItem read GetUplevel; property Count: Integer read GetCount; - property SubItems[ Idx: Integer ]: TKOLMenuItem read GetSubItems; + property SubItems[Idx: Integer]: TKOLMenuItem read GetSubItems; procedure MoveUp; procedure MoveDown; - procedure SetupTemplate( SL: TStringList; FirstItem: Boolean; KF: TKOLForm ); - function P_SetupTemplate( SL: TStringList; DoAdd: Boolean ): Integer; - procedure SetupAttributes( SL: TStringList; const MenuName: String ); - procedure P_SetupAttributes( SL: TStringList; const MenuName: String ); - procedure SetupAttributesLast( SL: TStringList; const MenuName: String ); - procedure P_SetupAttributesLast( SL: TStringList; const MenuName: String ); + procedure SetupTemplate(SL: TStringList; FirstItem: Boolean; KF: TKOLForm); + procedure SetupAttributes(SL: TStringList; const MenuName: string); + procedure SetupAttributesLast(SL: TStringList; const MenuName: string); procedure DesignTimeClick; function CheckOnMenuMethodExists: Boolean; published property Tag: Integer read FTag write SetTag; - property Caption: TDelphiString read FCaption write SetCaption; - property bitmap: TBitmap read FBitmap write SetBitmap; + property Caption: TDelphiString read fCaption write SetCaption; + property Bitmap: TBitmap read FBitmap write SetBitmap; property bitmapChecked: TBitmap read FbitmapChecked write SetbitmapChecked; property bitmapItem: TBitmap read FbitmapItem write SetbitmapItem; property default: Boolean read Fdefault write Setdefault; - property enabled: Boolean read FEnabled write SetEnabled; - property visible: Boolean read FVisible write SetVisible; + property Enabled: Boolean read fEnabled write SetEnabled; + property Visible: Boolean read fVisible write SetVisible; property checked: Boolean read FChecked write SetChecked; property radioGroup: Integer read FRadioGroup write SetRadioGroup; property separator: Boolean read FSeparator write SetSeparator; @@ -1475,12 +1277,12 @@ type // OnMenuItem events, and also in utility methods to access item // properties at run time). property itemindex: Integer read GetItemIndex write SetItemIndex_Dummy - stored False; + stored False; property WindowMenu: Boolean read FWindowMenu write SetWindowMenu; property HelpContext: Integer read FHelpContext write SetHelpContext; property action: TKOLAction read Faction write Setaction; property AllowBitmapCompression: Boolean read FAllowBitmapCompression write SetAllowBitmapCompression - default TRUE; + default True; end; TKOLMenu = class(TKOLObj) @@ -1493,7 +1295,7 @@ type FgenerateSeparatorConstants: Boolean; FOnMeasureItem: TOnMeasureItem; FOnDrawItem: TOnDrawItem; - FOwnerDraw: Boolean; + FownerDraw: Boolean; function GetCount: Integer; function GetItems(Idx: Integer): TKOLMenuItem; procedure SetOnMenuItem(const Value: TOnMenuItem); @@ -1503,29 +1305,24 @@ type procedure SetgenerateSeparatorConstants(const Value: Boolean); procedure SetOnMeasureItem(const Value: TOnMeasureItem); procedure SetOnDrawItem(const Value: TOnDrawItem); - procedure SetOwnerDraw(const Value: Boolean); + procedure SetownerDraw(const Value: Boolean); function AllItemsAreOwnerDraw: Boolean; protected FItemCount: Integer; FUpdateDisabled: Boolean; FUpdateNeeded: Boolean; - procedure DefineProperties( Filer: TFiler ); override; - procedure LoadItemCount( R: TReader ); - procedure SaveItemCount( W: TWriter ); - procedure SetName( const NewName: TComponentName ); override; - function OnMenuItemMethodName( for_pcode: Boolean ): String; + procedure DefineProperties(Filer: TFiler); override; + procedure LoadItemCount(R: TReader); + procedure SaveItemCount(W: TWriter); + procedure SetName(const NewName: TComponentName); override; + function OnMenuItemMethodName: string; public ItemsInStack: Integer; // Methods to generate code for creating menu: - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirstFinalizy( SL: TStringList ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; function NotAutoFree: Boolean; override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; procedure UpdateDisable; procedure UpdateEnable; @@ -1534,14 +1331,13 @@ type ActiveDesign: TKOLMenuDesign; procedure Change; override; procedure UpdateDesign; - property Items[ Idx: Integer ]: TKOLMenuItem read GetItems; + property Items[Idx: Integer]: TKOLMenuItem read GetItems; property Count: Integer read GetCount; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - function NameAlreadyUsed( const ItemName: String ): Boolean; - procedure SaveTo( WR: TWriter ); - procedure DoGenerateConstants( SL: TStringList ); override; - function Pcode_Generate: Boolean; override; + function NameAlreadyUsed(const ItemName: string): Boolean; + procedure SaveTo(WR: TWriter); + procedure DoGenerateConstants(SL: TStringList); override; published property OnMenuItem: TOnMenuItem read FOnMenuItem write SetOnMenuItem; property OnUncheckRadioItem: TOnMenuItem read FOnUncheckRadioItem write SetOnUncheckRadioItem; @@ -1550,7 +1346,7 @@ type property generateSeparatorConstants: Boolean read FgenerateSeparatorConstants write SetgenerateSeparatorConstants; property OnMeasureItem: TOnMeasureItem read FOnMeasureItem write SetOnMeasureItem; property OnDrawItem: TOnDrawItem read FOnDrawItem write SetOnDrawItem; - property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw; + property ownerDraw: Boolean read FownerDraw write SetownerDraw; end; TKOLMainMenu = class(TKOLMenu) @@ -1559,9 +1355,9 @@ type FOldWndProc: Pointer; procedure Loaded; override; procedure UpdateMenu; override; - procedure RestoreWndProc( Wnd: HWnd ); + procedure RestoreWndProc(Wnd: HWnd); public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Change; override; procedure RebuildMenubar; @@ -1569,11 +1365,11 @@ type property Localizy; end; - TPopupMenuFlag = ( tpmVertical, tpmRightButton, tpmCenterAlign, tpmRightAlign, - tpmVCenterAlign, tpmBottomAlign, tpmHorPosAnimation, - tpmHorNegAnimation, tpmVerPosAnimation, tpmVerNegAnimation, - tpmNoAnimation, {+ecm} tpmReturnCmd {/+ecm} ); - TPopupMenuFlags = Set of TPopupMenuFlag; + TPopupMenuFlag = (tpmVertical, tpmRightButton, tpmCenterAlign, tpmRightAlign, + tpmVCenterAlign, tpmBottomAlign, tpmHorPosAnimation, + tpmHorNegAnimation, tpmVerPosAnimation, tpmVerNegAnimation, + tpmNoAnimation, {+ecm} tpmReturnCmd {/+ecm}); + TPopupMenuFlags = set of TPopupMenuFlag; TKOLPopupMenu = class(TKOLMenu) protected @@ -1582,20 +1378,15 @@ type procedure SetOnPopup(const Value: TOnEvent); procedure SetFlags(const Value: TPopupMenuFlags); public - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - public - procedure P_DoProvideFakeType( SL: TStringList ); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; published property Flags: TPopupMenuFlags read FFlags write SetFlags; property OnPopup: TOnEvent read FOnPopup write SetOnPopup; property Localizy; end; - TKOLMenuEditor = class( TComponentEditor ) + TKOLMenuEditor = class(TComponentEditor) private protected public @@ -1605,7 +1396,7 @@ type function GetVerbCount: Integer; override; end; - TKOLOnItemPropEditor = class( TMethodProperty ) + TKOLOnItemPropEditor = class(TMethodProperty) private protected public @@ -1613,73 +1404,43 @@ type procedure SetValue(const AValue: string); override; end; - - - - - - - - - - - - - - - - - - - - - - // Align property (names are another then in VCL). // Свойство выравнивания контрола относительно клиентской части родителького // контрола. - TKOLAlign = ( caNone, caLeft, caTop, caRight, caBottom, caClient ); + TKOLAlign = (caNone, caLeft, caTop, caRight, caBottom, caClient); // Text alignment property. // Свойство выравнивания текста по горизонтали. Хотя и определено для всех // контролов, актуально только для кнопок и меток. - TTextAlign = ( taLeft, taRight, taCenter ); + TTextAlign = (taLeft, taRight, taCenter); // Text vertical alignment property. // Свойство выравнивания текста по вертикали. Хотя и определено в KOL для // всех контролов, актуально только для кнопок и меток. - TVerticalAlign = ( vaTop, vaCenter, vaBottom ); + TVerticalAlign = (vaTop, vaCenter, vaBottom); - - - - - - - - -{YS}//-------------------------------------------------------------- -// TKOLVCLParent is KOL control that represents VCL parent control. + {YS}//-------------------------------------------------------------- + // TKOLVCLParent is KOL control that represents VCL parent control. PKOLVCLParent = ^TKOLVCLParent; - TKOLVCLParent = object(kol.TControl) + TKOLVCLParent = object(KOL.TControl) public OldVCLWndProc: TWndMethod; - procedure AttachHandle(AHandle: HWND); + procedure AttachHandle(AHandle: HWnd); procedure AssignDynHandlers(Src: PKOLVCLParent); end; TKOLCtrlWrapper = class(TCustomControl) protected - FAllowSelfPaint: boolean; - FAllowCustomPaint: boolean; - FAllowPostPaint: boolean; + FAllowSelfPaint: Boolean; + FAllowCustomPaint: Boolean; + FAllowPostPaint: Boolean; procedure Change; virtual; protected {$IFNDEF NOT_USE_KOLCtrlWrapper} FKOLParentCtrl: PKOLVCLParent; - FRealParent: boolean; - FKOLCtrlNeeded: boolean; + FRealParent: Boolean; + FKOLCtrlNeeded: Boolean; procedure RemoveParentAttach; procedure CallKOLCtrlWndProc(var Message: TMessage); @@ -1687,55 +1448,40 @@ type protected FKOLCtrl: PControl; - procedure SetParent( Value: TWinControl ); override; + procedure SetParent(Value: TWinControl); override; procedure WndProc(var Message: TMessage); override; procedure DestroyWindowHandle; override; procedure DestroyWnd; override; procedure CreateWnd; override; procedure PaintWindow(DC: HDC); override; - procedure SetAllowSelfPaint(const Value: boolean); virtual; + procedure SetAllowSelfPaint(const Value: Boolean); virtual; // Override method CreateKOLControl and create instance of real KOL control within it. // Example: FKOLCtrl := NewGroupBox(KOLParentCtrl, ''); - procedure CreateKOLControl(Recreating: boolean); virtual; + procedure CreateKOLControl(Recreating: Boolean); virtual; // if False control does not paint itself - property AllowSelfPaint: boolean read FAllowSelfPaint write SetAllowSelfPaint; + property AllowSelfPaint: Boolean read FAllowSelfPaint write SetAllowSelfPaint; // Update control state according to AllowSelfPaint property procedure UpdateAllowSelfPaint; // if False and assigned FKOLCtrl then Paint method is not called for control - property AllowCustomPaint: boolean read FAllowCustomPaint write FAllowCustomPaint; + property AllowCustomPaint: Boolean read FAllowCustomPaint write FAllowCustomPaint; // if True and assigned FKOLCtrl then Paint method is called for control - property AllowPostPaint: boolean read FAllowPostPaint write FAllowPostPaint; + property AllowPostPaint: Boolean read FAllowPostPaint write FAllowPostPaint; // Called when KOL control has been recreated. You must set all visual properties // of KOL control within this method. procedure KOLControlRecreated; virtual; // Parent of real KOL control property KOLParentCtrl: PControl read GetKOLParentCtrl; public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; procedure DefaultHandler(var Message); override; procedure Invalidate; override; {$ENDIF NOT_USE_KOLCtrlWrapper} end; -{YS}//-------------------------------------------------------------- - - - - - - - - - - - - - - - TOnSetBounds = procedure( Sender: TObject; var NewBounds: TRect ) of object; - + {YS}//-------------------------------------------------------------- + TOnSetBounds = procedure(Sender: TObject; var NewBounds: TRect) of object; //============================================================================ // BASE CLASS FOR ALL MIRROR CONTROLS. @@ -1747,13 +1493,12 @@ type // Все контролы в KOL представлены в едином объекотном типе TControl. // Нам никто не мешает тем не менее в визуальном варианте иметь свой // собственный зеркальный класс, соответствующий каждому контролу. - TKOLCustomControl = class( TKOLCtrlWrapper ) + TKOLCustomControl = class(TKOLCtrlWrapper) private FLikeSpeedButton: Boolean; procedure SetLikeSpeedButton(const Value: Boolean); public - function Generate_SetSize: String; virtual; - function P_Generate_SetSize: String; virtual; + function Generate_SetSize: string; virtual; protected fClsStyle: DWORD; fExStyle: DWORD; @@ -1785,8 +1530,8 @@ type FOnDeadChar: TOnChar; FOnKeyUp: TOnKey; FOnKeyDown: TOnKey; - FFont: TKOLFont; - FBrush: TKOLBrush; + fFont: TKOLFont; + fBrush: TKOLBrush; FTransparent: Boolean; FOnChange: TOnEvent; FDoubleBuffered: Boolean; @@ -1815,15 +1560,15 @@ type fOnMouseDblClk: TOnMouse; FOnRE_InsOvrMode_Change: TOnEvent; FOnRE_OverURL: TOnEvent; - FCursor: String; + FCursor: string; FFalse: Boolean; FMarginTop: Integer; FMarginLeft: Integer; FMarginRight: Integer; FMarginBottom: Integer; - {$IFDEF KOL_MCK} +{$IFDEF KOL_MCK} //FParent: PControl; - {$ENDIF} +{$ENDIF} FOnEraseBkgnd: TOnPaint; FEraseBackground: Boolean; FOnTVSelChanging: TOnTVSelChanging; @@ -1854,8 +1599,8 @@ type FIsGeneratePosition: Boolean; Faction: TKOLAction; FWindowed: Boolean; - FAnchorTop: Boolean; //+Sormart - FAnchorLeft: Boolean;//+Sormart + FAnchorTop: Boolean; //+Sormart + FAnchorLeft: Boolean; //+Sormart FAnchorRight: Boolean; FAnchorBottom: Boolean; FpopupMenu: TKOLPopupMenu; @@ -1932,7 +1677,7 @@ type procedure SetOnMouseDblClk(const Value: TOnMouse); procedure SetOnRE_InsOvrMode_Change(const Value: TOnEvent); procedure SetOnRE_OverURL(const Value: TOnEvent); - procedure SetCursor(const Value: String); + procedure SetCursor(const Value: string); procedure SetMarginBottom(const Value: Integer); procedure SetMarginLeft(const Value: Integer); procedure SetMarginRight(const Value: Integer); @@ -1969,7 +1714,7 @@ type procedure SetIsGeneratePosition(const Value: Boolean); procedure Setaction(const Value: TKOLAction); procedure SetAnchorLeft(const Value: Boolean); //+Sormart - procedure SetAnchorTop(const Value: Boolean); //+Sormart + procedure SetAnchorTop(const Value: Boolean); //+Sormart procedure SetAnchorBottom(const Value: Boolean); procedure SetAnchorRight(const Value: Boolean); procedure SetpopupMenu(const Value: TKOLPopupMenu); @@ -1977,18 +1722,17 @@ type protected procedure SetWindowed(const Value: Boolean); virtual; protected - FHint: String; + FHint: string; FAcceptChildren: Boolean; FMouseTransparent: Boolean; FHasScrollbarsToOverride: Boolean; FOverrideScrollbars: Boolean; - procedure SetHint(const Value: String); + procedure SetHint(const Value: string); procedure SetAcceptChildren(const Value: Boolean); procedure SetMouseTransparent(const Value: Boolean); procedure SetOverrideScrollbars(const Value: Boolean); protected FNameSetuped: Boolean; - fP_NameSetuped: Boolean; FVerticalAlign: TVerticalAlign; FTabStop: Boolean; @@ -1998,7 +1742,7 @@ type DefaultHeight: Integer; FOnSetBounds: TOnSetBounds; DefaultMarginLeft, DefaultMarginTop, DefaultMarginRight, - DefaultMarginBottom: Integer; + DefaultMarginBottom: Integer; DefaultAutoSize: Boolean; fUpdated: Boolean; @@ -2025,10 +1769,10 @@ type procedure SetHasBorder(const Value: Boolean); virtual; procedure AutoSizeNow; virtual; function AutoSizeRunTime: Boolean; virtual; - function AutoWidth( Canvas: graphics.TCanvas ): Integer; virtual; - function AutoHeight( Canvas: graphics.TCanvas ): Integer; virtual; + function AutoWidth(Canvas: Graphics.TCanvas): Integer; virtual; + function AutoHeight(Canvas: Graphics.TCanvas): Integer; virtual; function ControlIndex: Integer; - function AdditionalUnits: String; virtual; + function AdditionalUnits: string; virtual; function TabStopByDefault: Boolean; virtual; procedure SetMargin(const Value: Integer); virtual; @@ -2045,7 +1789,7 @@ type function ParentControlUseAlign: Boolean; function ParentKOLControl: TComponent; - function OwnerKOLForm( AOwner: TComponent ): TKOLForm; + function OwnerKOLForm(AOwner: TComponent): TKOLForm; function ParentKOLForm: TKOLForm; function ParentForm: TForm; function ParentBounds: TRect; @@ -2053,12 +1797,10 @@ type function PrevBounds: TRect; function ParentMargin: Integer; - function TypeName: String; virtual; - procedure BeforeFontChange( SL: TStrings; const AName, Prefix: String ); virtual; - procedure P_BeforeFontChange( SL: TStrings; const AName, Prefix: String ); virtual; - function FontPropName: String; virtual; - procedure AfterFontChange( SL: TStrings; const AName, Prefix: String ); virtual; - procedure P_AfterFontChange( SL: TStrings; const AName, Prefix: String ); virtual; + function TypeName: string; virtual; + procedure BeforeFontChange(SL: TStrings; const AName, Prefix: string); virtual; + function FontPropName: string; virtual; + procedure AfterFontChange(SL: TStrings; const AName, Prefix: string); virtual; // Overriden to exclude prefix 'KOL' from names of all controls, dropped // onto form at design time. (E.g., when TKOLButton is dropped, its name @@ -2067,9 +1809,9 @@ type // Процедура SetName переопределена для того, чтобы выбрасывать префикс // KOL, присутствующий в названиях зеркальных классов, из вновь созданных // имен контролов. Например, TKOLButton -> Button1, а не KOLButton1. - procedure SetName( const NewName: TComponentName ); override; + procedure SetName(const NewName: TComponentName); override; - procedure SetParent( Value: TWinControl ); override; + procedure SetParent(Value: TWinControl); override; // This method is created only when control is just dropped onto form. // For mirror classes, reflecting to controls, which should display @@ -2087,7 +1829,7 @@ type property VerticalAlign: TVerticalAlign read FVerticalAlign write SetVerticalAlign; function VerticalAlignAsKOLVerticalAlign: Integer; - function RefName: String; virtual; + function RefName: string; virtual; function IsCursorDefault: Boolean; virtual; // Is called to generate constructor of control and operators to @@ -2096,19 +1838,14 @@ type // Процедура, которая добавляет в конец SL (:TStringList) операторы // создания объекта и те операторы настройки его свойств, которые // должны исполняться немедленно вслед за конструированием объекта: - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); virtual; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); virtual; - procedure SetupConstruct( SL: TStringList; const AName, AParent, Prefix: String ); virtual; - procedure SetupSetUnicode( SL: TStringList; const AName: String ); virtual; - procedure P_SetupConstruct( SL: TStringList; const AName, AParent, Prefix: String ); virtual; - procedure SetupName( SL: TStringList; const AName, AParent, - Prefix: String ); - procedure P_SetupName( SL: TStringList ); - procedure DoGenerateConstants( SL: TStringList ); virtual; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); virtual; + procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: string); virtual; + procedure SetupSetUnicode(SL: TStringList; const AName: string); virtual; + procedure SetupName(SL: TStringList; const AName, AParent, Prefix: string); + procedure DoGenerateConstants(SL: TStringList); virtual; - procedure SetupTabStop( SL: TStringList; const AName: String ); virtual; - procedure SetupTabOrder( SL: TStringList; const AName: String ); - procedure P_SetupTabStop( SL: TStringList; const AName: String ); virtual; + procedure SetupTabStop(SL: TStringList; const AName: string); virtual; + procedure SetupTabOrder(SL: TStringList; const AName: string); function DefaultColor: TColor; virtual; {* by default, clBtnFace. Override it for controls, having another Color as default. Usually these are controls, which main purpose is @@ -2133,17 +1870,11 @@ type {* TRUE, if the Color can be changed (default). This function is overriden for TKOLButton, which represents standard GDI button and can not have other color then clBtnFace. } - procedure SetupColor( SL: TStrings; const AName: String ); virtual; + procedure SetupColor(SL: TStrings; const AName: string); virtual; function SetupColorFirst: Boolean; virtual; - procedure P_SetupColor( SL: TStrings; const AName: String; var ControlInStack: Boolean ); virtual; - //function RunTimeFont: TKOLFont; function Get_ParentFont: TKOLFont; - procedure SetupFont( SL: TStrings; const AName: String ); virtual; - procedure P_SetupFont( SL: TStrings; const AName: String ); virtual; - procedure SetupTextAlign( SL: TStrings; const AName: String ); virtual; - procedure P_SetupTextAlign( SL: TStrings; const AName: String ); virtual; - - procedure P_ProvideFakeType( SL: TStrings; const Declaration: String ); + procedure SetupFont(SL: TStrings; const AName: string); virtual; + procedure SetupTextAlign(SL: TStrings; const AName: string); virtual; public ControlInStack: Boolean; protected @@ -2154,10 +1885,7 @@ type // Вызывается уже после генерации конструирования всех // дочерних контролов и объектов формы - для генерации какой-либо // завершающей инициализации: - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - virtual; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); virtual; // Method, which should return string with parameters for constructor // call. I.e. braces content in operator @@ -2166,8 +1894,7 @@ type // Функция, которая формирует правильные параметры для оператора // конструирования объекта (т.е. то, что будет в круглых скобках // в операторе: Result.Button1 := NewButton( ... )...; - function SetupParams( const AName, AParent: TDelphiString ): TDelphiString; virtual; - function P_SetupParams( const AName, AParent: String; var nparams: Integer ): String; virtual; + function SetupParams(const AName, AParent: TDelphiString): TDelphiString; virtual; // Method to assign values to assigned events. Is called in SetupFirst // and actually should call DoAssignEvents, passing a list of (additional) @@ -2176,20 +1903,15 @@ type // Процедура присваивания значений назначенным событиям. Вызывается из // SetupFirst и фактически должна (после вызова inherited) передать // в процедуру DoAssignEvents список (дополнительных) событий. - procedure AssignEvents( SL: TStringList; const AName: String ); virtual; - function P_AssignEvents( SL: TStringList; const AName: String; - CheckOnly: Boolean ): Boolean; virtual; + procedure AssignEvents(SL: TStringList; const AName: string); virtual; protected FEventDefs: TStringList; FAssignOnlyUserEvents: Boolean; FAssignOnlyWinEvents: Boolean; public - procedure DefineFormEvents( const EventNamesAndDefs: array of String ); - procedure DoAssignEvents( SL: TStringList; const AName: String; - const EventNames: array of PChar; const EventHandlers: array of Pointer ); - function P_DoAssignEvents( SL: TStringList; const AName: String; - const EventNames: array of PChar; const EventHandlers: array of Pointer; - const EventAssignProc: array of Boolean; CheckOnly: Boolean ): Boolean; + procedure DefineFormEvents(const EventNamesAndDefs: array of string); + procedure DoAssignEvents(SL: TStringList; const AName: string; + const EventNames: array of PChar; const EventHandlers: array of Pointer); // This method allows to initializy part of properties as a sequence // of "transparent" methods calls (see KOL documentation). @@ -2197,8 +1919,7 @@ type // Функция, которая инициализацию части свойств выполняет в виде // последовательности вызовов "прозрачных" методов (см. описание KOL) function ParentBorder: Integer; - function GenerateTransparentInits: String; virtual; - function P_GenerateTransparentInits: String; virtual; + function GenerateTransparentInits: string; virtual; property ShadowDeep: Integer read FShadowDeep write SetShadowDeep; @@ -2230,7 +1951,7 @@ type property actualLeft: Integer read GetActualLeft write SetActualLeft; property actualTop: Integer read GetActualTop write SetActualTop; - procedure WantTabs( Want: Boolean ); virtual; + procedure WantTabs(Want: Boolean); virtual; function CanNotChangeFontColor: Boolean; virtual; // Painting of mirror class object by default. It is possible to override it @@ -2258,57 +1979,55 @@ type function PaintType: TPaintType; function WYSIWIGPaintImplemented: Boolean; virtual; - procedure PrepareCanvasFontForWYSIWIGPaint( ACanvas: TCanvas ); + procedure PrepareCanvasFontForWYSIWIGPaint(ACanvas: TCanvas); function NoDrawFrame: Boolean; virtual; //-- by Alexander Shakhaylo - to allow sort objects - function CompareFirst(c, n: string): boolean; virtual; + function CompareFirst(c, N: string): Boolean; virtual; procedure Loaded; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; - function StringConstant( const Propname, Value: TDelphiString ): TDelphiString; - function P_StringConstant( const Propname, Value: String ): String; - function BestEventName: String; virtual; + function StringConstant(const Propname, Value: TDelphiString): TDelphiString; + function BestEventName: string; virtual; function GetDefaultControlFont: HFONT; virtual; procedure KOLControlRecreated; - {$IFNDEF NOT_USE_KOLCTRLWRAPPER} - override; - {$ELSE NOT_USE_KOLCTRLWRAPPER} - virtual; - procedure CreateKOLControl(Recreating: boolean); virtual; +{$IFNDEF NOT_USE_KOLCTRLWRAPPER} + override; +{$ELSE NOT_USE_KOLCTRLWRAPPER} + virtual; + procedure CreateKOLControl(Recreating: Boolean); virtual; procedure UpdateAllowSelfPaint; protected FKOLCtrl: PControl; FKOLParentCtrl: PControl; property KOLParentCtrl: PControl read FKOLParentCtrl; - {$ENDIF NOT_USE_KOLCTRLWRAPPER} - property AllowPostPaint: boolean read FAllowPostPaint write FAllowPostPaint; - property AllowSelfPaint: boolean read FAllowSelfPaint write FAllowSelfPaint; - property AllowCustomPaint: boolean read FAllowCustomPaint write FAllowCustomPaint; +{$ENDIF NOT_USE_KOLCTRLWRAPPER} + property AllowPostPaint: Boolean read FAllowPostPaint write FAllowPostPaint; + property AllowSelfPaint: Boolean read FAllowSelfPaint write FAllowSelfPaint; + property AllowCustomPaint: Boolean read FAllowCustomPaint write FAllowCustomPaint; property WordWrap: Boolean read FWordWrap write SetWordWrap; // only for graphic button (Windowed = FALSE) property LikeSpeedButton: Boolean read FLikeSpeedButton write SetLikeSpeedButton; public - function Pcode_Generate: Boolean; virtual; property IsGenerateSize: Boolean read FIsGenerateSize write SetIsGenerateSize; property IsGeneratePosition: Boolean read FIsGeneratePosition write SetIsGeneratePosition; procedure Change; override; - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; destructor Destroy; override; - procedure AddToNotifyList( Sender: TComponent ); + procedure AddToNotifyList(Sender: TComponent); // procedure which is called by linked components, when those are // renamed or removed at design time. - procedure NotifyLinkedComponent( Sender: TObject; Operation: TNotifyOperation ); - virtual; - procedure DoNotifyLinkedComponents( Operation: TNotifyOperation ); + procedure NotifyLinkedComponent(Sender: TObject; Operation: TNotifyOperation); + virtual; + procedure DoNotifyLinkedComponents(Operation: TNotifyOperation); property Style: DWORD read fStyle write SetStyle; property ExStyle: DWORD read fExStyle write SetExStyle; property ClsStyle: DWORD read fClsStyle write SetClsStyle; procedure Click; override; - procedure SetBounds( aLeft, aTop, aWidth, aHeight: Integer ); override; - procedure ReAlign( ParentOnly: Boolean ); + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + procedure ReAlign(ParentOnly: Boolean); property Transparent: Boolean read FTransparent write SetTransparent; property TabStop: Boolean read FTabStop write SetTabStop; @@ -2340,7 +2059,7 @@ type property autoSize: Boolean read FautoSize write Set_autoSize; property HasBorder: Boolean read FHasBorder write SetHasBorder; property EditTabChar: Boolean read FEditTabChar write SetEditTabChar; - //published + //published property TabOrder: Integer read GetTabOrder write SetTabOrder; // This section contains published properties, available in Object // Inspector at design time. @@ -2362,7 +2081,7 @@ type property MaxWidth: Integer read FMaxWidth write SetMaxWidth; property MaxHeight: Integer read FMaxHeight write SetMaxHeight; - property Cursor_: String read FCursor write SetCursor; + property Cursor_: string read FCursor write SetCursor; property Cursor: Boolean read FFalse; property PlaceDown: Boolean read fPlaceDown write SetPlaceDown; @@ -2388,8 +2107,8 @@ type property Color: TColor read Get_Color write Set_Color; property parentColor: Boolean read GetParentColor write SetparentColor; - property Font: TKOLFont read FFont write SetFont; - property Brush: TKOLBrush read FBrush write SetBrush; + property Font: TKOLFont read fFont write SetFont; + property Brush: TKOLBrush read fBrush write SetBrush; property parentFont: Boolean read GetParentFont write SetParentFont; property OnClick: TOnEvent read fOnClick write SetOnClick; @@ -2413,7 +2132,7 @@ type property EraseBackground: Boolean read FEraseBackground write SetEraseBackground; property Tag: Integer read FTag write SetTag; - property Hint: String read FHint write SetHint; + property Hint: string read FHint write SetHint; property HelpContext: Integer read FHelpContext1 write SetHelpContext; property Localizy: TLocalizyOptions read FLocalizy write SetLocalizy; @@ -2428,25 +2147,20 @@ type published property IgnoreDefault: Boolean read FIgnoreDefault write SetIgnoreDefault; property AnchorLeft: Boolean read FAnchorLeft write SetAnchorLeft; //+Sormart - property AnchorTop: Boolean read FAnchorTop write SetAnchorTop; //+Sormart + property AnchorTop: Boolean read FAnchorTop write SetAnchorTop; //+Sormart property AnchorRight: Boolean read FAnchorRight write SetAnchorRight; property AnchorBottom: Boolean read FAnchorBottom write SetAnchorBottom; property AcceptChildren: Boolean read FAcceptChildren write SetAcceptChildren; property MouseTransparent: Boolean read FMouseTransparent write SetMouseTransparent; protected - function SupportsFormCompact: Boolean; virtual; - function HasCompactConstructor: Boolean; virtual; - procedure SetupConstruct_Compact; virtual; - procedure GenerateTransparentInits_Compact; virtual; - procedure Generate_SetSize_Compact; virtual; - procedure GenerateVerticalAlign( SL: TStrings; const AName: String ); - procedure GenerateTextAlign( SL: TStrings; const AName: String ); + procedure GenerateVerticalAlign(SL: TStrings; const AName: string); + procedure GenerateTextAlign(SL: TStrings; const AName: string); function DefaultBorder: Integer; virtual; end; - TKOLControl = class( TKOLCustomControl ) + TKOLControl = class(TKOLCustomControl) public - function Generate_SetSize: String; override; + function Generate_SetSize: string; override; procedure Change; override; published property TabOrder; @@ -2499,9 +2213,8 @@ type property Hint; end; - - {$IFDEF _D5} - TLeftPropEditor = class( TIntegerProperty ) +{$IFDEF _D5} + TLeftPropEditor = class(TIntegerProperty) private function VisualValue: string; protected @@ -2510,7 +2223,7 @@ type ASelected: Boolean); override; end; - TTopPropEditor = class( TIntegerProperty ) + TTopPropEditor = class(TIntegerProperty) private function VisualValue: string; protected @@ -2518,9 +2231,9 @@ type procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); override; end; - {$ENDIF} +{$ENDIF} - TCursorPropEditor = class( TPropertyEditor ) + TCursorPropEditor = class(TPropertyEditor) private protected public @@ -2530,34 +2243,24 @@ type procedure SetValue(const Value: string); override; end; - - - - - - - - - - //============================================================================ // Special component, intended to use it instead TKOLForm and to implement a // unit, which contains MDI child form. - TKOLMDIChild = class( TKOLForm ) + TKOLMDIChild = class(TKOLForm) private - FParentForm: String; + FParentForm: string; fNotAvailable: Boolean; - procedure SetParentForm(const Value: String); + procedure SetParentForm(const Value: string); protected - procedure GenerateCreateForm( SL: TStringList ); override; + procedure GenerateCreateForm(SL: TStringList); override; function DoNotGenerateSetPosition: Boolean; override; public published - property ParentMDIForm: String read FParentForm write SetParentForm; + property ParentMDIForm: string read FParentForm write SetParentForm; property OnQueryEndSession: Boolean read fNotAvailable; end; - TParentMDIFormPropEditor = class( TPropertyEditor ) + TParentMDIFormPropEditor = class(TPropertyEditor) private protected public @@ -2567,13 +2270,12 @@ type procedure SetValue(const Value: string); override; end; - //============================================================================ // Special component, intended to use it instead TKOLForm and to implement a // unit, which does not contain a form, but non-visual KOL objects only. - TDataModuleHowToDestroy = ( ddAfterRun, ddOnAppletDestroy, ddManually ); + TDataModuleHowToDestroy = (ddAfterRun, ddOnAppletDestroy, ddManually); - TKOLDataModule = class( TKOLForm ) + TKOLDataModule = class(TKOLForm) private FOnCreate: TOnEvent; FhowToDestroy: TDataModuleHowToDestroy; @@ -2581,20 +2283,15 @@ type procedure SethowToDestroy(const Value: TDataModuleHowToDestroy); protected fNotAvailable: Boolean; - function GenerateTransparentInits: String; override; - function GenerateINC( const Path: String; var Updated: Boolean ): Boolean; override; - procedure GenerateCreateForm( SL: TStringList ); override; - function Result_Form: String; override; - procedure GenerateDestroyAfterRun( SL: TStringList ); override; - procedure GenerateAdd2AutoFree( SL: TStringList; const AName: String; - AControl: Boolean; Add2AutoFreeProc: String; Obj: TObject ); override; - procedure P_GenerateAdd2AutoFree( SL: TStringList; const AName: String; - AControl: Boolean; Add2AutoFreeProc: String; Obj: TObject ); override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); - override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); - override; - public + function GenerateTransparentInits: string; override; + function GenerateINC(const Path: string; var Updated: Boolean): Boolean; override; + procedure GenerateCreateForm(SL: TStringList); override; + function Result_Form: string; override; + procedure GenerateDestroyAfterRun(SL: TStringList); override; + procedure GenerateAdd2AutoFree(SL: TStringList; const AName: string; + AControl: Boolean; Add2AutoFreeProc: string; Obj: TObject); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; published property Locked; property formName: Boolean read fNotAvailable; @@ -2677,26 +2374,19 @@ type property OnHelp: Boolean read fNotAvailable; end; - - - - - - - //============================================================================ // Special component, intended to use it instead TKOLForm and to implement a // unit, which can contain several visual and non-visual MCK components, which // can be adjusted at design time on a standalone designer form, and created // on KOL form at run time, like a panel with such controls. - TKOLFrame = class( TKOLForm ) + TKOLFrame = class(TKOLForm) private FEdgeStyle: TEdgeStyle; fNotAvailable: Boolean; - FAlign: TKOLAlign; - FCenterOnParent: Boolean; + fAlign: TKOLAlign; + fCenterOnParent: Boolean; FzOrderTopmost: Boolean; - fFrameCaption: String; + fFrameCaption: string; FParentFont: Boolean; FParentColor: Boolean; procedure SetEdgeStyle(const Value: TEdgeStyle); @@ -2707,35 +2397,29 @@ type function GetFrameWidth: Integer; procedure SetFrameHeight(const Value: Integer); procedure SetFrameWidth(const Value: Integer); - procedure SetFrameCaption(const Value: String); - procedure SetParentColor(const Value: Boolean); + procedure SetFrameCaption(const Value: string); + procedure SetparentColor(const Value: Boolean); procedure SetParentFont(const Value: Boolean); protected function AutoCaption: Boolean; override; function GetCaption: TDelphiString; override; - function GenerateTransparentInits: String; override; - function P_GenerateTransparentInits: String; override; - procedure GenerateCreateForm( SL: TStringList ); override; - procedure P_GenerateCreateForm( SL: TStringList ); override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure GenerateAdd2AutoFree( SL: TStringList; const AName: String; - AControl: Boolean; Add2AutoFreeProc: String; Obj: TObject ); override; - procedure P_GenerateAdd2AutoFree( SL: TStringList; const AName: String; - AControl: Boolean; Add2AutoFreeProc: String; Obj: TObject ); override; + function GenerateTransparentInits: string; override; + procedure GenerateCreateForm(SL: TStringList); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure GenerateAdd2AutoFree(SL: TStringList; const AName: string; + AControl: Boolean; Add2AutoFreeProc: string; Obj: TObject); override; public - constructor Create( AOwner: TComponent ); override; + constructor Create(AOwner: TComponent); override; published property EdgeStyle: TEdgeStyle read FEdgeStyle write SetEdgeStyle; - property FormMain: Boolean read fNotAvailable; + property formMain: Boolean read fNotAvailable; property AlphaBlend: Boolean read fNotAvailable; property bounds: Boolean read fNotAvailable; property Width: Integer read GetFrameWidth write SetFrameWidth; property Height: Integer read GetFrameHeight write SetFrameHeight; - property Align: TKOLAlign read FAlign write SetAlign; - property CenterOnParent: Boolean read FCenterOnParent write SetCenterOnParent; + property Align: TKOLAlign read fAlign write SetAlign; + property CenterOnParent: Boolean read fCenterOnParent write SetCenterOnParent; property zOrderTopmost: Boolean read FzOrderTopmost write SetzOrderTopmost; property CanResize: Boolean read fNotAvailable; property defaultPosition: Boolean read fNotAvailable; @@ -2754,9 +2438,9 @@ type property Tabulate: Boolean read fNotAvailable; property TabulateEx: Boolean read fNotAvailable; property WindowState: Boolean read fNotAvailable; - property Caption: String read fFrameCaption write SetFrameCaption; - property ParentColor: Boolean read FParentColor write SetParentColor; - property ParentFont: Boolean read FParentFont write SetParentFont; + property Caption: string read fFrameCaption write SetFrameCaption; + property parentColor: Boolean read FParentColor write SetparentColor; + property parentFont: Boolean read FParentFont write SetParentFont; property OnQueryEndSession: Boolean read fNotAvailable; property OnClose: Boolean read fNotAvailable; property OnMinimize: Boolean read fNotAvailable; @@ -2765,26 +2449,25 @@ type property OnHelp: Boolean read fNotAvailable; end; - TKOLAction = class(TKOLObj) private FLinked: TStringList; FActionList: TKOLActionList; - FVisible: boolean; - FChecked: boolean; - FEnabled: boolean; - FHelpContext: integer; + fVisible: Boolean; + FChecked: Boolean; + fEnabled: Boolean; + FHelpContext: Integer; FHint: string; - FCaption: string; + fCaption: string; FOnExecute: TOnEvent; FAccelerator: TKOLAccelerator; procedure SetCaption(const Value: string); - procedure SetChecked(const Value: boolean); - procedure SetEnabled(const Value: boolean); - procedure SetHelpContext(const Value: integer); + procedure SetChecked(const Value: Boolean); + procedure SetEnabled(const Value: Boolean); + procedure SetHelpContext(const Value: Integer); procedure SetHint(const Value: string); procedure SetOnExecute(const Value: TOnEvent); - procedure SetVisible(const Value: boolean); + procedure SetVisible(const Value: Boolean); procedure SetAccelerator(const Value: TKOLAccelerator); procedure SetActionList(const Value: TKOLActionList); function GetIndex: Integer; @@ -2797,16 +2480,15 @@ type protected procedure ReadState(Reader: TReader); override; procedure SetParentComponent(AParent: TComponent); override; - procedure DefineProperties( Filer: TFiler ); override; + procedure DefineProperties(Filer: TFiler); override; procedure LoadLinks(R: TReader); procedure SaveLinks(W: TWriter); procedure Loaded; override; procedure SetName(const NewName: TComponentName); override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; protected FNameSetuppingInParent: Boolean; - procedure SetupName( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure P_SetupName( SL: TStringList ); override; + procedure SetupName(SL: TStringList; const AName, AParent, Prefix: string); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; @@ -2818,15 +2500,15 @@ type property Index: Integer read GetIndex write SetIndex stored False; procedure LinkComponent(const AComponent: TComponent); procedure UnLinkComponent(const AComponent: TComponent); - function AdditionalUnits: String; override; + function AdditionalUnits: string; override; published - property Caption: string read FCaption write SetCaption; + property Caption: string read fCaption write SetCaption; property Hint: string read FHint write SetHint; - property Checked: boolean read FChecked write SetChecked default False; - property Enabled: boolean read FEnabled write SetEnabled default True; - property Visible: boolean read FVisible write SetVisible default True; - property HelpContext: integer read FHelpContext write SetHelpContext default 0; - property Accelerator: TKOLAccelerator read FAccelerator write SetAccelerator; + property checked: Boolean read FChecked write SetChecked default False; + property Enabled: Boolean read fEnabled write SetEnabled default True; + property Visible: Boolean read fVisible write SetVisible default True; + property HelpContext: Integer read FHelpContext write SetHelpContext default 0; + property accelerator: TKOLAccelerator read FAccelerator write SetAccelerator; property OnExecute: TOnEvent read FOnExecute write SetOnExecute; end; @@ -2836,28 +2518,28 @@ type FOnUpdateActions: TOnEvent; function GetKOLAction(Index: Integer): TKOLAction; procedure SetKOLAction(Index: Integer; const Value: TKOLAction); - function GetCount: integer; + function GetCount: Integer; procedure SetOnUpdateActions(const Value: TOnEvent); public procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; procedure SetChildOrder(Component: TComponent; Order: Integer); override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; + procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override; + procedure AssignEvents(SL: TStringList; const AName: string); override; + procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override; public ActiveDesign: TfmActionListEditor; constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Actions[Index: Integer]: TKOLAction read GetKOLAction write SetKOLAction; default; - property Count: integer read GetCount; + property Count: Integer read GetCount; property List: TList read FActions; - function AdditionalUnits: String; override; + function AdditionalUnits: string; override; published property OnUpdateActions: TOnEvent read FOnUpdateActions write SetOnUpdateActions; end; - TKOLActionListEditor = class( TComponentEditor ) + TKOLActionListEditor = class(TComponentEditor) private protected public @@ -2867,13 +2549,6 @@ type function GetVerbCount: Integer; override; end; - - - - - - - var // Variable KOLProject refers to a TKOLProject instance (must be // single in a project). @@ -2881,7 +2556,6 @@ var // Переменная KOLProject содержит указатель на представитель класса // TKOLProject (который должен быть единственным) KOLProject: TKOLProject; - GlobalNewIF: Boolean = {$IFDEF _D6orHigher} TRUE {$ELSE} FALSE {$ENDIF}; function BuildKOLProject: Boolean; @@ -2901,188 +2575,190 @@ var // суметь перечислить все формы, чтобы сгенерировать код для них). FormsList: TList; -function Color2Str( Color: TColor ): String; +function Color2Str(Color: TColor): string; -procedure Log( const S: String ); -procedure LogOK ; -procedure Rpt( const S: KOLString; Color: Integer ); -procedure RptDetailed( const S: KOLString; Color: Integer ); +procedure Log(const s: string); +procedure LogOK; +procedure Rpt(const s: KOLString; Color: Integer); +procedure RptDetailed(const s: KOLString; Color: Integer); procedure Rpt_Stack; -function ProjectSourcePath: String; -function Get_ProjectName: String; +function ProjectSourcePath: string; +function Get_ProjectName: string; //dufa {$IFDEF _D2005orHigher} function Get_ProjectGroup: IOTAProjectGroup; {$ENDIF} -procedure AddLongTextField( var SL: TStringList; const Prefix:String; - const Text:TDelphiString; const Suffix:String; const LinePrefix: String ); +procedure AddLongTextField(var SL: TStringList; const Prefix: string; + const Text: TDelphiString; const Suffix: string; const LinePrefix: string); //*/////////////////////////////////////// - {$IFDEF _D6orHigher} // +{$IFDEF _D6orHigher} // type - IFormDesigner = IDesigner; // - {$ENDIF} // -//*/////////////////////////////////////// + IFormDesigner = IDesigner; // +{$ENDIF} // + //*/////////////////////////////////////// -function QueryFormDesigner( D: IDesigner; var FD: IFormDesigner ): Boolean; -function PCharStringConstant( Sender: TObject; const Propname, Value: String ): String; -function P_PCharStringConstant( Sender: TObject; const Propname, Value: String ): String; -procedure LoadSource( SL: TStrings; const Path: String ); -procedure SaveStrings( SL: TStrings; const Path: String; var Updated: Boolean ); -procedure SaveStringToFile(const Path, Str: String ); -procedure MarkModified( const Path: String ); +function QueryFormDesigner(D: IDesigner; var FD: IFormDesigner): Boolean; +function PCharStringConstant(Sender: TObject; const Propname, Value: string): string; +procedure LoadSource(SL: TStrings; const Path: string); +procedure SaveStrings(SL: TStrings; const Path: string; var Updated: Boolean); +procedure SaveStringToFile(const Path, Str: string); +procedure MarkModified(const Path: string); const Signature = '{ KOL MCK } // Do not remove this line!'; -const TextAligns: array[ TTextAlign ] of String = ( 'taLeft', 'taRight', 'taCenter' ); - VertAligns: array[ TVerticalAlign ] of String = ( 'vaTop', 'vaCenter', 'vaBottom' ); - - +const + TextAligns: array[TTextAlign] of string = ('taLeft', 'taRight', 'taCenter'); + VertAligns: array[TVerticalAlign] of string = ('vaTop', 'vaCenter', 'vaBottom'); procedure Register; {$R KOLmirrors.dcr} -function Remove_Result_dot( const s: String ): String; +function Remove_Result_dot(const s: string): string; implementation uses ShellAPI, shlobj, ActiveX, mckCtrls, mckObjs; - procedure Register; - begin - RegisterComponents( 'KOL', [ TKOLProject, TKOLApplet, TKOLForm, TKOLMDIChild, - TKOLDataModule, TKOLFrame, TKOLActionList ] ); - RegisterComponentEditor( TKOLProject, TKOLProjectBuilder ); - {$IFDEF _D5} - RegisterPropertyEditor( TypeInfo( Integer ), TKOLCustomControl, 'Left', TLeftPropEditor ); - RegisterPropertyEditor( TypeInfo( Integer ), TKOLCustomControl, 'Top', TTopPropEditor ); - {$ENDIF} - RegisterComponentEditor( TKOLObj, TKOLObjectCompEditor ); - RegisterComponentEditor( TKOLApplet, TKOLObjectCompEditor ); - RegisterComponentEditor( TKOLCustomControl, TKOLObjectCompEditor ); - RegisterPropertyEditor( TypeInfo( TOnEvent ), nil, '', TKOLOnEventPropEditor ); - RegisterPropertyEditor( TypeInfo( TOnMessage ), nil, '', TKOLOnEventPropEditor ); - RegisterPropertyEditor( TypeInfo( String ), TKOLCustomControl, 'Cursor_', TCursorPropEditor ); - RegisterPropertyEditor( TypeInfo( String ), TKOLForm, 'Cursor', TCursorPropEditor ); - RegisterPropertyEditor( TypeInfo( String ), TKOLMDIChild, 'ParentMDIForm', TParentMDIFormPropEditor ); - RegisterComponentEditor( TKOLMenu, TKOLMenuEditor ); - RegisterPropertyEditor( TypeInfo( TOnMenuItem ), TKOLMenuItem, 'OnMenu', - TKOLOnItemPropEditor ); - RegisterPropertyEditor( TypeInfo( TKOLAccelerator ), TKOLMenuItem, 'Accelerator', - TKOLAcceleratorPropEditor ); - RegisterNoIcon([TKOLAction]); - RegisterClasses([TKOLAction]); - RegisterComponentEditor( TKOLActionList, TKOLActionListEditor ); - RegisterPropertyEditor( TypeInfo( TKOLAccelerator ), TKOLAction, 'Accelerator', - TKOLAcceleratorPropEditor ); - end; - -const BoolVals: array[ Boolean ] of String = ( 'FALSE', 'TRUE' ); - -function Remove_Result_dot( const s: String ): String; +procedure Register; begin - Result := s; - if Copy( LowerCase( s ), 1, 7 ) = 'result.' then - Result := Copy( s, 8, Length( s ) - 7 ); + RegisterComponents('KOL', [TKOLProject, TKOLApplet, TKOLForm, TKOLMDIChild, + TKOLDataModule, TKOLFrame, TKOLActionList]); + RegisterComponentEditor(TKOLProject, TKOLProjectBuilder); +{$IFDEF _D5} + RegisterPropertyEditor(TypeInfo(Integer), TKOLCustomControl, 'Left', TLeftPropEditor); + RegisterPropertyEditor(TypeInfo(Integer), TKOLCustomControl, 'Top', TTopPropEditor); +{$ENDIF} + RegisterComponentEditor(TKOLObj, TKOLObjectCompEditor); + RegisterComponentEditor(TKOLApplet, TKOLObjectCompEditor); + RegisterComponentEditor(TKOLCustomControl, TKOLObjectCompEditor); + RegisterPropertyEditor(TypeInfo(TOnEvent), nil, '', TKOLOnEventPropEditor); + RegisterPropertyEditor(TypeInfo(TOnMessage), nil, '', TKOLOnEventPropEditor); + RegisterPropertyEditor(TypeInfo(string), TKOLCustomControl, 'Cursor_', TCursorPropEditor); + RegisterPropertyEditor(TypeInfo(string), TKOLForm, 'Cursor', TCursorPropEditor); + RegisterPropertyEditor(TypeInfo(string), TKOLMDIChild, 'ParentMDIForm', TParentMDIFormPropEditor); + RegisterComponentEditor(TKOLMenu, TKOLMenuEditor); + RegisterPropertyEditor(TypeInfo(TOnMenuItem), TKOLMenuItem, 'OnMenu', + TKOLOnItemPropEditor); + RegisterPropertyEditor(TypeInfo(TKOLAccelerator), TKOLMenuItem, 'Accelerator', + TKOLAcceleratorPropEditor); + RegisterNoIcon([TKOLAction]); + RegisterClasses([TKOLAction]); + RegisterComponentEditor(TKOLActionList, TKOLActionListEditor); + RegisterPropertyEditor(TypeInfo(TKOLAccelerator), TKOLAction, 'Accelerator', + TKOLAcceleratorPropEditor); end; -function IDI2Number( const IDIName: String ): Integer; const - IDINames: array[ 1..9 ] of String = ( + BoolVals: array[Boolean] of string = ('FALSE', 'TRUE'); + +function Remove_Result_dot(const s: string): string; +begin + Result := s; + if Copy(LowerCase(s), 1, 7) = 'result.' then + Result := Copy(s, 8, Length(s) - 7); +end; + +function IDI2Number(const IDIName: string): Integer; +const + IDINames: array[1..9] of string = ( 'IDI_APPLICATION', 'IDI_HAND', 'IDI_QUESTION', 'IDI_EXCLAMATION', 'IDI_ASTERISK', 'IDI_WINLOGO', 'IDI_WARNING', 'IDI_ERROR', - 'IDI_INFORMATION' ); - IDIValues: array[ 1..9 ] of Integer = ( 32512, 32513, 32514, 32515, + 'IDI_INFORMATION'); + IDIValues: array[1..9] of Integer = (32512, 32513, 32514, 32515, 32516, 32517, - 32515, 32513, 32516 ); -var i: Integer; + 32515, 32513, 32516); +var + I: Integer; begin - for i := 1 to High( IDINames ) do - if UpperCase( IDIName ) = IDINames[ i ] then - begin - Result := IDIValues[ i ]; + for I := 1 to High(IDINames) do + if UpperCase(IDIName) = IDINames[I] then begin + Result := IDIValues[I]; Exit; end; Result := 0; end; -function IDC2Number( const IDCName: String ): Integer; +function IDC2Number(const IDCName: string): Integer; const - IDCNames: array[ 1..16 ] of String = ( + IDCNames: array[1..16] of string = ( 'IDC_ARROW', 'IDC_IBEAM', 'IDC_WAIT', 'IDC_CROSS', 'IDC_UPARROW', 'IDC_SIZE', 'IDC_ICON', 'IDC_SIZENWSE', 'IDC_SIZENESW', 'IDC_SIZEWE', 'IDC_SIZENS', - 'IDC_SIZEALL', 'IDC_NO', 'IDC_HAND', 'IDC_APPSTARTING', 'IDC_HELP' ); - IDCValues: array[ 1..16 ] of Integer = ( 32512, 32513, 32514, 32515, 32516, - 32640, 32641, 32642, 32643, 32644, 32645, 32646, 32648, 32649, 32650, 32651 ); -var i: Integer; + 'IDC_SIZEALL', 'IDC_NO', 'IDC_HAND', 'IDC_APPSTARTING', 'IDC_HELP'); + IDCValues: array[1..16] of Integer = (32512, 32513, 32514, 32515, 32516, + 32640, 32641, 32642, 32643, 32644, 32645, 32646, 32648, 32649, 32650, 32651); +var + I: Integer; begin - for i := 1 to High( IDCNames ) do - if UpperCase( IDCName ) = IDCNames[ i ] then - begin - Result := IDCValues[ i ]; + for I := 1 to High(IDCNames) do + if UpperCase(IDCName) = IDCNames[I] then begin + Result := IDCValues[I]; Exit; end; Result := 0; end; {$STACKFRAMES ON} + function GetCallStack: TStringList; -var RegEBP: PDWORD; - RetAddr, MinSearchAddr, SrchPtr: PAnsiChar; - Found: Boolean; +var + RegEBP: PDWORD; + RetAddr, MinSearchAddr, SrchPtr: PAnsiChar; + Found: Boolean; begin Result := TStringList.Create; //Exit; // TODO: check Memory runaway asm MOV RegEBP, EBP end; - while TRUE do - begin - Inc( RegEBP ); + while True do begin + Inc(RegEBP); try - RetAddr := Pointer( RegEBP^ ); + RetAddr := Pointer(RegEBP^); except RetAddr := nil; end; - if RetAddr = nil then Exit; + if RetAddr = nil then + Exit; MinSearchAddr := RetAddr - 4000; - if Integer( MinSearchAddr ) > Integer( RetAddr ) then - break; - Found := FALSE; - SrchPtr := RetAddr - Length( '#$signature$#' ) - 1; - while SrchPtr >= MinSearchAddr do - begin + if Integer(MinSearchAddr) > Integer(RetAddr) then + Break; + Found := False; + SrchPtr := RetAddr - Length('#$signature$#') - 1; + while SrchPtr >= MinSearchAddr do begin try - if SrchPtr = '#$signature$#' then - begin - Found := TRUE; - break; + if SrchPtr = '#$signature$#' then begin + Found := True; + Break; end; except SrchPtr := nil; end; - if SrchPtr = nil then break; - Dec( SrchPtr ); + if SrchPtr = nil then + Break; + Dec(SrchPtr); end; - if not Found then break; - Inc( SrchPtr, Length( '#$signature$#' ) + 1 ); - Result.Add( String(SrchPtr) ); // TODO: cast - Dec( RegEBP ); + if not Found then + Break; + Inc(SrchPtr, Length('#$signature$#') + 1); + Result.Add(string(SrchPtr)); // TODO: cast + Dec(RegEBP); try - RegEBP := Pointer( RegEBP^ ); + RegEBP := Pointer(RegEBP^); except RegEBP := nil; end; - if RegEBP = nil then break; + if RegEBP = nil then + Break; end; end; -function CmpInts( X, Y: Integer ): Integer; +function CmpInts(X, Y: Integer): Integer; begin asm jmp @@e_signature @@ -3092,15 +2768,15 @@ begin end; if X < Y then Result := -1 - else - if X > Y then + else if X > Y then Result := 1 else Result := 0; end; -function IsVCLControl( C: TComponent ): Boolean; -var temp: Integer; +function IsVCLControl(c: TComponent): Boolean; +var + temp: Integer; begin asm jmp @@e_signature @@ -3114,61 +2790,62 @@ begin if (C is TKOLApplet) or (C is TKOLCustomControl) or (C is TOleControl) then Result := FALSE;} //----------------------- new - by Alexander Rabotyagov - Result := C is controls.TControl; + Result := c is Controls.TControl; if Result then - if (C is TKOLApplet) or (C is TKOLCustomControl) or (C is TOleControl) - then result:=false - else begin - result:=false; - if c.tag<>cKolTag - then begin - {KOL.ShowQuestion - более удобно, поэтому так:} - temp:=ShowQuestion('Form contain VCL control!!!'+#13+#10+ - 'Name this VCL control is '+c.name+'.'+#13+#10+ - 'You have choise:'+#13+#10+ - '1) replace this VCL control - click "Replace"'+#13+#10+ - '2) ignore this VCL control - click "Ignore"'+#13+#10+ - ' (it change tag property to '+IntToStr(cKolTag)+','+#13+#10+ - ' remove it to Private'+#13+#10+ - ' and change source code to:'+#13+#10+ - ' {$IFNDEF KOL_MCK}'+c.Name+': '+c.ClassName+';{$ENDIF} {<-- It is a VCL control}'+#13+#10+ - '3) lock Your project - click "Lock"' - ,'Replace/Ignore/Lock'); - try - if temp=1 then c.free; - if temp=2 then c.tag:=cKolTag; - if temp=3 then result:=true; - except - Showmessage('Sorry, but can not do it! Your project will be locked!'); - result:=true; + if (c is TKOLApplet) or (c is TKOLCustomControl) or (c is TOleControl) then + Result := False + else begin + Result := False; + if c.Tag <> cKOLTag then begin + {KOL.ShowQuestion - более удобно, поэтому так:} + temp := ShowQuestion('Form contain VCL control!!!' + #13 + #10 + + 'Name this VCL control is ' + c.name + '.' + #13 + #10 + + 'You have choise:' + #13 + #10 + + '1) replace this VCL control - click "Replace"' + #13 + #10 + + '2) ignore this VCL control - click "Ignore"' + #13 + #10 + + ' (it change tag property to ' + IntToStr(cKOLTag) + ',' + #13 + #10 + + ' remove it to Private' + #13 + #10 + + ' and change source code to:' + #13 + #10 + + ' {$IFNDEF KOL_MCK}' + c.name + ': ' + c.ClassName + ';{$ENDIF} {<-- It is a VCL control}' + #13 + #10 + + '3) lock Your project - click "Lock"' + , 'Replace/Ignore/Lock'); + try + if temp = 1 then + c.free; + if temp = 2 then + c.Tag := cKOLTag; + if temp = 3 then + Result := True; + except + Showmessage('Sorry, but can not do it! Your project will be locked!'); + Result := True; + end; end; end; - end; end; {$IFDEF MCKLOG} -var EnterLevel: array[ 0..7 ] of Integer; - LevelOKStack: array[ 0..7, -1000..+1000 ] of Boolean; - Threads: array[ 0..7 ] of DWORD; +var + EnterLevel: array[0..7] of Integer; + LevelOKStack: array[0..7, -1000.. + 1000] of Boolean; + Threads: array[0..7] of DWORD; + function GetThreadIndex: Integer; -var i: Integer; - CTI: DWORD; +var + I: Integer; + CTI: DWORD; begin CTI := GetCurrentThreadId; - for i := 0 to 6 do - begin - if Threads[ i ] = CTI then - begin - Result := i; + for I := 0 to 6 do begin + if Threads[I] = CTI then begin + Result := I; Exit; end; end; - for i := 0 to 6 do - begin - if Threads[ i ] = 0 then - begin - Threads[ i ] := CTI; - Result := i; + for I := 0 to 6 do begin + if Threads[I] = 0 then begin + Threads[I] := CTI; + Result := I; Exit; end; end; @@ -3177,73 +2854,71 @@ end; {$ENDIF MCKLOG} {$IFDEF MCKLOGBUFFERED} -var LogBuffer: TStringList; +var + LogBuffer: TStringList; {$ENDIF} -procedure Log( const S: String ); +procedure Log(const s: string); {$IFDEF MCKLOG} -var S1: String; - L: Integer; +var + S1: string; + L: Integer; {$ENDIF} begin - {$IFDEF MCKLOG} - L := EnterLevel[ GetThreadIndex ]; - if Copy( S, 1, 2 ) = '->' then - begin - Inc( EnterLevel[ GetThreadIndex ] ); - if (EnterLevel[ GetThreadIndex ] >= -1000) and (EnterLevel[ GetThreadIndex ] <= 1000) then - LevelOKStack[ GetThreadIndex, EnterLevel[ GetThreadIndex ] ] := FALSE; +{$IFDEF MCKLOG} + L := EnterLevel[GetThreadIndex]; + if Copy(s, 1, 2) = '->' then begin + Inc(EnterLevel[GetThreadIndex]); + if (EnterLevel[GetThreadIndex] >= -1000) and (EnterLevel[GetThreadIndex] <= 1000) then + LevelOKStack[GetThreadIndex, EnterLevel[GetThreadIndex]] := False; end - else - if Copy( S, 1, 2 ) = '<-' then - begin - dec( L ); - if (EnterLevel[ GetThreadIndex ] >= -1000) and (EnterLevel[ GetThreadIndex ] <= 1000) then - if not LevelOKStack[ GetThreadIndex, EnterLevel[ GetThreadIndex ] ] then - LogFileOutput( 'C:\MCK.log', DateTime2StrShort( Now ) + - ' <' + IntToStr( GetCurrentThreadId ) + '> ' + - IntToStr( EnterLevel[ GetThreadIndex ] ) + ' *** Leave not OK *** ' + S ); - Dec( EnterLevel[ GetThreadIndex ] ); + else if Copy(s, 1, 2) = '<-' then begin + Dec(L); + if (EnterLevel[GetThreadIndex] >= -1000) and (EnterLevel[GetThreadIndex] <= 1000) then + if not LevelOKStack[GetThreadIndex, EnterLevel[GetThreadIndex]] then + LogFileOutput('C:\MCK.log', DateTime2StrShort(Now) + + ' <' + IntToStr(GetCurrentThreadId) + '> ' + + IntToStr(EnterLevel[GetThreadIndex]) + ' *** Leave not OK *** ' + s); + Dec(EnterLevel[GetThreadIndex]); end; - {$IFDEF MCKLOGwoRPT} - if Copy( S, 1, 4 ) = 'Rpt:' then +{$IFDEF MCKLOGwoRPT} + if Copy(s, 1, 4) = 'Rpt:' then Exit; - {$ENDIF MCKLOGwoRPT} - {$IFDEF MCKLOGwoTKOLProject} - if StrEq( Copy( S, 3, 11 ), 'TKOLProject' ) then +{$ENDIF MCKLOGwoRPT} +{$IFDEF MCKLOGwoTKOLProject} + if StrEq(Copy(s, 3, 11), 'TKOLProject') then Exit; - {$ENDIF MCKLOGwoTKOLProject} +{$ENDIF MCKLOGwoTKOLProject} - S1 := DateTime2StrShort( Now ) + - ' <' + IntToStr( GetCurrentThreadId ) + '> ' - + IntToStr( EnterLevel[ GetThreadIndex ] ) + ' ' - + StrRepeat( ' ', L ) + S; - {$IFDEF MCKLOGBUFFERED} + S1 := DateTime2StrShort(Now) + + ' <' + IntToStr(GetCurrentThreadId) + '> ' + + IntToStr(EnterLevel[GetThreadIndex]) + ' ' + + StrRepeat(' ', L) + s; +{$IFDEF MCKLOGBUFFERED} if LogBuffer = nil then LogBuffer := TStringList.Create; - LogBuffer.Add( S1 ); - if LogBuffer.Count >= 100 then - begin - LogFileOutput( 'C:\MCK.log', TrimRight(LogBuffer.Text) ); + LogBuffer.Add(S1); + if LogBuffer.Count >= 100 then begin + LogFileOutput('C:\MCK.log', TrimRight(LogBuffer.Text)); LogBuffer.Clear; end; - {$ELSE} - LogFileOutput( 'C:\MCK.log', S1 ); - {$ENDIF} - {$ELSE} - Sleep( 0 ); - {$ENDIF MCKLOG} +{$ELSE} + LogFileOutput('C:\MCK.log', S1); +{$ENDIF} +{$ELSE} +//-dufa Sleep(0); +{$ENDIF MCKLOG} end; -procedure LogOK ; +procedure LogOK; begin - {$IFDEF MCKLOG} - if (EnterLevel[ GetThreadIndex ] >= -1000) and (EnterLevel[ GetThreadIndex ] <= 1000) then - LevelOKStack[ GetThreadIndex, EnterLevel[ GetThreadIndex ] ] := TRUE; - {$ENDIF} +{$IFDEF MCKLOG} + if (EnterLevel[GetThreadIndex] >= -1000) and (EnterLevel[GetThreadIndex] <= 1000) then + LevelOKStack[GetThreadIndex, EnterLevel[GetThreadIndex]] := True; +{$ENDIF} end; -procedure Rpt( const S: KOLString; Color: Integer ); +procedure Rpt(const s: KOLString; Color: Integer); begin asm jmp @@e_signature @@ -3251,12 +2926,12 @@ begin DB 'Rpt', 0 @@e_signature: end; - Log( 'Rpt: ' + S ); + Log('Rpt: ' + s); if KOLProject <> nil then - KOLProject.Report( S, Color ); + KOLProject.Report(s, Color); end; -procedure RptDetailed( const S: KOLString; Color: Integer ); +procedure RptDetailed(const s: KOLString; Color: Integer); begin asm jmp @@e_signature @@ -3264,30 +2939,31 @@ begin DB 'RptDetailed', 0 @@e_signature: end; - Log( 'Rpt: ' + S ); + Log('Rpt: ' + s); if (KOLProject <> nil) and KOLProject.ReportDetailed then - KOLProject.Report( S, Color ); + KOLProject.Report(s, Color); end; procedure Rpt_Stack; -var StrList: TStringList; - I: Integer; +var + StrList: TStringList; + I: Integer; begin - Rpt( 'Stack:', LIGHT + BLUE ); - TRY - StrList := GetCallStack; - TRY - for I := 0 to StrList.Count-1 do - Rpt( KOLString(StrList[ I ]), LIGHT + BLUE ); - FINALLY - StrList.Free; -end; - EXCEPT - RptDetailed( 'Exception while Rpt_Stack', YELLOW ); - END; + Rpt('Stack:', LIGHT + BLUE); + try + StrList := GetCallStack; + try + for I := 0 to StrList.Count - 1 do + Rpt(KOLString(StrList[I]), LIGHT + BLUE); + finally + StrList.free; + end; + except + RptDetailed('Exception while Rpt_Stack', YELLOW); + end; end; -function ProjectSourcePath: String; +function ProjectSourcePath: string; {$IFDEF _D2005orHigher} var IProjectGroup: IOTAProjectGroup; @@ -3301,27 +2977,24 @@ begin end; Result := ''; if KOLProject <> nil then - Result := KOLProject.SourcePath - else - begin + Result := KOLProject.sourcePath + else begin if ToolServices <> nil then - Result := ExtractFilePath( ToolServices.GetProjectName ) - {$IFDEF _D2005orHigher} - else - begin + Result := ExtractFilePath(ToolServices.GetProjectName) +{$IFDEF _D2005orHigher} + else begin IProjectGroup := Get_ProjectGroup(); - if Assigned(IProjectGroup) then - begin + if Assigned(IProjectGroup) then begin // if IProjectGroup.ActiveProject.ProjectType = 'Library' - Result := ExtractFilePath( IProjectGroup.ActiveProject.ProjectOptions.TargetName ); + Result := ExtractFilePath(IProjectGroup.ActiveProject.ProjectOptions.TargetName); end; end; - {$ENDIF} +{$ENDIF} end; end; -function Get_ProjectName: String; +function Get_ProjectName: string; {$IFDEF _D2005orHigher} var IProjectGroup: IOTAProjectGroup; @@ -3335,24 +3008,23 @@ begin end; Result := ''; if KOLProject <> nil then - Result := KOLProject.ProjectName - else - if ToolServices <> nil then - Result := ExtractFileNameWOExt( ToolServices.GetProjectName ) - {$IFDEF _D2005orHigher} - else - begin - IProjectGroup := Get_ProjectGroup; - if Assigned(IProjectGroup) then - Result := ExtractFileNameWOExt( IProjectGroup.ActiveProject.ProjectOptions.TargetName ); // instead ActiveProject.GetFilename - end; - {$ENDIF} + Result := KOLProject.projectName + else if ToolServices <> nil then + Result := ExtractFileNameWOExt(ToolServices.GetProjectName) +{$IFDEF _D2005orHigher} + else begin + IProjectGroup := Get_ProjectGroup; + if Assigned(IProjectGroup) then + Result := ExtractFileNameWOExt(IProjectGroup.ActiveProject.ProjectOptions.TargetName); // instead ActiveProject.GetFilename + end; +{$ENDIF} end; -function ReadTextFromIDE( Reader: TIEditReader ): PChar; -var Buf: PChar; // ANSI_CTRLS? - Len, Pos: Integer; - MS: TMemoryStream; +function ReadTextFromIDE(Reader: TIEditReader): PChar; +var + Buf: PChar; // ANSI_CTRLS? + Len, Pos: Integer; + MS: TMemoryStream; begin asm jmp @@e_signature @@ -3361,44 +3033,43 @@ begin @@e_signature: end; Result := nil; - GetMem( Buf, 10000 ); + GetMem(Buf, 10000); MS := TMemoryStream.Create; Pos := 0; try - Len := Reader.GetText( 0, Buf, 10000 ); - while Len > 0 do - begin - MS.Write( Buf[ 0 ], Len ); + Len := Reader.GetText(0, Buf, 10000); + while Len > 0 do begin + MS.Write(Buf[0], Len); Pos := Pos + Len; - Len := Reader.GetText( Pos, Buf, 10000 ); + Len := Reader.GetText(Pos, Buf, 10000); end; - if MS.Size > 0 then - begin - GetMem( Result, MS.Size + 1 ); - Move( MS.Memory^, Result^, MS.Size ); - Result[ MS.Size ] := #0; + if MS.Size > 0 then begin + GetMem(Result, MS.Size + 1); + Move(MS.Memory^, Result^, MS.Size); + Result[MS.Size] := #0; end; //Rpt( IntToStr( MS.Size ) + ' bytes are read from IDE' ); except - on E: Exception do - begin - ShowMessage( 'Cannot read text from IDE, exception: ' + E.Message ); + on E: Exception do begin + Showmessage('Cannot read text from IDE, exception: ' + E.Message); end; end; - FreeMem( Buf ); - MS.Free; + FreeMem(Buf); + MS.free; end; {$IFNDEF VER90} {$IFNDEF VER100} -function ReadTextFromIDE_0( Reader: IOTAEditReader ): PChar; -var Buf: PAnsiChar; - Len, Pos: Integer; - MS: TMemoryStream; + +function ReadTextFromIDE_0(Reader: IOTAEditReader): PChar; +var + Buf: PAnsiChar; + Len, Pos: Integer; + MS: TMemoryStream; begin asm jmp @@e_signature @@ -3407,58 +3078,56 @@ begin @@e_signature: end; Result := nil; - GetMem( Buf, 10000 ); + GetMem(Buf, 10000); MS := TMemoryStream.Create; Pos := 0; try - Len := Reader.GetText( 0, Buf, 10000 ); - while Len > 0 do - begin - MS.Write( Buf[ 0 ], Len ); + Len := Reader.GetText(0, Buf, 10000); + while Len > 0 do begin + MS.Write(Buf[0], Len); Pos := Pos + Len; - Len := Reader.GetText( Pos, Buf, 10000 ); + Len := Reader.GetText(Pos, Buf, 10000); end; - if MS.Size > 0 then - begin - GetMem( Result, MS.Size + 1 ); - Move( MS.Memory^, Result^, MS.Size ); - Result[ MS.Size ] := #0; + if MS.Size > 0 then begin + GetMem(Result, MS.Size + 1); + Move(MS.Memory^, Result^, MS.Size); + Result[MS.Size] := #0; end; //Rpt( IntToStr( MS.Size ) + ' bytes are read from IDE' ); except - on E: Exception do - begin - ShowMessage( 'Cannot read text from IDE, exception(0): ' + E.Message ); + on E: Exception do begin + Showmessage('Cannot read text from IDE, exception(0): ' + E.Message); end; end; - FreeMem( Buf ); - MS.Free; + FreeMem(Buf); + MS.free; end; {$ENDIF} {$ENDIF} -procedure LoadSource( SL: TStrings; const Path: String ); -var N, I: Integer; - S: String; - Loaded: Boolean; - Module: TIModuleInterface; - Editor: TIEditorInterface; - Reader: TIEditReader; - Buffer: PChar; +procedure LoadSource(SL: TStrings; const Path: string); +var + N, I: Integer; + s: string; + Loaded: Boolean; + Module: TIModuleInterface; + Editor: TIEditorInterface; + Reader: TIEditReader; + Buffer: PChar; - {$IFNDEF VER90} - {$IFNDEF VER100} - MS: IOTAModuleServices; - M: IOTAModule; - E: IOTAEditor; - SE: IOTASourceEditor; - ER: IOTAEditReader; - {$ENDIF} - {$ENDIF} +{$IFNDEF VER90} +{$IFNDEF VER100} + MS: IOTAModuleServices; + M: IOTAModule; + E: IOTAEditor; + SE: IOTASourceEditor; + ER: IOTAEditReader; +{$ENDIF} +{$ENDIF} begin asm @@ -3469,119 +3138,105 @@ begin end; Loaded := False; SL.Clear; - if ToolServices <> nil then - try + if ToolServices <> nil then try //Rpt( 'trying to load from IDE Editor: ' + Path ); N := ToolServices.GetUnitCount; - for I := 0 to N - 1 do - begin - S := ToolServices.GetUnitName( I ); - if AnsiLowerCase( S ) = AnsiLowerCase( Path ) then - begin + for I := 0 to N - 1 do begin + s := ToolServices.GetUnitName(I); + if AnsiLowerCase(s) = AnsiLowerCase(Path) then begin // unit is loaded into IDE editor - make an attempt to get it from there - Module := ToolServices.GetModuleInterface( S ); - if Module <> nil then - try + Module := ToolServices.GetModuleInterface(s); + if Module <> nil then try Editor := Module.GetEditorInterface; - if Editor <> nil then - try + if Editor <> nil then try Reader := Editor.CreateReader; Buffer := nil; - if Reader <> nil then - try + if Reader <> nil then try //Rpt( 'Loading source from IDE Editor: ' + Path ); - Buffer := ReadTextFromIDE( Reader ); - if Buffer <> nil then - begin - SL.Text := String(Buffer); // TODO: KOL_ANSI + Buffer := ReadTextFromIDE(Reader); + if Buffer <> nil then begin + SL.Text := string(Buffer); // TODO: KOL_ANSI Loaded := True; //Rpt( 'Loaded: ' + Path ); end; finally - Reader.Free; + Reader.free; if Buffer <> nil then - FreeMem( Buffer ); + FreeMem(Buffer); end; finally - Editor.Free; + Editor.free; end; finally - Module.Free; + Module.free; end; - break; + Break; end; end; - {$IFNDEF VER90} - {$IFNDEF VER100} - if not Loaded and (BorlandIDEServices <> nil) then - begin - if BorlandIDEServices.QueryInterface( IOTAModuleServices, MS ) = 0 then - begin - M := MS.FindModule( Path ); - if M <> nil then - begin +{$IFNDEF VER90} +{$IFNDEF VER100} + if not Loaded and (BorlandIDEServices <> nil) then begin + if BorlandIDEServices.QueryInterface(IOTAModuleServices, MS) = 0 then begin + M := MS.FindModule(Path); + if M <> nil then begin N := M.GetModuleFileCount; - for I := 0 to N-1 do - begin - E := M.GetModuleFileEditor( I ); - if E.QueryInterface( IOTASourceEditor, SE ) = 0 then - begin + for I := 0 to N - 1 do begin + E := M.GetModuleFileEditor(I); + if E.QueryInterface(IOTASourceEditor, SE) = 0 then begin ER := SE.CreateReader; - if ER <> nil then - begin - Buffer := ReadTextFromIDE_0( ER ); - if Buffer <> nil then - begin - SL.Text := String(Buffer); // TODO: KOL_ANSI + if ER <> nil then begin + Buffer := ReadTextFromIDE_0(ER); + if Buffer <> nil then begin + SL.Text := string(Buffer); // TODO: KOL_ANSI Loaded := True; //Rpt( 'Loaded_0: ' + Path ); end; - break; + Break; end; end; end; end; end; end; - {$ENDIF} - {$ENDIF} +{$ENDIF} +{$ENDIF} except - on E: Exception do - begin - ShowMessage( 'Can not load source of ' + Path + ', exception: ' + E.Message ); + on E: Exception do begin + Showmessage('Can not load source of ' + Path + ', exception: ' + E.Message); end; end; if not Loaded then - if FileExists( Path ) then - SL.LoadFromFile( Path ); + if FileExists(Path) then + SL.LoadFromFile(Path); end; -function UpdateSource( SL: TStrings; const Path: String ): Boolean; -var N, I: Integer; - S: String; - Module: TIModuleInterface; - Editor: TIEditorInterface; - Writer: TIEditWriter; - Buffer: String; +function UpdateSource(SL: TStrings; const Path: string): Boolean; +var + N, I: Integer; + s: string; + Module: TIModuleInterface; + Editor: TIEditorInterface; + Writer: TIEditWriter; + Buffer: string; - {$IFNDEF VER90} - {$IFNDEF VER100} - MS: IOTAModuleServices; - M: IOTAModule; - E: IOTAEditor; - SE: IOTASourceEditor; - {$IFNDEF VER120} - EB: IOTAEditBuffer; - RO: Boolean; - {$ENDIF} - EW: IOTAEditWriter; - {$ENDIF} - {$ENDIF} +{$IFNDEF VER90} +{$IFNDEF VER100} + MS: IOTAModuleServices; + M: IOTAModule; + E: IOTAEditor; + SE: IOTASourceEditor; +{$IFNDEF VER120} + EB: IOTAEditBuffer; + RO: Boolean; +{$ENDIF} + EW: IOTAEditWriter; +{$ENDIF} +{$ENDIF} begin asm jmp @@e_signature @@ -3589,104 +3244,92 @@ begin DB 'UpdateSource', 0 @@e_signature: end; - Rpt( 'Updating source for ' + Path, WHITE ); + Rpt('Updating source for ' + Path, WHITE); //Rpt_Stack; Result := False; - if ToolServices <> nil then - try + if ToolServices <> nil then try //Rpt( 'trying to save to IDE Editor: ' + Path ); N := ToolServices.GetUnitCount; - for I := 0 to N - 1 do - begin - S := ToolServices.GetUnitName( I ); - if AnsiLowerCase( S ) = AnsiLowerCase( Path ) then - begin + for I := 0 to N - 1 do begin + s := ToolServices.GetUnitName(I); + if AnsiLowerCase(s) = AnsiLowerCase(Path) then begin //Rpt( 'Updating in IDE: ' + Path ); // unit is loaded into IDE editor - make an attempt to update it from there - Module := ToolServices.GetModuleInterface( S ); - if Module <> nil then - try + Module := ToolServices.GetModuleInterface(s); + if Module <> nil then try Editor := Module.GetEditorInterface; - if Editor <> nil then - try + if Editor <> nil then try Writer := Editor.CreateWriter; Buffer := SL.Text; - if Writer <> nil then - try + if Writer <> nil then try //Rpt( 'Updating source in IDE Editor: ' + Path ); - if Writer.DeleteTo( $3FFFFFFF ) and Writer.Insert( PChar( Buffer ) ) then + if Writer.DeleteTo($3FFFFFFF) and Writer.Insert(PChar(Buffer)) then Result := True; //else Rpt( 'Can not update ' + S ); finally - Writer.Free; + Writer.free; end; finally - Editor.Free; + Editor.free; end; finally - Module.Free; + Module.free; end; - break; + Break; end; end; - {$IFNDEF VER90} - {$IFNDEF VER100} - if not Result and (BorlandIDEServices <> nil) then - begin - if BorlandIDEServices.QueryInterface( IOTAModuleServices, MS ) = 0 then - begin - M := MS.FindModule( Path ); - if M <> nil then - begin +{$IFNDEF VER90} +{$IFNDEF VER100} + if not Result and (BorlandIDEServices <> nil) then begin + if BorlandIDEServices.QueryInterface(IOTAModuleServices, MS) = 0 then begin + M := MS.FindModule(Path); + if M <> nil then begin N := M.GetModuleFileCount; - for I := 0 to N-1 do - begin - E := M.GetModuleFileEditor( I ); - if E.QueryInterface( IOTASourceEditor, SE ) = 0 then - begin - {$IFNDEF VER120} - if E.QueryInterface( IOTAEditBuffer, EB ) = 0 then - begin + for I := 0 to N - 1 do begin + E := M.GetModuleFileEditor(I); + if E.QueryInterface(IOTASourceEditor, SE) = 0 then begin +{$IFNDEF VER120} + if E.QueryInterface(IOTAEditBuffer, EB) = 0 then begin RO := EB.IsReadOnly; if RO then - EB.IsReadOnly := FALSE; + EB.IsReadOnly := False; end; - {$ENDIF} +{$ENDIF} EW := SE.CreateWriter; - if EW <> nil then - begin + if EW <> nil then begin Buffer := SL.Text; - EW.DeleteTo( $3FFFFFFF ); - EW.Insert( PAnsiChar( AnsiString(Buffer) ) ); // TODO: dangerous + EW.DeleteTo($3FFFFFFF); + EW.Insert(PAnsiChar(AnsiString(Buffer))); // TODO: dangerous Result := True; - break; + Break; end; end; end; end; end; end; - {$ENDIF} - {$ENDIF} +{$ENDIF} +{$ENDIF} except - on E: Exception do - begin - ShowMessage( 'Can not update source, exception: ' + E.Message ); + on E: Exception do begin + Showmessage('Can not update source, exception: ' + E.Message); end; end; end; //var SameCmpCount: Integer; -procedure SaveStrings( SL: TStrings; const Path: String; var Updated: Boolean ); -var S1, s: String; - Old: TStringList; - I: Integer; - TheSame: Boolean; - OldCount, NewCount: Integer; + +procedure SaveStrings(SL: TStrings; const Path: string; var Updated: Boolean); +var + S1, s: string; + Old: TStringList; + I: Integer; + TheSame: Boolean; + OldCount, NewCount: Integer; begin asm jmp @@e_signature @@ -3697,44 +3340,39 @@ begin //Rpt( 'SaveStrings: ' + Path ); SL.Text := SL.Text; Old := TStringList.Create; - LoadSource( Old, Path ); + LoadSource(Old, Path); - TheSame := FALSE; - if Old.Count > 0 then - begin + TheSame := False; + if Old.Count > 0 then begin NewCount := SL.Count; - while (NewCount > 1) and (Trim(SL[ NewCount - 1]) = '') do - Dec( NewCount ); + while (NewCount > 1) and (Trim(SL[NewCount - 1]) = '') do + Dec(NewCount); I := 0; - while I < Old.Count do - begin - s := Old[ I ]; - if StrIsStartingFrom( PChar( s ), ' PROC(2) //--by PCompiler:line#' ) then // TODO: dangerous - Old[ I ] := ' PROC(2)' - else - if AnsiCompareText( s, '{$ENDIF Psource}' ) = 0 then - begin - Inc( I ); - while I < Old.Count do - begin - s := Old[ I ]; - if AnsiCompareText( s, '{$ELSE OldCode}' ) = 0 then break; - Old.Delete( I ); + while I < Old.Count do begin + s := Old[I]; + if StrIsStartingFrom(PChar(s), ' PROC(2) //--by PCompiler:line#') then // TODO: dangerous + Old[I] := ' PROC(2)' + else if AnsiCompareText(s, '{$ENDIF Psource}') = 0 then begin + Inc(I); + while I < Old.Count do begin + s := Old[I]; + if AnsiCompareText(s, '{$ELSE OldCode}') = 0 then + Break; + Old.Delete(I); end; end; - inc( I ); + Inc(I); end; OldCount := Old.Count; - while (OldCount > 1) and (Trim(Old[ OldCount - 1 ]) = '') do - Dec( OldCount ); + while (OldCount > 1) and (Trim(Old[OldCount - 1]) = '') do + Dec(OldCount); TheSame := OldCount = NewCount; if TheSame then - for I := 0 to OldCount - 1 do - if Old[ I ] <> SL[ I ] then - begin - TheSame := False; - break; - end; + for I := 0 to OldCount - 1 do + if Old[I] <> SL[I] then begin + TheSame := False; + Break; + end; {if not TheSame then begin Inc( SameCmpCount ); @@ -3746,71 +3384,68 @@ begin + ' (' + Path + '):' + IntToStr( SameCmpCount ) , CYAN ); //Rpt_Stack; end;} - Old.Free; + Old.free; end; - if not TheSame then - begin - Rpt( 'SaveStrings: found that strings are different', LIGHT + BLUE ); //Rpt_Stack; + if not TheSame then begin + Rpt('SaveStrings: found that strings are different', LIGHT + BLUE); //Rpt_Stack; - if UpdateSource( SL, Path ) then - begin + if UpdateSource(SL, Path) then begin //Rpt( 'updated (in IDE Editor): ' + Path ); - if FileExists( Path ) then - SetFileAttributes( PChar( Path ), FILE_ATTRIBUTE_NORMAL ); - Updated := TRUE; + if FileExists(Path) then + SetFileAttributes(PChar(Path), FILE_ATTRIBUTE_NORMAL); + Updated := True; Exit; end; //Rpt( 'writing to ' + Path ); - S1 := Copy( Path, 1, Length( Path ) - 3 ) + '$$$'; - if FileExists( S1 ) then - DeleteFile( S1 ); - SetFileAttributes( PChar( Path ), FILE_ATTRIBUTE_NORMAL ); - MoveFile( PChar( Path ), PChar( S1 ) ); - if KOLProject <> nil then - begin - S1 := KOLProject.OutdcuPath + ExtractFileName( Path ); - if LowerCase( Copy( S1, Length( S1 ) - 3, 4 ) ) = '.inc' then - S1 := Copy( S1, 1, Length( S1 ) - 6 ) + '.dcu' + S1 := Copy(Path, 1, Length(Path) - 3) + '$$$'; + if FileExists(S1) then + DeleteFile(S1); + SetFileAttributes(PChar(Path), FILE_ATTRIBUTE_NORMAL); + MoveFile(PChar(Path), PChar(S1)); + if KOLProject <> nil then begin + S1 := KOLProject.outdcuPath + ExtractFileName(Path); + if LowerCase(Copy(S1, Length(S1) - 3, 4)) = '.inc' then + S1 := Copy(S1, 1, Length(S1) - 6) + '.dcu' else - S1 := Copy( S1, 1, Length( S1 ) - 3 ) + 'dcu'; - if FileExists( S1 ) then - begin + S1 := Copy(S1, 1, Length(S1) - 3) + 'dcu'; + if FileExists(S1) then begin //Rpt( 'Remove: ' + S1 ); - DeleteFile( S1 ); + DeleteFile(S1); end; end; - SL.SaveToFile( Path ); - Updated := TRUE; + SL.SaveToFile(Path); + Updated := True; {if Protect then SetFileAttributes( PAnsiChar( Path ), FILE_ATTRIBUTE_READONLY );} end - else - begin + else begin //Rpt( 'file ' + Path + ' is the same.' ); Exit; end; end; -procedure SaveStringToFile(const Path, Str: String ); -var SL: TStringList; +procedure SaveStringToFile(const Path, Str: string); +var + SL: TStringList; begin SL := TStringList.Create; - TRY - SL.Text := Str; - SL.SaveToFile( Path ); - FINALLY - SL.Free; - END; + try + SL.Text := Str; + SL.SaveToFile(Path); + finally + SL.free; + end; end; -procedure MarkModified( const Path: String ); +procedure MarkModified(const Path: string); {$IFNDEF VER90} {$IFNDEF VER100} -var MS: IOTAModuleServices; - M: IOTAModule; - E: IOTAEditor; - I, N: Integer; +var + MS: IOTAModuleServices; + M: IOTAModule; + E: IOTAEditor; + I, N: Integer; {$ENDIF} {$ENDIF} begin @@ -3820,23 +3455,19 @@ begin DB 'MarkModified', 0 @@e_signature: end; - Rpt( 'MarkModified: ' + Path, WHITE ); //Rpt_Stack; + Rpt('MarkModified: ' + Path, WHITE); //Rpt_Stack; {$IFNDEF VER90} {$IFNDEF VER100} if (BorlandIDEServices <> nil) and - (BorlandIDEServices.QueryInterface( IOTAModuleServices, MS ) = 0) then - begin - M := MS.FindModule( Path ); - if M <> nil then - begin + (BorlandIDEServices.QueryInterface(IOTAModuleServices, MS) = 0) then begin + M := MS.FindModule(Path); + if M <> nil then begin N := M.GetModuleFileCount; - for I := 0 to N-1 do - begin - E := M.GetModuleFileEditor( I ); - if E <> nil then - begin + for I := 0 to N - 1 do begin + E := M.GetModuleFileEditor(I); + if E <> nil then begin E.MarkModified; - break; + Break; end; end; end; @@ -3845,8 +3476,9 @@ begin {$ENDIF} end; -procedure UpdateUnit( const Path: String ); -var MI: TIModuleInterface; +procedure UpdateUnit(const Path: string); +var + MI: TIModuleInterface; begin asm jmp @@e_signature @@ -3854,27 +3486,29 @@ begin DB 'UpdateUnit', 0 @@e_signature: end; - if ToolServices = nil then Exit; - MI := ToolServices.GetModuleInterface( Path ); - if MI <> nil then - TRY - Rpt( 'Update Unit: ' + Path, WHITE ); //Rpt_Stack; - MI.Save( TRUE ); - FINALLY - MI.Free; - END; + if ToolServices = nil then + Exit; + MI := ToolServices.GetModuleInterface(Path); + if MI <> nil then try + Rpt('Update Unit: ' + Path, WHITE); //Rpt_Stack; + MI.Save(True); + finally + MI.free; + end; end; -procedure AddLongTextField( var SL: TStringList; const Prefix:String; - const Text:TDelphiString; const Suffix:String; const LinePrefix: String ); +procedure AddLongTextField(var SL: TStringList; const Prefix: string; const Text: TDelphiString; + const Suffix: string; const LinePrefix: string); +const + LIMIT = 80; + var {$IFDEF _D2009orHigher} - C, C2: WideString; - j : integer; + c, C2: WideString; + j: Integer; {$ENDIF} + I, k, N: Integer; - i,k,n:Integer; -const LIMIT = 80; begin asm jmp @@e_signature @@ -3882,73 +3516,70 @@ begin DB 'AddLongTextField', 0 @@e_signature: end; - if ( Length( Text ) > LIMIT ) then - begin - SL.Add( Prefix + '''''' ); + + if (Length(Text) > LIMIT) then begin + SL.Add(Prefix + ''''''); - k := Length( Text ); - i := 0; - while ( i <> k ) do - begin - inc(i); - n := ( i mod LIMIT ); - if ( ( n = LIMIT - 1 ) or ( i = k ) ) then - begin - if pos( '+', LinePrefix ) > 0 then - begin - {$IFDEF _D2009orHigher} - C := Text; - C2 := ''; - for j := i + 1 - n to i + 1 do C2 := C2 + '#'+int2str(ord(C[j])); - SL.Add( LinePrefix + C2); - {$ELSE} - SL.Add( LinePrefix + String2Pascal( - Copy( Text, i + 1 - n, n + 1 ), '+' ) ); - {$ENDIF} - end - else - begin - {$IFDEF _D2009orHigher} - Msgok(''); - C := Text; - C2 := ''; - for j := i + 1 - n to i + 1 do C2 := C2 + '#'+int2str(ord(C[j])); - SL.Add( LinePrefix + C2 ); - {$ELSE} - SL.Add( LinePrefix + String2Pascal( - Copy( Text, i + 1 - n, n + 1 ), ',' ) ) - {$ENDIF} - end; - end; - end; - - SL.Add( Suffix ); - end - else - begin - if pos( '+', LinePrefix ) > 0 then - begin - {$IFDEF _D2009orHigher} - C := Text; + k := Length(Text); + I := 0; + while (I <> k) do begin + Inc(I); + N := (I mod LIMIT); + if ((N = LIMIT - 1) or (I = k)) then begin + if Pos('+', LinePrefix) > 0 then begin +{$IFDEF _D2009orHigher} + c := Text; C2 := ''; - for j := 1 to Length(C) do C2 := C2 + '#'+int2str(ord(C[j])); - SL.Add( Prefix + C2 + Suffix ) - {$ELSE} - SL.Add( Prefix + String2Pascal(Text, '+') + Suffix ) - {$ENDIF} + for j := I + 1 - N to I + 1 do + C2 := C2 + '#' + int2str(Ord(c[j])); + SL.Add(LinePrefix + C2); +{$ELSE} + SL.Add(LinePrefix + String2Pascal( + Copy(Text, I + 1 - N, N + 1), '+')); +{$ENDIF} end - else - begin - {$IFDEF _D2009orHigher} - C := Text; + else begin +{$IFDEF _D2009orHigher} + Msgok(''); + c := Text; C2 := ''; - for j := 1 to Length(C) do C2 := C2 + '#'+int2str(ord(C[j])); - SL.Add( Prefix + C2 + Suffix ) - {$ELSE} - SL.Add( Prefix + String2Pascal(Text, ',') + Suffix ) - {$ENDIF} + for j := I + 1 - N to I + 1 do + C2 := C2 + '#' + int2str(Ord(c[j])); + SL.Add(LinePrefix + C2); +{$ELSE} + SL.Add(LinePrefix + String2Pascal( + Copy(Text, I + 1 - N, N + 1), ',')) +{$ENDIF} end; - end; + end; + end; + + SL.Add(Suffix); + end + else begin + if Pos('+', LinePrefix) > 0 then begin +{$IFDEF _D2009orHigher} + c := Text; + C2 := ''; + for j := 1 to Length(c) do + C2 := C2 + '#' + int2str(Ord(c[j])); + SL.Add(Prefix + C2 + Suffix) +{$ELSE} + SL.Add(Prefix + String2Pascal(Text, '+') + Suffix) +{$ENDIF} + end + else begin +{$IFDEF _D2009orHigher} + c := Text; + C2 := ''; + for j := 1 to Length(c) do + C2 := C2 + '#' + int2str(Ord(c[j])); + SL.Add(Prefix + C2 + Suffix) +{$ELSE} + SL.Add(Prefix + String2Pascal(Text, ',') + Suffix) +{$ENDIF} + end; + end; end; {procedure OutSortedListOfComponents( const path: String; L: TList; ii: Integer ); @@ -3981,67 +3612,65 @@ begin END; end;} - - - {YS}//-------------------------------------------------------------- {$IFNDEF NOT_USE_KOLCTRLWRAPPER} -function InterceptWndProc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer ): Integer; stdcall; + +function InterceptWndProc(W: HWnd; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall; var KOLParentCtrl: PControl; _Msg: KOL.TMsg; - OldWndProc: pointer; + OldWndProc: Pointer; begin - KOLParentCtrl:=PControl(GetProp(W, 'KOLParentCtrl')); - OldWndProc:=pointer(GetProp(W, 'OldWndProc')); + KOLParentCtrl := PControl(GetProp(W, 'KOLParentCtrl')); + OldWndProc := Pointer(GetProp(W, 'OldWndProc')); if Assigned(KOLParentCtrl) and KOLParentCtrl.HandleAllocated then - if (Msg in [WM_DRAWITEM, WM_NOTIFY, WM_SIZE, WM_MEASUREITEM]) then begin - _Msg.hwnd:=KOLParentCtrl.Handle; - _Msg.message:=Msg; - _Msg.wParam:=WParam; - _Msg.lParam:=LParam; - KOLParentCtrl.WndProc(_Msg); - end; + if (Msg in [WM_DRAWITEM, WM_NOTIFY, WM_SIZE, WM_MEASUREITEM]) then begin + _Msg.HWnd := KOLParentCtrl.Handle; + _Msg.Message := Msg; + _Msg.wParam := wParam; + _Msg.lParam := lParam; + KOLParentCtrl.WndProc(_Msg); + end; - Result:=CallWindowProc(OldWndProc, W, Msg, wParam, lParam); + Result := CallWindowProc(OldWndProc, W, Msg, wParam, lParam); end; -function EnumChildProc(wnd: HWND; lParam: integer): BOOL; stdcall; +function EnumChildProc(Wnd: HWnd; lParam: Integer): BOOL; stdcall; begin - ShowWindow(wnd, lParam); - Result:=True; + ShowWindow(Wnd, lParam); + Result := True; end; { TKOLVCLParent } function NewKOLVCLParent: PKOLVCLParent; begin - Log( '->NewKOLVCLParent' ); - TRY - New( Result, CreateParented( nil ) ); + Log('->NewKOLVCLParent'); + try + New(Result, CreateParented(nil)); Result.fControlClassName := 'KOLVCLParent'; - Result.Visible:=False; + Result.Visible := False; LogOK; - FINALLY - Log( '<-NewKOLVCLParent' ); - END; + finally + Log('<-NewKOLVCLParent'); + end; end; {$ENDIF NOT_USE_KOLCTRLWRAPPER} -procedure TKOLVCLParent.AttachHandle(AHandle: HWND); +procedure TKOLVCLParent.AttachHandle(AHandle: HWnd); begin - fHandle:=AHandle; + fHandle := AHandle; end; procedure TKOLVCLParent.AssignDynHandlers(Src: PKOLVCLParent); -var i: integer; +var + I: Integer; begin - i:=0; - while i < Src.fDynHandlers.Count do - begin + I := 0; + while I < Src.fDynHandlers.Count do begin if fDynHandlers = nil then fDynHandlers := NewList else @@ -4049,8 +3678,8 @@ begin begin //AttachProcEx(Src.fDynHandlers.Items[i], boolean(Src.fDynHandlers.Items[i + 1])); //Inc(i, 2); - fDynHandlers.Add( Src.fDynHandlers.Items[ i ] ); - inc( i ); + fDynHandlers.Add(Src.fDynHandlers.Items[I]); + Inc(I); end; end; end; @@ -4060,27 +3689,28 @@ end; constructor TKOLCtrlWrapper.Create(AOwner: TComponent); begin - Log( '->TKOLCtrlWrapper.Create' ); - TRY - Log( '//// inherited starting' ); + Log('->TKOLCtrlWrapper.Create'); + try + Log('//// inherited starting'); inherited; - Log( '//// inherited called' ); - FAllowSelfPaint:=True; - {$IFDEF _KOLCtrlWrapper_} + Log('//// inherited called'); + FAllowSelfPaint := True; +{$IFDEF _KOLCtrlWrapper_} CreateKOLControl(False); - {$ENDIF} +{$ENDIF} LogOK; - FINALLY - Log( '<-TKOLCtrlWrapper.Create' ); - END; + finally + Log('<-TKOLCtrlWrapper.Create'); + end; end; destructor TKOLCtrlWrapper.Destroy; -var FRP: Boolean; - FKPC: PKOLVCLParent; +var + FRP: Boolean; + FKPC: PKOLVCLParent; begin if Assigned(FKOLCtrl) then begin - Parent:=nil; + Parent := nil; if Assigned(FKOLCtrl) and (FKOLCtrl.Parent <> nil) and not FRealParent then begin FKOLParentCtrl.RefDec; RemoveParentAttach; @@ -4090,15 +3720,15 @@ begin FKPC := FKOLParentCtrl; inherited; if not FRP and Assigned(FKPC) and (FKPC.RefCount = 0) then - FKOLParentCtrl.Free; + FKOLParentCtrl.free; end; procedure TKOLCtrlWrapper.RemoveParentAttach; var - wp: integer; + wp: Integer; begin if not FRealParent and (FKOLParentCtrl.RefCount <= 1) and FKOLParentCtrl.HandleAllocated then begin - wp:=GetProp(FKOLParentCtrl.Handle, 'OldWndProc'); + wp := GetProp(FKOLParentCtrl.Handle, 'OldWndProc'); if wp <> 0 then SetWindowLong(FKOLParentCtrl.Handle, GWL_WNDPROC, wp); RemoveProp(FKOLParentCtrl.Handle, 'KOLParentCtrl'); @@ -4114,144 +3744,139 @@ var procedure AssignNewParent; begin KP.AssignDynHandlers(FKOLParentCtrl); - FKOLCtrl.Parent:=KP; + FKOLCtrl.Parent := KP; Windows.SetParent(FKOLCtrl.Handle, Value.Handle); if not FRealParent then - FKOLParentCtrl.Free; - FKOLParentCtrl:=KP; + FKOLParentCtrl.free; + FKOLParentCtrl := KP; end; var F: TCustomForm; begin - Log( '->TKOLCtrlWrapper.SetParent Self:' + Int2Hex( DWORD( Self ), 6 ) ); - TRY + Log('->TKOLCtrlWrapper.SetParent Self:' + Int2Hex(DWORD(Self), 6)); + try - Log( 'A' ); - if Assigned(FKOLCtrl) and (Parent <> Value) then - begin - Log( 'B' ); - if Assigned(Parent) then begin - FKOLCtrl.Parent:=nil; - if not FRealParent then begin - FKOLParentCtrl.RefDec; - RemoveParentAttach; - end; - end; - Log( 'C' ); - if Assigned(Value) then - begin - Log( 'D' ); - if (Value is TKOLCtrlWrapper) and Assigned(TKOLCtrlWrapper(Value).FKOLCtrl) then - KP:=PKOLVCLParent(TKOLCtrlWrapper(Value).FKOLCtrl) - else - KP:=PKOLVCLParent(GetProp(Value.Handle, 'KOLParentCtrl')); - if Assigned(KP) then begin - AssignNewParent; - FRealParent:=(Value is TKOLCtrlWrapper) and Assigned(TKOLCtrlWrapper(Value).FKOLCtrl); - end - else - begin - Log( 'E' ); - FRealParent:=False; - if FKOLParentCtrl.HandleAllocated then - begin - KP:=NewKOLVCLParent; - AssignNewParent; + Log('A'); + if Assigned(FKOLCtrl) and (Parent <> Value) then begin + Log('B'); + if Assigned(Parent) then begin + FKOLCtrl.Parent := nil; + if not FRealParent then begin + FKOLParentCtrl.RefDec; + RemoveParentAttach; end; - Log( 'F' ); - FKOLParentCtrl.AttachHandle(Value.Handle); - SetProp(Value.Handle, 'KOLParentCtrl', integer(FKOLParentCtrl)); - SetProp(Value.Handle, 'OldWndProc', GetWindowLong(Value.Handle, GWL_WNDPROC)); - SetWindowLong(Value.Handle, GWL_WNDPROC, integer(@InterceptWndProc)); end; - Log( 'G' ); - if not FRealParent then - FKOLParentCtrl.RefInc; - FKOLCtrl.Style:=FKOLCtrl.Style or WS_CLIPSIBLINGS; + Log('C'); + if Assigned(Value) then begin + Log('D'); + if (Value is TKOLCtrlWrapper) and Assigned(TKOLCtrlWrapper(Value).FKOLCtrl) then + KP := PKOLVCLParent(TKOLCtrlWrapper(Value).FKOLCtrl) + else + KP := PKOLVCLParent(GetProp(Value.Handle, 'KOLParentCtrl')); + if Assigned(KP) then begin + AssignNewParent; + FRealParent := (Value is TKOLCtrlWrapper) and Assigned(TKOLCtrlWrapper(Value).FKOLCtrl); + end + else begin + Log('E'); + FRealParent := False; + if FKOLParentCtrl.HandleAllocated then begin + KP := NewKOLVCLParent; + AssignNewParent; + end; + Log('F'); + FKOLParentCtrl.AttachHandle(Value.Handle); + SetProp(Value.Handle, 'KOLParentCtrl', Integer(FKOLParentCtrl)); + SetProp(Value.Handle, 'OldWndProc', GetWindowLong(Value.Handle, GWL_WNDPROC)); + SetWindowLong(Value.Handle, GWL_WNDPROC, Integer(@InterceptWndProc)); + end; + Log('G'); + if not FRealParent then + FKOLParentCtrl.RefInc; + FKOLCtrl.Style := FKOLCtrl.Style or WS_CLIPSIBLINGS; + end; + Log('H'); end; - Log( 'H' ); + Log('I'); + inherited; + Log('J'); + if Assigned(FKOLCtrl) and Assigned(Value) and not (csLoading in ComponentState) then begin + Log('K'); + HandleNeeded; + Log('L'); + F := GetParentForm(Self); + Log('M'); + if Assigned(F) then + Windows.SetFocus(F.Handle); + Log('N'); + UpdateAllowSelfPaint; + end; + Log('O'); + LogOK; + finally + Log('<-TKOLCtrlWrapper.SetParent'); end; - Log( 'I' ); - inherited; - Log( 'J' ); - if Assigned(FKOLCtrl) and Assigned(Value) and not(csLoading in ComponentState) then - begin - Log( 'K' ); - HandleNeeded; - Log( 'L' ); - F:=GetParentForm(Self); - Log( 'M' ); - if Assigned(F) then - Windows.SetFocus(F.Handle); - Log( 'N' ); - UpdateAllowSelfPaint; - end; - Log( 'O' ); - LogOK; - FINALLY - Log( '<-TKOLCtrlWrapper.SetParent' ); - END; end; procedure TKOLCtrlWrapper.WndProc(var Message: TMessage); var - DeniedMessage: boolean; + DeniedMessage: Boolean; DC: HDC; PS: TPaintStruct; begin - Log( '->TKOLCtrlWrapper.WndProc: ' + Int2Hex( Message.Msg, 2 ) + '(' + - Int2Str( Message.Msg ) + ')' ); - TRY + Log('->TKOLCtrlWrapper.WndProc: ' + Int2Hex(Message.Msg, 2) + '(' + + int2str(Message.Msg) + ')'); + try if Assigned(FKOLCtrl) then begin - DeniedMessage:=(((Message.Msg >= WM_MOUSEFIRST) and (Message.Msg <= WM_MOUSELAST)) or - ((Message.Msg >= WM_KEYFIRST) and (Message.Msg <= WM_KEYLAST)) or - (Message.Msg in [WM_NCHITTEST, WM_SETCURSOR]) or - (Message.Msg = CM_DESIGNHITTEST) or (Message.Msg = CM_RECREATEWND)); + DeniedMessage := (((Message.Msg >= WM_MOUSEFIRST) and (Message.Msg <= WM_MOUSELAST)) or + ((Message.Msg >= WM_KEYFIRST) and (Message.Msg <= WM_KEYLAST)) or + (Message.Msg in [WM_NCHITTEST, WM_SETCURSOR]) or + (Message.Msg = CM_DESIGNHITTEST) or (Message.Msg = CM_RECREATEWND)); - if not FAllowSelfPaint and (Message.Msg in [WM_NCCALCSIZE, WM_ERASEBKGND]) then - begin - LogOK; exit; + if not FAllowSelfPaint and (Message.Msg in [WM_NCCALCSIZE, WM_ERASEBKGND]) then begin + LogOK; + Exit; end; if FAllowSelfPaint or (Message.Msg <> WM_PAINT) then if not DeniedMessage then - CallKOLCtrlWndProc(Message); + CallKOLCtrlWndProc(Message); if (FKOLCtrl.Parent = nil) and (Message.Msg = WM_NCDESTROY) then begin - FKOLCtrl:=nil; + FKOLCtrl := nil; if not FRealParent and Assigned(FKOLParentCtrl) and (FKOLParentCtrl.RefCount = 0) then begin - FKOLParentCtrl.Free; - FKOLParentCtrl:=nil; + FKOLParentCtrl.free; + FKOLParentCtrl := nil; end; LogOK; - exit; + Exit; end; if not (DeniedMessage or - (Message.Msg in [WM_PAINT, WM_SIZE, WM_MOVE, WM_WINDOWPOSCHANGED, WM_WINDOWPOSCHANGING, WM_DESTROY])) - then - begin - LogOK; exit; + (Message.Msg in [WM_PAINT, WM_SIZE, WM_MOVE, WM_WINDOWPOSCHANGED, WM_WINDOWPOSCHANGING, WM_DESTROY])) then begin + LogOK; + Exit; end; if (Message.Msg = WM_PAINT) then begin if FAllowSelfPaint then - DC:=GetDC(WindowHandle) + DC := GetDC(WindowHandle) else - DC:=BeginPaint(WindowHandle, PS); + DC := BeginPaint(WindowHandle, PS); try - Message.WParam:=DC; + Message.wParam := DC; inherited; finally if FAllowSelfPaint then - ReleaseDC( WindowHandle, DC ) + ReleaseDC(WindowHandle, DC) else EndPaint(WindowHandle, PS); end; - LogOK; exit; + LogOK; + Exit; end; end; @@ -4259,135 +3884,130 @@ begin if (Message.Msg = CM_RECREATEWND) and FKOLCtrlNeeded then HandleNeeded; LogOK; - FINALLY - Log( '<-TKOLCtrlWrapper.WndProc: ' + Int2Hex( Message.Msg, 2 ) + '(' + Int2Str( Message.Msg ) + ')' ); - END; + finally + Log('<-TKOLCtrlWrapper.WndProc: ' + Int2Hex(Message.Msg, 2) + '(' + int2str(Message.Msg) + ')'); + end; end; procedure TKOLCtrlWrapper.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); -var R: TRect; +var + R: TRect; begin - Log( '->TKOLCtrlWrapper.SetBounds' ); + Log('->TKOLCtrlWrapper.SetBounds'); try - TRY - //Log( 'TKOLCtrlWrapper.SetBounds-1' ); - //if not( csLoading in ComponentState ) then - begin - //Log( 'TKOLCtrlWrapper.SetBounds-1A - very often crashed here on loading project' ); - //Rpt_Stack; - inherited SetBounds( ALeft, ATop, AWidth, AHeight ); - //Log( 'TKOLCtrlWrapper.SetBounds-1B' ); - R := BoundsRect; - //Log( 'TKOLCtrlWrapper.SetBounds-1C' ); - end + try + //Log( 'TKOLCtrlWrapper.SetBounds-1' ); + //if not( csLoading in ComponentState ) then + begin + //Log( 'TKOLCtrlWrapper.SetBounds-1A - very often crashed here on loading project' ); + //Rpt_Stack; + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + //Log( 'TKOLCtrlWrapper.SetBounds-1B' ); + R := BoundsRect; + //Log( 'TKOLCtrlWrapper.SetBounds-1C' ); + end {else begin //Log( 'TKOLCtrlWrapper.SetBounds-1D' ); R := Rect( ALeft, ATop, ALeft+AWidth, ATop+AHeight ); //Log( 'TKOLCtrlWrapper.SetBounds-1E' ); end}; - //Log( 'TKOLCtrlWrapper.SetBounds-2' ); - if Assigned(FKOLCtrl) then - begin - //Log( 'TKOLCtrlWrapper.SetBounds-3' ); - if FKOLCtrl <> nil then - begin - //Log( 'TKOLCtrlWrapper.SetBounds-3A' ); - //Log( 'FKOLCtrl.Handle = ' + IntToStr( FKOLCtrl.Handle ) ); - //Log( 'FKOLCtrl.Parent = ' + IntToStr( DWORD( FKOLCtrl.Parent ) ) ); - FKOLCtrl.BoundsRect := R; - //Log( 'TKOLCtrlWrapper.SetBounds-3B' ); + //Log( 'TKOLCtrlWrapper.SetBounds-2' ); + if Assigned(FKOLCtrl) then begin + //Log( 'TKOLCtrlWrapper.SetBounds-3' ); + if FKOLCtrl <> nil then begin + //Log( 'TKOLCtrlWrapper.SetBounds-3A' ); + //Log( 'FKOLCtrl.Handle = ' + IntToStr( FKOLCtrl.Handle ) ); + //Log( 'FKOLCtrl.Parent = ' + IntToStr( DWORD( FKOLCtrl.Parent ) ) ); + FKOLCtrl.BoundsRect := R; + //Log( 'TKOLCtrlWrapper.SetBounds-3B' ); + end; + //Log( 'TKOLCtrlWrapper.SetBounds-4' ); + if not FAllowSelfPaint and HandleAllocated then begin + //Log( 'TKOLCtrlWrapper.SetBounds-5' ); + UpdateAllowSelfPaint; + //Log( 'TKOLCtrlWrapper.SetBounds-6' ); + end; + //Log( 'TKOLCtrlWrapper.SetBounds-7' ); end; - //Log( 'TKOLCtrlWrapper.SetBounds-4' ); - if not FAllowSelfPaint and HandleAllocated then - begin - //Log( 'TKOLCtrlWrapper.SetBounds-5' ); - UpdateAllowSelfPaint; - //Log( 'TKOLCtrlWrapper.SetBounds-6' ); - end; - //Log( 'TKOLCtrlWrapper.SetBounds-7' ); + except + on E: Exception do + Rpt('Exception in TKOLCtrlWrapper.SetBounds: ' + E.Message, RED); end; - EXCEPT - on E: EXception do - Rpt( 'Exception in TKOLCtrlWrapper.SetBounds: ' + E.Message, RED ); - END; - LogOK; + LogOK; finally - Log( '<-TKOLCtrlWrapper.SetBounds' ); + Log('<-TKOLCtrlWrapper.SetBounds'); end; end; procedure TKOLCtrlWrapper.CreateWnd; begin - Log( '->TKOLCtrlWrapper.CreateWnd(' + Name + ')' ); - TRY + Log('->TKOLCtrlWrapper.CreateWnd(' + name + ')'); + try - if not Assigned(FKOLCtrl) and FKOLCtrlNeeded then - begin - CreateKOLControl(True); - if Assigned(FKOLCtrl) then - FKOLCtrl.BoundsRect:=BoundsRect; + if not Assigned(FKOLCtrl) and FKOLCtrlNeeded then begin + CreateKOLControl(True); + if Assigned(FKOLCtrl) then + FKOLCtrl.BoundsRect := BoundsRect; + end; + if Assigned(FKOLCtrl) then begin + WindowHandle := FKOLCtrl.GetWindowHandle; + CreationControl := Self; + InitWndProc(WindowHandle, 0, 0, 0); + if FKOLCtrlNeeded then + KOLControlRecreated; + FKOLCtrlNeeded := False; + UpdateAllowSelfPaint; + FKOLCtrl.Visible := True; + end + else + inherited; + + LogOK; + finally + Log('<-TKOLCtrlWrapper.CreateWnd(' + name + ')'); end; - if Assigned(FKOLCtrl) then begin - WindowHandle:=FKOLCtrl.GetWindowHandle; - CreationControl:=Self; - InitWndProc(WindowHandle, 0, 0, 0); - if FKOLCtrlNeeded then - KOLControlRecreated; - FKOLCtrlNeeded:=False; - UpdateAllowSelfPaint; - FKOLCtrl.Visible:=True; - end - else - inherited; - - LogOK; - FINALLY - Log( '<-TKOLCtrlWrapper.CreateWnd(' + Name + ')' ); - END; end; procedure TKOLCtrlWrapper.DestroyWindowHandle; var - i: integer; + I: Integer; begin - Log( '->TKOLCtrlWrapper.DestroyWindowHandle(' + Name + ')' ); - TRY - Log( 'A' ); - if Assigned(FKOLCtrl) then - begin - Log( 'B' ); - while FKOLCtrl.ChildCount > 0 do - FKOLCtrl.Children[0].Parent:=nil; - Log( 'C' ); - WindowHandle:=0; - ControlState:=ControlState + [csDestroyingHandle]; - Log( 'D' ); - try - FKOLCtrl.Free; - finally - ControlState:=ControlState - [csDestroyingHandle]; - end; - Log( 'E' ); - FKOLCtrl:=nil; - if not (csDestroying in ComponentState) then - begin - Log( 'F' ); - for i:=0 to ControlCount - 1 do - if Controls[i] is TKOLCtrlWrapper then - with TKOLCtrlWrapper(Controls[i]) do begin - FKOLParentCtrl:=nil; - end; - end; - Log( 'G' ); - FKOLCtrlNeeded:=True; - end - else - inherited; - LogOK; - FINALLY - Log( '<-TKOLCtrlWrapper.DestroyWindowHandle(' + Name + ')' ); - END; + Log('->TKOLCtrlWrapper.DestroyWindowHandle(' + name + ')'); + try + Log('A'); + if Assigned(FKOLCtrl) then begin + Log('B'); + while FKOLCtrl.ChildCount > 0 do + FKOLCtrl.Children[0].Parent := nil; + Log('C'); + WindowHandle := 0; + ControlState := ControlState + [csDestroyingHandle]; + Log('D'); + try + FKOLCtrl.free; + finally + ControlState := ControlState - [csDestroyingHandle]; + end; + Log('E'); + FKOLCtrl := nil; + if not (csDestroying in ComponentState) then begin + Log('F'); + for I := 0 to ControlCount - 1 do + if Controls[I] is TKOLCtrlWrapper then + with TKOLCtrlWrapper(Controls[I]) do begin + FKOLParentCtrl := nil; + end; + end; + Log('G'); + FKOLCtrlNeeded := True; + end + else + inherited; + LogOK; + finally + Log('<-TKOLCtrlWrapper.DestroyWindowHandle(' + name + ')'); + end; end; procedure TKOLCtrlWrapper.DefaultHandler(var Message); @@ -4404,29 +4024,27 @@ procedure TKOLCtrlWrapper.CallKOLCtrlWndProc(var Message: TMessage); var _Msg: KOL.TMsg; begin - Log( '->TKOLCtrlWrapper.CallKOLCtrlWndProc' ); + Log('->TKOLCtrlWrapper.CallKOLCtrlWndProc'); try if csLoading in ComponentState then - else - begin - _Msg.hwnd:=FKOLCtrl.GetWindowHandle; - Log( 'hwnd: ' + Int2Str( _Msg.hwnd ) ); - _Msg.message:=Message.Msg; - _Msg.wParam:=Message.wParam; - _Msg.lParam:=Message.lParam; - Log('msg:'+Int2Str( Message.Msg ) + ' FKOLCtrl:' + Int2Hex( DWORD( FKOLCtrl ), 6 ) ); - TRY - Message.Result:=FKOLCtrl.WndProc(_Msg); - Log('result:' + Int2Str( Message.Result )); - EXCEPT on E: Exception do - begin - Log( '*** Exception ' + E.Message ); - end; - END; + else begin + _Msg.HWnd := FKOLCtrl.GetWindowHandle; + Log('hwnd: ' + int2str(_Msg.HWnd)); + _Msg.Message := Message.Msg; + _Msg.wParam := Message.wParam; + _Msg.lParam := Message.lParam; + Log('msg:' + int2str(Message.Msg) + ' FKOLCtrl:' + Int2Hex(DWORD(FKOLCtrl), 6)); + try + Message.Result := FKOLCtrl.WndProc(_Msg); + Log('result:' + int2str(Message.Result)); + except on E: Exception do begin + Log('*** Exception ' + E.Message); + end; + end; end; LogOK; finally - Log( '<-TKOLCtrlWrapper.CallKOLCtrlWndProc' ); + Log('<-TKOLCtrlWrapper.CallKOLCtrlWndProc'); end; end; @@ -4434,35 +4052,34 @@ procedure TKOLCtrlWrapper.Invalidate; begin if not Assigned(FKOLCtrl) then inherited - else - begin - if HandleAllocated then - begin + else begin + if HandleAllocated then begin InvalidateRect(WindowHandle, nil, not (csOpaque in ControlStyle)) end; FKOLCtrl.Invalidate; end; end; -procedure TKOLCtrlWrapper.SetAllowSelfPaint(const Value: boolean); +procedure TKOLCtrlWrapper.SetAllowSelfPaint(const Value: Boolean); begin - if FAllowSelfPaint = Value then exit; + if FAllowSelfPaint = Value then + Exit; FAllowSelfPaint := Value; UpdateAllowSelfPaint; end; procedure TKOLCtrlWrapper.UpdateAllowSelfPaint; var - i: integer; + I: Integer; begin if Assigned(FKOLCtrl) and HandleAllocated then begin if not (csAcceptsControls in ControlStyle) then begin if FAllowSelfPaint then - i:=SW_SHOW + I := SW_SHOW else - i:=SW_HIDE; - EnumChildWindows(WindowHandle, @EnumChildProc, i); + I := SW_HIDE; + EnumChildWindows(WindowHandle, @EnumChildProc, I); end; SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_DRAWFRAME or SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER); Invalidate; @@ -4471,32 +4088,32 @@ end; function TKOLCtrlWrapper.GetKOLParentCtrl: PControl; begin - Log( '->TKOLCtrlWrapper.GetKOLParentCtrl' ); - TRY + Log('->TKOLCtrlWrapper.GetKOLParentCtrl'); + try if (FKOLParentCtrl = nil) and (FKOLCtrl = nil) then begin if Assigned(Parent) and (Parent is TKOLCtrlWrapper) and Assigned(TKOLCtrlWrapper(Parent).FKOLCtrl) then - FKOLParentCtrl:=PKOLVCLParent(TKOLCtrlWrapper(Parent).FKOLCtrl) + FKOLParentCtrl := PKOLVCLParent(TKOLCtrlWrapper(Parent).FKOLCtrl) else - FKOLParentCtrl:=NewKOLVCLParent; + FKOLParentCtrl := NewKOLVCLParent; end; - Result:=FKOLParentCtrl; + Result := FKOLParentCtrl; LogOK; - FINALLY - Log( '<-TKOLCtrlWrapper.GetKOLParentCtrl Result:' + Int2Hex( DWORD( Result ),6 ) ); - END; + finally + Log('<-TKOLCtrlWrapper.GetKOLParentCtrl Result:' + Int2Hex(DWORD(Result), 6)); + end; end; procedure TKOLCtrlWrapper.PaintWindow(DC: HDC); begin if Assigned(FKOLCtrl) and not FAllowCustomPaint and not FAllowPostPaint then - exit; + Exit; inherited; end; -procedure TKOLCtrlWrapper.CreateKOLControl(Recreating: boolean); +procedure TKOLCtrlWrapper.CreateKOLControl(Recreating: Boolean); begin - Log( 'TKOLCtrlWrapper.CreateKOLControl(' + - IntToStr( Integer( Recreating ) ) + ') for ' + ClassName ); + Log('TKOLCtrlWrapper.CreateKOLControl(' + + IntToStr(Integer(Recreating)) + ') for ' + ClassName); end; procedure TKOLCtrlWrapper.KOLControlRecreated; @@ -4506,27 +4123,26 @@ end; procedure TKOLCtrlWrapper.DestroyWnd; begin inherited; - if FKOLCtrlNeeded then - begin + if FKOLCtrlNeeded then begin StrDispose(WindowText); - WindowText:=nil; + WindowText := nil; end; end; {$ENDIF NOT_USE_KOLCTRLWRAPPER} procedure TKOLCtrlWrapper.Change; begin - Log( '->TKOLCtrlWrapper.Change' ); - TRY - LogOK; - FINALLY - Log( '<-TKOLCtrlWrapper.Change' ); - END; + Log('->TKOLCtrlWrapper.Change'); + try + LogOK; + finally + Log('<-TKOLCtrlWrapper.Change'); + end; end; { TKOLCustomControl } -function TKOLCustomControl.AdditionalUnits: String; +function TKOLCustomControl.AdditionalUnits: string; begin asm jmp @@e_signature @@ -4538,8 +4154,9 @@ begin end; procedure TKOLCustomControl.ApplyColorToChildren; -var I: Integer; - C: TKOLCustomControl; +var + I: Integer; + c: TKOLCustomControl; begin asm jmp @@e_signature @@ -4547,23 +4164,23 @@ begin DB 'TKOLCustomControl.ApplyFontToChildren', 0 @@e_signature: end; - Log( '->TKOLCustomControl.ApplyColorToChildren' ); + Log('->TKOLCustomControl.ApplyColorToChildren'); try - for I := 0 to FParentLikeColorControls.Count - 1 do - begin - C := FParentLikeColorControls[ I ]; - if C.ParentColor and (C.Color <> Color) then - C.Color := Color; - end; - LogOK; + for I := 0 to FParentLikeColorControls.Count - 1 do begin + c := FParentLikeColorControls[I]; + if c.parentColor and (c.Color <> Color) then + c.Color := Color; + end; + LogOK; finally - Log( '<-TKOLCustomControl.ApplyColorToChildren' ); + Log('<-TKOLCustomControl.ApplyColorToChildren'); end; end; procedure TKOLCustomControl.ApplyFontToChildren; -var I: Integer; - C: TKOLCustomControl; +var + I: Integer; + c: TKOLCustomControl; begin asm jmp @@e_signature @@ -4571,22 +4188,21 @@ begin DB 'TKOLCustomControl.ApplyFontToChildren', 0 @@e_signature: end; - Log( '->TKOLCustomControl.ApplyFontToChildren' ); + Log('->TKOLCustomControl.ApplyFontToChildren'); try - if AutoSize then - AutoSizeNow; - for I := 0 to FParentLikeFontControls.Count - 1 do - begin - C := FParentLikeFontControls[ I ]; - C.Font.Assign( Font ); - end; - LogOK; + if autoSize then + AutoSizeNow; + for I := 0 to FParentLikeFontControls.Count - 1 do begin + c := FParentLikeFontControls[I]; + c.Font.Assign(Font); + end; + LogOK; finally - Log( '<-TKOLCustomControl.ApplyFontToChildren' ); + Log('<-TKOLCustomControl.ApplyFontToChildren'); end; end; -procedure TKOLCustomControl.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLCustomControl.AssignEvents(SL: TStringList; const AName: string); begin asm jmp @@e_signature @@ -4594,106 +4210,107 @@ begin DB 'TKOLCustomControl.AssignEvents', 0 @@e_signature: end; - Log( '->TKOLCustomControl.AssignEvents' ); + Log('->TKOLCustomControl.AssignEvents'); try - RptDetailed( 'Calling DefineFormEvents', WHITE ); - DefineFormEvents( - // events marked with '^' can be set immediately following control creation: - // in case of FormCompact = TRUE this gives smaller code since there are less - // calls of FormSetCurCtl. - // --------------------------------------------------------------------------- - [ 'OnClick:^TControl.SetOnClick', - 'OnMouseDblClk:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseDblClk), - 'OnMessage: TControl.Set_OnMessage', - 'OnMouseDown:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseDown), - 'OnMouseMove:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseMove), - 'OnMouseUp:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseUp), - 'OnMouseWheel:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseWheel), - 'OnMouseEnter:^TControl.SetOnMouseEnter', - 'OnMouseLeave:^TControl.SetOnMouseLeave', + RptDetailed('Calling DefineFormEvents', WHITE); + DefineFormEvents( + // events marked with '^' can be set immediately following control creation: + // in case of FormCompact = TRUE this gives smaller code since there are less + // calls of FormSetCurCtl. + // --------------------------------------------------------------------------- + ['OnClick:^TControl.SetOnClick', + 'OnMouseDblClk:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseDblClk), + 'OnMessage: TControl.Set_OnMessage', + 'OnMouseDown:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseDown), + 'OnMouseMove:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseMove), + 'OnMouseUp:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseUp), + 'OnMouseWheel:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseWheel), + 'OnMouseEnter:^TControl.SetOnMouseEnter', + 'OnMouseLeave:^TControl.SetOnMouseLeave', - 'OnDestroy:^TObj.SetOnDestroy', - 'OnEnter:^TControl.Set_TOnEvent,' + IntToStr(idx_fOnEnter), - 'OnLeave:^TControl.Set_TOnEvent,' + IntToStr(idx_fOnLeave), - 'OnKeyDown:^TControl.SetOnKeyDown', - 'OnKeyUp:^TControl.SetOnKeyUp', - 'OnKeyChar:^TControl.SetOnChar', - 'OnKeyDeadChar:^TControl.SetOnDeadChar', + 'OnDestroy:^TObj.SetOnDestroy', + 'OnEnter:^TControl.Set_TOnEvent,' + IntToStr(idx_fOnEnter), + 'OnLeave:^TControl.Set_TOnEvent,' + IntToStr(idx_fOnLeave), + 'OnKeyDown:^TControl.SetOnKeyDown', + 'OnKeyUp:^TControl.SetOnKeyUp', + 'OnKeyChar:^TControl.SetOnChar', + 'OnKeyDeadChar:^TControl.SetOnDeadChar', - 'OnChange: TControl.Set_TOnEvent,' + IntToStr(idx_fOnChangeCtl), - 'OnSelChange: TControl.Set_TOnEvent,' + IntToStr(idx_fOnSelChange), - 'OnPaint:^TControl.SetOnPaint', - 'OnEraseBkgnd:^TControl.SetOnEraseBkgnd', - 'OnResize: TControl.SetOnResize', - 'OnMove: TControl.SetOnMove', - 'OnMoving: TControl.SetOnMoving', - 'OnBitBtnDraw:^TControl.Set_OnBitBtnDraw', - 'OnDropDown:^TControl.Set_TOnEvent,' + IntToStr(idx_fOnDropDown), - 'OnCloseUp:^TControl.Set_TOnEvent,' + IntToStr(idx_FOnCloseUp), - 'OnProgress:^TControl.Set_TOnEvent,' + IntToStr(idx_FOnProgress), + 'OnChange: TControl.Set_TOnEvent,' + IntToStr(idx_fOnChangeCtl), + 'OnSelChange: TControl.Set_TOnEvent,' + IntToStr(idx_fOnSelChange), + 'OnPaint:^TControl.SetOnPaint', + 'OnEraseBkgnd:^TControl.SetOnEraseBkgnd', + 'OnResize: TControl.SetOnResize', + 'OnMove: TControl.SetOnMove', + 'OnMoving: TControl.SetOnMoving', + 'OnBitBtnDraw:^TControl.Set_OnBitBtnDraw', + 'OnDropDown:^TControl.Set_TOnEvent,' + IntToStr(idx_fOnDropDown), + 'OnCloseUp:^TControl.Set_TOnEvent,' + IntToStr(idx_FOnCloseUp), + 'OnProgress:^TControl.Set_TOnEvent,' + IntToStr(idx_FOnProgress), - 'OnDeleteAllLVItems:^TControl.SetOnDeleteAllLVItems', - 'OnDeleteLVItem:^TControl.SetOnDeleteLVItem', - 'OnLVData:^TControl.SetOnLVData', - 'OnCompareLVItems:^TControl.Set_OnCompareLVItems', - 'OnColumnClick:^TControl.SetOnColumnClick', - 'OnLVStateChange:^TControl.SetOnLVStateChange', - 'OnEndEditLVItem:^TControl.SetOnEndEditLVItem', + 'OnDeleteAllLVItems:^TControl.SetOnDeleteAllLVItems', + 'OnDeleteLVItem:^TControl.SetOnDeleteLVItem', + 'OnLVData:^TControl.SetOnLVData', + 'OnCompareLVItems:^TControl.Set_OnCompareLVItems', + 'OnColumnClick:^TControl.SetOnColumnClick', + 'OnLVStateChange:^TControl.SetOnLVStateChange', + 'OnEndEditLVItem:^TControl.SetOnEndEditLVItem', - 'OnDrawItem:^TControl.SetOnDrawItem', - 'OnMeasureItem:^TControl.SetOnMeasureItem', - 'OnTBDropDown:^TControl.Set_TOnEvent,' + IntToStr(idx_FOnDropDown), - 'OnDropFiles:^TControl.SetOnDropFiles', - 'OnShow:^TControl.SetOnShow', - 'OnHide:^TControl.SetOnHide', - 'OnSplit:^TControl.Set_OnSplit', - 'OnScroll:^TControl.SetOnScroll', + 'OnDrawItem:^TControl.SetOnDrawItem', + 'OnMeasureItem:^TControl.SetOnMeasureItem', + 'OnTBDropDown:^TControl.Set_TOnEvent,' + IntToStr(idx_fOnDropDown), + 'OnDropFiles:^TControl.SetOnDropFiles', + 'OnShow:^TControl.SetOnShow', + 'OnHide:^TControl.SetOnHide', + 'OnSplit:^TControl.Set_OnSplit', + 'OnScroll:^TControl.SetOnScroll', - 'OnRE_OverURL:^TControl.RESetOnURL,0', - 'OnRE_URLClick:^TControl.RESetOnURL,8', - 'OnRE_InsOvrMode_Change:^TControl.Set_TOnEvent,' + IntToStr(idx_FOnREInsModeChg), + 'OnRE_OverURL:^TControl.RESetOnURL,0', + 'OnRE_URLClick:^TControl.RESetOnURL,8', + 'OnRE_InsOvrMode_Change:^TControl.Set_TOnEvent,' + IntToStr(idx_FOnREInsModeChg), - 'OnTVBeginDrag:^TControl.Set_OnTVBeginDrag', - 'OnTVBeginEdit:^TControl.Set_OnTVBeginEdit', - 'OnTVEndEdit:^TControl.Set_OnTVEndEdit', - 'OnTVExpanded:^TControl.Set_OnTVExpanded', - 'OnTVExpanding:^TControl.Set_OnTVExpanding', - 'OnTVSelChanging:^TControl.Set_OnTVSelChanging', - 'OnTVDelete:^TControl.SetOnTVDelete' - ] ); - RptDetailed( 'Called DefineFormEvents ---', WHITE ); - DoAssignEvents( SL, AName, - [ 'OnClick', 'OnMouseDblClk', 'OnMessage', 'OnMouseDown', 'OnMouseMove', 'OnMouseUp', 'OnMouseWheel', 'OnMouseEnter', 'OnMouseLeave' ], - [ @OnClick, @ OnMouseDblClk, @OnMessage, @OnMouseDown, @OnMouseMove, @OnMouseUp, @OnMouseWheel, @OnMouseEnter, @OnMouseLeave ] ); - DoAssignEvents( SL, AName, - [ 'OnDestroy', 'OnEnter', 'OnLeave', 'OnKeyDown', 'OnKeyUp', 'OnKeyChar', 'OnKeyDeadChar' ], - [ @ OnDestroy, @OnEnter, @OnLeave, @OnKeyDown, @OnKeyUp, @OnKeyChar , @OnKeyDeadChar ] ); - DoAssignEvents( SL, AName, - [ 'OnChange', 'OnSelChange', 'OnPaint', 'OnEraseBkgnd', 'OnResize', 'OnMove', 'OnMoving', 'OnBitBtnDraw', 'OnDropDown', 'OnCloseUp', 'OnProgress' ], - [ @OnChange, @OnSelChange, @OnPaint , @ OnEraseBkgnd, @OnResize, @ OnMove, @ OnMoving, @OnBitBtnDraw, @OnDropDown, @ OnCloseUp, @ OnProgress ] ); - DoAssignEvents( SL, AName, - [ 'OnDeleteAllLVItems', 'OnDeleteLVItem', 'OnLVData', 'OnCompareLVItems', 'OnColumnClick', 'OnLVStateChange', 'OnEndEditLVItem' ], - [ @ OnDeleteAllLVItems, @ OnDeleteLVItem, @ OnLVData, @ OnCompareLVItems, @ OnColumnClick, @ OnLVStateChange, @ OnEndEditLVItem ] ); - DoAssignEvents( SL, AName, - [ 'OnDrawItem', 'OnMeasureItem', 'OnTBDropDown', 'OnDropFiles', 'OnShow', 'OnHide', 'OnSplit', 'OnScroll' ], - [ @ OnDrawItem, @ OnMeasureItem, @ OnTBDropDown, @ OnDropFiles, @ OnShow, @ OnHide, @ OnSplit, @ OnScroll ] ); - DoAssignEvents( SL, AName, - [ 'OnRE_URLClick', 'OnRE_InsOvrMode_Change', 'OnRE_OverURL' ], - [ @ OnRE_URLClick, @ OnRE_InsOvrMode_Change, @ OnRE_OverURL ] ); - DoAssignEvents( SL, AName, - [ 'OnTVBeginDrag', 'OnTVBeginEdit', 'OnTVEndEdit', 'OnTVExpanded', 'OnTVExpanding', 'OnTVSelChanging', 'OnTVDelete' ], - [ @ OnTVBeginDrag, @ OnTVBeginEdit, @ OnTVEndEdit, @ OnTVExpanded, @ OnTVExpanding, @ OnTVSelChanging, @ OnTVDelete ] ); - LogOK; + 'OnTVBeginDrag:^TControl.Set_OnTVBeginDrag', + 'OnTVBeginEdit:^TControl.Set_OnTVBeginEdit', + 'OnTVEndEdit:^TControl.Set_OnTVEndEdit', + 'OnTVExpanded:^TControl.Set_OnTVExpanded', + 'OnTVExpanding:^TControl.Set_OnTVExpanding', + 'OnTVSelChanging:^TControl.Set_OnTVSelChanging', + 'OnTVDelete:^TControl.SetOnTVDelete' + ]); + RptDetailed('Called DefineFormEvents ---', WHITE); + DoAssignEvents(SL, AName, + ['OnClick', 'OnMouseDblClk', 'OnMessage', 'OnMouseDown', 'OnMouseMove', 'OnMouseUp', 'OnMouseWheel', 'OnMouseEnter', 'OnMouseLeave'], + [@OnClick, @OnMouseDblClk, @OnMessage, @OnMouseDown, @OnMouseMove, @OnMouseUp, @OnMouseWheel, @OnMouseEnter, @OnMouseLeave]); + DoAssignEvents(SL, AName, + ['OnDestroy', 'OnEnter', 'OnLeave', 'OnKeyDown', 'OnKeyUp', 'OnKeyChar', 'OnKeyDeadChar'], + [@OnDestroy, @OnEnter, @OnLeave, @OnKeyDown, @OnKeyUp, @OnKeyChar, @OnKeyDeadChar]); + DoAssignEvents(SL, AName, + ['OnChange', 'OnSelChange', 'OnPaint', 'OnEraseBkgnd', 'OnResize', 'OnMove', 'OnMoving', 'OnBitBtnDraw', 'OnDropDown', 'OnCloseUp', 'OnProgress'], + [@OnChange, @OnSelChange, @OnPaint, @OnEraseBkgnd, @OnResize, @OnMove, @OnMoving, @OnBitBtnDraw, @OnDropDown, @OnCloseUp, @OnProgress]); + DoAssignEvents(SL, AName, + ['OnDeleteAllLVItems', 'OnDeleteLVItem', 'OnLVData', 'OnCompareLVItems', 'OnColumnClick', 'OnLVStateChange', 'OnEndEditLVItem'], + [@OnDeleteAllLVItems, @OnDeleteLVItem, @OnLVData, @OnCompareLVItems, @OnColumnClick, @OnLVStateChange, @OnEndEditLVItem]); + DoAssignEvents(SL, AName, + ['OnDrawItem', 'OnMeasureItem', 'OnTBDropDown', 'OnDropFiles', 'OnShow', 'OnHide', 'OnSplit', 'OnScroll'], + [@OnDrawItem, @OnMeasureItem, @OnTBDropDown, @OnDropFiles, @OnShow, @OnHide, @OnSplit, @OnScroll]); + DoAssignEvents(SL, AName, + ['OnRE_URLClick', 'OnRE_InsOvrMode_Change', 'OnRE_OverURL'], + [@OnRE_URLClick, @OnRE_InsOvrMode_Change, @OnRE_OverURL]); + DoAssignEvents(SL, AName, + ['OnTVBeginDrag', 'OnTVBeginEdit', 'OnTVEndEdit', 'OnTVExpanded', 'OnTVExpanding', 'OnTVSelChanging', 'OnTVDelete'], + [@OnTVBeginDrag, @OnTVBeginEdit, @OnTVEndEdit, @OnTVExpanded, @OnTVExpanding, @OnTVSelChanging, @OnTVDelete]); + LogOK; finally - Log( '<-TKOLCustomControl.AssignEvents' ); + Log('<-TKOLCustomControl.AssignEvents'); end; end; function TKOLCustomControl.AutoHeight(Canvas: TCanvas): Integer; -var Txt: String; - Sz: TSize; - R: TRect; - Flags: DWORD; +var + Txt: string; + Sz: TSize; + R: TRect; + Flags: DWORD; begin asm jmp @@e_signature @@ -4701,44 +4318,43 @@ begin DB 'TKOLCustomControl.AutoHeight', 0 @@e_signature: end; - Log( '->TKOLCustomControl.AutoHeight' ); + Log('->TKOLCustomControl.AutoHeight'); try - if not AutoSize then - Result := Height - else - begin - if Caption <> '' then - Txt := Caption - else - Txt := 'Ap^_/|'; - Windows.GetTextExtentPoint32( Canvas.Handle, PChar( Txt ), Length( Txt ), - Sz ); // TODO: dangerous - Result := Sz.cy; - if WordWrap and (Align <> caClient) then - begin - R := ClientRect; - Flags := DT_CALCRECT or DT_EXPANDTABS or DT_WORDBREAK; - CASE TextAlign OF - taCenter: Flags := Flags or DT_CENTER; - taRight : Flags := Flags or DT_RIGHT; - END; - CASE VerticalAlign OF - vaCenter: Flags := Flags or DT_VCENTER; - vaBottom: Flags := Flags or DT_BOTTOM; - END; - DrawText( Canvas.Handle, PChar( Txt ), Length( Txt ), R, Flags ); // TODO: dangerous - Result := R.Bottom - R.Top; + if not autoSize then + Result := Height + else begin + if Caption <> '' then + Txt := Caption + else + Txt := 'Ap^_/|'; + Windows.GetTextExtentPoint32(Canvas.Handle, PChar(Txt), Length(Txt), + Sz); // TODO: dangerous + Result := Sz.cy; + if WordWrap and (Align <> caClient) then begin + R := ClientRect; + Flags := DT_CALCRECT or DT_EXPANDTABS or DT_WORDBREAK; + case TextAlign of + taCenter: Flags := Flags or DT_CENTER; + taRight: Flags := Flags or DT_RIGHT; + end; + case VerticalAlign of + vaCenter: Flags := Flags or DT_VCENTER; + vaBottom: Flags := Flags or DT_BOTTOM; + end; + DrawText(Canvas.Handle, PChar(Txt), Length(Txt), R, Flags); // TODO: dangerous + Result := R.Bottom - R.Top; + end; end; - end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.AutoHeight' ); + Log('<-TKOLCustomControl.AutoHeight'); end; end; procedure TKOLCustomControl.AutoSizeNow; -var TmpBmp: graphics.TBitmap; - W, H: Integer; +var + TmpBmp: Graphics.TBitmap; + W, H: Integer; begin asm jmp @@e_signature @@ -4746,51 +4362,53 @@ begin DB 'AutoSizeNow', 0 @@e_signature: end; - Log( '->TKOLCustomControl.AutoSizeNow' ); + Log('->TKOLCustomControl.AutoSizeNow'); try - if not AutoSize then Exit; - if fAutoSizingNow or (csLoading in ComponentState) then - begin - LogOK; Exit; - end; - fAutoSizingNow := TRUE; - //Rpt( 'Autosize, Name: ' + Name, RED ); - TmpBmp := graphics.TBitmap.Create; - try - TmpBmp.Width := 10; - TmpBmp.Height := 10; - //Rpt( 'Autosize, Prepare Font for WYSIWIG Paint', RED ); - PrepareCanvasFontForWYSIWIGPaint( TmpBmp.Canvas ); - //Rpt( 'Name=' + Name + ': Canvas.Handle := ' + - // Int2Hex( TmpBmp.Canvas.Handle, 8 ), WHITE ); - if WordWrap then - W := Width - else - W := AutoWidth( TmpBmp.Canvas ); - H := AutoHeight( TmpBmp.Canvas ); - //Rpt( 'Name=' + Name + ': Canvas.Handle := ' + - // Int2Hex( TmpBmp.Canvas.Handle, 8 ), WHITE ); - //Rpt( 'Name=' + Name + ': W=' + IntToStr( W ) + ' H=' + IntToStr( H ), WHITE ); - if Align in [ caNone, caLeft, caRight ] then - if not fNoAutoSizeX and not WordWrap then - Width := W + fAutoSzX; - if Align in [ caNone, caTop, caBottom ] then - Height := H + fAutoSzY; - finally - TmpBmp.Free; - fAutoSizingNow := FALSE; - end; + if not autoSize then + Exit; + if fAutoSizingNow or (csLoading in ComponentState) then begin + LogOK; + Exit; + end; + fAutoSizingNow := True; + //Rpt( 'Autosize, Name: ' + Name, RED ); + TmpBmp := Graphics.TBitmap.Create; + try + TmpBmp.Width := 10; + TmpBmp.Height := 10; + //Rpt( 'Autosize, Prepare Font for WYSIWIG Paint', RED ); + PrepareCanvasFontForWYSIWIGPaint(TmpBmp.Canvas); + //Rpt( 'Name=' + Name + ': Canvas.Handle := ' + + // Int2Hex( TmpBmp.Canvas.Handle, 8 ), WHITE ); + if WordWrap then + W := Width + else + W := AutoWidth(TmpBmp.Canvas); + H := AutoHeight(TmpBmp.Canvas); + //Rpt( 'Name=' + Name + ': Canvas.Handle := ' + + // Int2Hex( TmpBmp.Canvas.Handle, 8 ), WHITE ); + //Rpt( 'Name=' + Name + ': W=' + IntToStr( W ) + ' H=' + IntToStr( H ), WHITE ); + if Align in [caNone, caLeft, caRight] then + if not fNoAutoSizeX and not WordWrap then + Width := W + fAutoSzX; + if Align in [caNone, caTop, caBottom] then + Height := H + fAutoSzY; + finally + TmpBmp.free; + fAutoSizingNow := False; + end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.AutoSizeNow' ); + Log('<-TKOLCustomControl.AutoSizeNow'); end; end; function TKOLCustomControl.AutoWidth(Canvas: TCanvas): Integer; -var Txt: String; - Sz: TSize; +var + Txt: string; + Sz: TSize; begin asm jmp @@e_signature @@ -4798,22 +4416,21 @@ begin DB 'TKOLCustomControl.AutoWidth', 0 @@e_signature: end; - Log( '->TKOLCustomControl.AutoWidth' ); + Log('->TKOLCustomControl.AutoWidth'); try - if WordWrap or not AutoSize then - Result := Width - else - begin - Txt := Caption; - if fsItalic in Font.FontStyle then - Txt := Txt + ' '; - Windows.GetTextExtentPoint32( Canvas.Handle, PChar( Txt ), Length( Txt ), - Sz ); // TODO: Dangerous - Result := Sz.cx; - end; - LogOK; + if WordWrap or not autoSize then + Result := Width + else begin + Txt := Caption; + if fsItalic in Font.FontStyle then + Txt := Txt + ' '; + Windows.GetTextExtentPoint32(Canvas.Handle, PChar(Txt), Length(Txt), + Sz); // TODO: Dangerous + Result := Sz.cx; + end; + LogOK; finally - Log( '<-TKOLCustomControl.AutoWidth' ); + Log('<-TKOLCustomControl.AutoWidth'); end; end; @@ -4827,20 +4444,19 @@ begin end; //Log( '->TKOLCustomControl.Change' ); try - if not fChangingNow then - begin - fChangingNow := TRUE; - try - if not (csLoading in ComponentState) then - if ParentKOLForm <> nil then - ParentKOLForm.Change( Self ); - finally - fChangingNow := FALSE; + if not fChangingNow then begin + fChangingNow := True; + try + if not (csLoading in ComponentState) then + if ParentKOLForm <> nil then + ParentKOLForm.Change(Self); + finally + fChangingNow := False; + end; end; - end; - //LogOK; + //LogOK; finally - //Log( '<-TKOLCustomControl.Change' ); + //Log( '<-TKOLCustomControl.Change' ); end; end; @@ -4863,12 +4479,13 @@ begin DB 'TKOLCustomControl.ClientMargins', 0 @@e_signature: end; - Result := Rect( 0, 0, 0, 0 ); + Result := Rect(0, 0, 0, 0); end; procedure TKOLCustomControl.CollectChildrenWithParentColor; -var I: Integer; - C: TComponent; +var + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -4876,25 +4493,25 @@ begin DB 'TKOLCustomControl.CollectChildrenWithParentFont', 0 @@e_signature: end; - Log( '->TKOLCustomControl.CollectChildrenWithParentColor' ); + Log('->TKOLCustomControl.CollectChildrenWithParentColor'); try - FParentLikeColorControls.Clear; - for I := 0 to ParentForm.ComponentCount - 1 do - begin - C := ParentForm.Components[ I ]; - if (C is TKOLCustomControl) and ((C as TKOLCustomControl).Parent = Self) then - if (C as TKOLCustomControl).parentColor then - FParentLikeColorControls.Add( C ); - end; - LogOK; + FParentLikeColorControls.Clear; + for I := 0 to ParentForm.ComponentCount - 1 do begin + c := ParentForm.Components[I]; + if (c is TKOLCustomControl) and ((c as TKOLCustomControl).Parent = Self) then + if (c as TKOLCustomControl).parentColor then + FParentLikeColorControls.Add(c); + end; + LogOK; finally - Log( '<-TKOLCustomControl.CollectChildrenWithParentColor' ); + Log('<-TKOLCustomControl.CollectChildrenWithParentColor'); end; end; procedure TKOLCustomControl.CollectChildrenWithParentFont; -var I: Integer; - C: TComponent; +var + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -4902,24 +4519,24 @@ begin DB 'TKOLCustomControl.CollectChildrenWithParentFont', 0 @@e_signature: end; - Log( '->TKOLCustomControl.CollectChildrenWithParentFont' ); + Log('->TKOLCustomControl.CollectChildrenWithParentFont'); try - FParentLikeFontControls.Clear; - for I := 0 to ParentForm.ComponentCount - 1 do - begin - C := ParentForm.Components[ I ]; - if (C is TKOLCustomControl) and ((C as TKOLCustomControl).Parent = Self) then - if (C as TKOLCustomControl).ParentFont then - FParentLikeFontControls.Add( C ); - end; - LogOK; + FParentLikeFontControls.Clear; + for I := 0 to ParentForm.ComponentCount - 1 do begin + c := ParentForm.Components[I]; + if (c is TKOLCustomControl) and ((c as TKOLCustomControl).Parent = Self) then + if (c as TKOLCustomControl).parentFont then + FParentLikeFontControls.Add(c); + end; + LogOK; finally - Log( '<-TKOLCustomControl.CollectChildrenWithParentFont' ); + Log('<-TKOLCustomControl.CollectChildrenWithParentFont'); end; end; function TKOLCustomControl.ControlIndex: Integer; -var I: Integer; +var + I: Integer; begin asm jmp @@e_signature @@ -4927,25 +4544,25 @@ begin DB 'TKOLCustomControl.ControlIndex', 0 @@e_signature: end; - Log( '->TKOLCustomControl.ControlIndex' ); + Log('->TKOLCustomControl.ControlIndex'); try - Result := -1; - for I := 0 to Parent.ControlCount-1 do - if Parent.Controls[ I ] = Self then - begin - Result := I; - break; - end; - LogOK; + Result := -1; + for I := 0 to Parent.ControlCount - 1 do + if Parent.Controls[I] = Self then begin + Result := I; + Break; + end; + LogOK; finally - Log( '<-TKOLCustomControl.ControlIndex' ); + Log('<-TKOLCustomControl.ControlIndex'); end; end; constructor TKOLCustomControl.Create(AOwner: TComponent); -var F: TKOLForm; - K: TComponent; - ColorOfParent: TColor; +var + F: TKOLForm; + k: TComponent; + ColorOfParent: TColor; begin asm jmp @@e_signature @@ -4953,101 +4570,99 @@ begin DB 'TKOLCustomControl.Create', 0 @@e_signature: end; - Log( '->TKOLCustomControl.Create' ); + Log('->TKOLCustomControl.Create'); try - fWindowed := TRUE; - FTabOrder := -2; - fNotifyList := TList.Create; - {$IFDEF NOT_USE_KOLCTRLWRAPPER} - FAllowSelfPaint := TRUE; - {$ENDIF NOT_USE_KOLCTRLWRAPPER} - Log( '//// inherited starting' ); - inherited; - Log( '//// inherited called' ); + FWindowed := True; + FTabOrder := -2; + fNotifyList := TList.Create; +{$IFDEF NOT_USE_KOLCTRLWRAPPER} + FAllowSelfPaint := True; +{$ENDIF NOT_USE_KOLCTRLWRAPPER} + Log('//// inherited starting'); + inherited; + Log('//// inherited called'); - {if not(csLoading in ComponentState) then - if OwnerKOLForm( AOwner ) = nil then - begin - raise Exception.Create( 'You forget to place TKOLForm or descendant component onto the form!'#13#10 + - 'Check also if TKOLProject already dropped onto the main form.' + - #13#10'classname = ' + ClassName ); - end;} + {if not(csLoading in ComponentState) then + if OwnerKOLForm( AOwner ) = nil then + begin + raise Exception.Create( 'You forget to place TKOLForm or descendant component onto the form!'#13#10 + + 'Check also if TKOLProject already dropped onto the main form.' + + #13#10'classname = ' + ClassName ); + end;} - FIsGenerateSize := TRUE; - FIsGeneratePosition := TRUE; - fAutoSzX := 4; - fAutoSzY := 4; - FParentFont := TRUE; - FParentColor := TRUE; - FParentLikeFontControls := TList.Create; - FParentLikeColorControls := TList.Create; - FFont := TKOLFont.Create( Self ); - FBrush := TKOLBrush.Create( Self ); - Width := 64; DefaultWidth := Width; - Height := 64; DefaultHeight := Height; + FIsGenerateSize := True; + FIsGeneratePosition := True; + fAutoSzX := 4; + fAutoSzY := 4; + FParentFont := True; + FParentColor := True; + FParentLikeFontControls := TList.Create; + FParentLikeColorControls := TList.Create; + fFont := TKOLFont.Create(Self); + fBrush := TKOLBrush.Create(Self); + Width := 64; + DefaultWidth := Width; + Height := 64; + DefaultHeight := Height; - fMargin := 2; - K := ParentKOLControl; + fMargin := 2; + k := ParentKOLControl; - if K <> nil then - if not( K is TKOLCustomControl ) then - K := nil; + if k <> nil then + if not (k is TKOLCustomControl) then + k := nil; - F := ParentKOLForm; + F := ParentKOLForm; - ColorOfParent := clBtnFace; - if K <> nil then - begin - fCtl3D := (K as TKOLCustomControl).Ctl3D; - ColorOfParent := (K as TKOLCustomControl).Color; - end + ColorOfParent := clBtnFace; + if k <> nil then begin + FCtl3D := (k as TKOLCustomControl).Ctl3D; + ColorOfParent := (k as TKOLCustomControl).Color; + end + else if F <> nil then begin + FCtl3D := F.Ctl3D; + ColorOfParent := F.Color; + end else - if F <> nil then - begin - fCtl3D := F.Ctl3D; - ColorOfParent := F.Color; - end - else - fCtl3D := True; + FCtl3D := True; - if DefaultParentColor then - begin - //Color := DefaultColor; - //Color := ColorOfParent; - FParentColor := FALSE; - ParentColor := TRUE; - end - else - begin - Color := ColorOfParent; - parentColor := FALSE; - Color := DefaultInitialColor; - end; + if DefaultParentColor then begin + //Color := DefaultColor; + //Color := ColorOfParent; + FParentColor := False; + parentColor := True; + end + else begin + Color := ColorOfParent; + parentColor := False; + Color := DefaultInitialColor; + end; - //FparentColor := Color = ColorOfParent; + //FparentColor := Color = ColorOfParent; - //inherited Color := Color; + //inherited Color := Color; - FHasBorder := TRUE; - FDefHasBorder := TRUE; - //Change; + FHasBorder := True; + FDefHasBorder := True; + //Change; - if F <> nil then + if F <> nil then FOverrideScrollbars := F.OverrideScrollbars; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.Create' ); + Log('<-TKOLCustomControl.Create'); end; end; destructor TKOLCustomControl.Destroy; -var F: TKOLForm; - SaveAlign: TKOLAlign; - I: Integer; - C: TComponent; - Cname: String; +var + F: TKOLForm; + SaveAlign: TKOLAlign; + I: Integer; + c: TComponent; + Cname: string; begin asm jmp @@e_signature @@ -5055,77 +4670,67 @@ begin DB 'TKOLCustomControl.Destroy', 0 @@e_signature: end; - Cname := Name; - Log( '->TKOLCustomControl.Destroy(' + Cname + ')' ); + Cname := name; + Log('->TKOLCustomControl.Destroy(' + Cname + ')'); try - if Assigned( Owner ) and not (csDestroying in Owner.ComponentState) then - begin - if Assigned( fNotifyList ) then - for I := fNotifyList.Count-1 downto 0 do - begin - C := fNotifyList[ I ]; - if C is TKOLObj then - (C as TKOLObj).NotifyLinkedComponent( Self, noRemoved ) - else - if C is TKOLCustomControl then - (C as TKOLCustomControl).NotifyLinkedComponent( Self, noRemoved ); + if Assigned(Owner) and not (csDestroying in Owner.ComponentState) then begin + if Assigned(fNotifyList) then + for I := fNotifyList.Count - 1 downto 0 do begin + c := fNotifyList[I]; + if c is TKOLObj then + (c as TKOLObj).NotifyLinkedComponent(Self, noRemoved) + else if c is TKOLCustomControl then + (c as TKOLCustomControl).NotifyLinkedComponent(Self, noRemoved); + end; + try + if OwnerKOLForm(Owner) <> nil then + OwnerKOLForm(Owner).Change(nil); + except + Rpt('Exception (destroying control)', RED); end; - TRY - if OwnerKOLForm( Owner ) <> nil then - OwnerKOLForm( Owner ).Change( nil ); - EXCEPT - Rpt( 'Exception (destroying control)', RED ); - END; - end; - F := nil; - if Owner <> nil then - begin - F := ParentKOLForm; - if F <> nil then - begin - if F.fDefaultBtnCtl = Self then - F.fDefaultBtnCtl := nil; - if F.fCancelBtnCtl = Self then - F.fCancelBtnCtl := nil; - SaveAlign := FAlign; - FAlign := caNone; - ReAlign( TRUE ); //-- realign only parent - FAlign := SaveAlign; end; - end; - FFont.Free; - FParentLikeFontControls.Free; - FParentLikeColorControls.Free; - fNotifyList.Free; - fNotifyList := nil; - FBrush.Free; {YS}//! Memory leak fix - if FEventDefs <> nil then - for I := 0 to FEventDefs.Count-1 do - begin - FreeMem( Pointer( FEventDefs.Objects[I] ) ); + F := nil; + if Owner <> nil then begin + F := ParentKOLForm; + if F <> nil then begin + if F.fDefaultBtnCtl = Self then + F.fDefaultBtnCtl := nil; + if F.fCancelBtnCtl = Self then + F.fCancelBtnCtl := nil; + SaveAlign := fAlign; + fAlign := caNone; + ReAlign(True); //-- realign only parent + fAlign := SaveAlign; end; - FreeAndNil( FEventDefs ); - inherited; - if (F <> nil) and not F.FIsDestroying and - (Owner <> nil) and not(csDestroying in Owner.ComponentState) then - F.Change( F ); + end; + fFont.free; + FParentLikeFontControls.free; + FParentLikeColorControls.free; + fNotifyList.free; + fNotifyList := nil; + fBrush.free; {YS} //! Memory leak fix + if FEventDefs <> nil then + for I := 0 to FEventDefs.Count - 1 do begin + FreeMem(Pointer(FEventDefs.Objects[I])); + end; + FreeAndNil(FEventDefs); + inherited; + if (F <> nil) and not F.FIsDestroying and + (Owner <> nil) and not (csDestroying in Owner.ComponentState) then + F.Change(F); - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.Destroy(' + Cname + ')' ); + Log('<-TKOLCustomControl.Destroy(' + Cname + ')'); end; end; -procedure TKOLCustomControl.DoAssignEvents(SL: TStringList; const AName: String; +procedure TKOLCustomControl.DoAssignEvents(SL: TStringList; const AName: string; const EventNames: array of PChar; const EventHandlers: array of Pointer); -var I: Integer; - KF: TKOLForm; - add_SL: Boolean; - j: Integer; - s: KOLString; - ev_setter, ev_handler: String; - N_ev_setter, N_ev_handler: Integer; +var + I: Integer; + add_SL: Boolean; begin asm jmp @@e_signature @@ -5135,60 +4740,17 @@ begin end; //Log( '->TKOLCustomControl.DoAssignEvents' ); try - - KF := ParentKOLForm; - - for I := 0 to High( EventHandlers ) do - begin - if EventHandlers[ I ] <> nil then - begin - add_SL := TRUE; - if (KF <> nil) and KF.FormCompact and - (FEventDefs <> nil) then - begin - j := FEventDefs.IndexOf( EventNames[I] ); - if j >= 0 then - begin - s := PChar( FEventDefs.Objects[j] ); - if s = '' then continue; - if FAssignOnlyWinEvents and (s[1] = '^') then - continue; - if FAssignOnlyUserEvents and (s[1] <> '^') then - continue; - if s[1] = '^' then - Delete( s, 1, 1 ); - ev_setter := Trim( Parse( s, ',' ) ); - ev_handler := 'T' + KF.formName + '.' + - ParentForm.MethodName( EventHandlers[ I ] ); - N_ev_setter := KF.FormAddAlphabet( ev_setter, FALSE, FALSE, ' ' + ev_setter + ':' + EventNames[I] ); - N_ev_handler := KF.FormAddAlphabet( ev_handler, FALSE, FALSE, ' ' + ev_handler + ':' + EventNames[I] ); - s := Trim( s ); - if s = '' then - begin - KF.FormAddCtlCommand( Name, 'FormSetEvent', ' ' + EventNames[I] ); - KF.FormAddNumParameter( N_ev_handler ); - KF.FormAddNumParameter( N_ev_setter ); - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetIndexedEvent', ' ' + EventNames[I] ); - KF.FormAddNumParameter( N_ev_handler ); - KF.FormAddNumParameter( StrToInt( s ) ); - KF.FormAddNumParameter( N_ev_setter ); - end; - add_SL := FALSE; - end; - end; - if add_SL then - SL.Add( ' ' + AName + '.' + String( EventNames[ I ] ) + - ' := Result.' + - ParentForm.MethodName( EventHandlers[ I ] ) + ';' ); + for I := 0 to High(EventHandlers) do begin + if EventHandlers[I] <> nil then begin + add_SL := True; + if add_SL then + SL.Add(' ' + AName + '.' + string(EventNames[I]) + + ' := Result.' + ParentForm.MethodName(EventHandlers[I]) + ';'); + end; end; - end; - - //LogOK; + //LogOK; finally - //Log( '<-TKOLCustomControl.DoAssignEvents' ); + //Log( '<-TKOLCustomControl.DoAssignEvents' ); end; end; @@ -5211,31 +4773,30 @@ begin DB 'TKOLCustomControl.FirstCreate', 0 @@e_signature: end; - Log( '->TKOLCustomControl.FirstCreate' ); + Log('->TKOLCustomControl.FirstCreate'); try - if Owner <> nil then - if Owner is TKOLCustomControl then - begin - Transparent := (Owner as TKOLCustomControl).Transparent; - {ShowMessage( 'First create of ' + Name + ' and owner Transparent = ' + - IntToStr( Integer( (Owner as TKOLCustomControl).Transparent ) ) );} - if (Owner as TKOLCustomControl).Transparent then - begin - end; - end; - LogOK; + if Owner <> nil then + if Owner is TKOLCustomControl then begin + Transparent := (Owner as TKOLCustomControl).Transparent; + {ShowMessage( 'First create of ' + Name + ' and owner Transparent = ' + + IntToStr( Integer( (Owner as TKOLCustomControl).Transparent ) ) );} + if (Owner as TKOLCustomControl).Transparent then begin + end; + end; + LogOK; finally - Log( '<-TKOLCustomControl.FirstCreate' ); + Log('<-TKOLCustomControl.FirstCreate'); end; end; const - AlignValues: array[ TKOLAlign ] of String = ( 'caNone', 'caLeft', 'caTop', - 'caRight', 'caBottom', 'caClient' ); + AlignValues: array[TKOLAlign] of string = ('caNone', 'caLeft', 'caTop', + 'caRight', 'caBottom', 'caClient'); -function TKOLCustomControl.GenerateTransparentInits: String; -var KF: TKOLForm; - S, S1, S2: String; +function TKOLCustomControl.GenerateTransparentInits: string; +var + KF: TKOLForm; + s, S1, S2: string; begin asm jmp @@e_signature @@ -5243,64 +4804,59 @@ begin DB 'TKOLCustomControl.GenerateTransparentInits', 0 @@e_signature: end; - Log( '->TKOLCustomControl.GenerateTransparentInits' ); + Log('->TKOLCustomControl.GenerateTransparentInits'); try - S := ''; // пока ничего не надо - if Align = caNone then - begin - if IsGenerateSize then - begin - if PlaceRight then - S := '.PlaceRight' - else - if PlaceDown then - S := '.PlaceDown' - else - if PlaceUnder then - S := '.PlaceUnder' - else - if not CenterOnParent then - if (actualLeft <> ParentMargin) or (actualTop <> ParentMargin) then - begin - S1 := IntToStr( actualLeft ); - S2 := IntToStr( actualTop ); - S := '.SetPosition( ' + S1 + ', ' + S2 + ' )'; + s := ''; // пока ничего не надо + if Align = caNone then begin + if IsGenerateSize then begin + if PlaceRight then + s := '.PlaceRight' + else if PlaceDown then + s := '.PlaceDown' + else if PlaceUnder then + s := '.PlaceUnder' + else if not CenterOnParent then + if (actualLeft <> ParentMargin) or (actualTop <> ParentMargin) then begin + S1 := IntToStr(actualLeft); + S2 := IntToStr(actualTop); + s := '.SetPosition( ' + S1 + ', ' + S2 + ' )'; + end; end; end; - end; - if Align <> caNone then - S := S + '.SetAlign ( ' + AlignValues[ Align ] + ' )'; - S := S + Generate_SetSize; - if CenterOnParent and (Align = caNone) then - S := S + '.CenterOnParent'; - KF := ParentKOLForm; - if KF <> nil then - if KF.zOrderChildren then - S := S + '.BringToFront'; - if EditTabChar then - S := S + '.EditTabChar'; - if (HelpContext <> 0) and (Faction = nil) then - S := S + '.AssignHelpContext( ' + IntToStr( HelpContext ) + ' )' ; - if MouseTransparent then - S := S + '.MouseTransparent'; - if LikeSpeedButton then - S := S + '.LikeSpeedButton'; - if (Border <> DefaultBorder) or + if Align <> caNone then + s := s + '.SetAlign ( ' + AlignValues[Align] + ' )'; + s := s + Generate_SetSize; + if CenterOnParent and (Align = caNone) then + s := s + '.CenterOnParent'; + KF := ParentKOLForm; + if KF <> nil then + if KF.zOrderChildren then + s := s + '.BringToFront'; + if EditTabChar then + s := s + '.EditTabChar'; + if (HelpContext <> 0) and (Faction = nil) then + s := s + '.AssignHelpContext( ' + IntToStr(HelpContext) + ' )'; + if MouseTransparent then + s := s + '.MouseTransparent'; + if LikeSpeedButton then + s := s + '.LikeSpeedButton'; + if (Border <> DefaultBorder) or (Border = DefaultBorder) and (ParentBorder >= 0) and (ParentBorder <> Border) then - S := S + '.SetBorder( ' + IntToStr( Border ) + ')'; - Result := Trim( S ); + s := s + '.SetBorder( ' + IntToStr(Border) + ')'; + Result := Trim(s); - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.GenerateTransparentInits' ); + Log('<-TKOLCustomControl.GenerateTransparentInits'); end; end; function TKOLCustomControl.GetActualLeft: Integer; -var P: TControl; - R: TRect; +var + P: TControl; + R: TRect; begin asm jmp @@e_signature @@ -5308,24 +4864,24 @@ begin DB 'TKOLCustomControl.GetActualLeft', 0 @@e_signature: end; - Log( '->TKOLCustomControl.GetActualLeft' ); + Log('->TKOLCustomControl.GetActualLeft'); try - Result := Left; - P := Parent; - if P is TKOLCustomControl then - begin - R := (P as TKOLCustomControl).ClientMargins; - Dec( Result, R.Left ); - end; - LogOK; + Result := Left; + P := Parent; + if P is TKOLCustomControl then begin + R := (P as TKOLCustomControl).ClientMargins; + Dec(Result, R.Left); + end; + LogOK; finally - Log( '<-TKOLCustomControl.GetActualLeft' ); + Log('<-TKOLCustomControl.GetActualLeft'); end; end; function TKOLCustomControl.GetActualTop: Integer; -var P: TControl; - R: TRect; +var + P: TControl; + R: TRect; begin asm jmp @@e_signature @@ -5333,25 +4889,25 @@ begin DB 'GetActualTop', 0 @@e_signature: end; - Log( '->TKOLCustomControl.GetActualTop' ); + Log('->TKOLCustomControl.GetActualTop'); try - Result := Top; - P := Parent; - if P is TKOLCustomControl then - begin - R := (P as TKOLCustomControl).ClientMargins; - Dec( Result, R.Top ); - end; - LogOK; + Result := Top; + P := Parent; + if P is TKOLCustomControl then begin + R := (P as TKOLCustomControl).ClientMargins; + Dec(Result, R.Top); + end; + LogOK; finally - Log( '<-TKOLCustomControl.GetActualTop' ); + Log('<-TKOLCustomControl.GetActualTop'); end; end; function TKOLCustomControl.GetParentColor: Boolean; -var KF: TKOLForm; - KC: TKOLCustomControl; - C: TComponent; +var + KF: TKOLForm; + KC: TKOLCustomControl; + c: TComponent; begin asm jmp @@e_signature @@ -5359,42 +4915,39 @@ begin DB 'TKOLCustomControl.GetParentColor', 0 @@e_signature: end; - Log( '->TKOLCustomControl.GetParentColor' ); + Log('->TKOLCustomControl.GetParentColor'); try - Result := FParentColor; - if Result then - begin - C := ParentKOLControl; - if C = nil then - begin - LogOK; - Exit; + Result := FParentColor; + if Result then begin + c := ParentKOLControl; + if c = nil then begin + LogOK; + Exit; + end; + if c is TKOLForm then begin + KF := c as TKOLForm; + if Color <> KF.Color then + Color := KF.Color; + end + else begin + KC := c as TKOLCustomControl; + if Color <> KC.Color then + Color := KC.Color; + end; end; - if C is TKOLForm then - begin - KF := C as TKOLForm; - if Color <> KF.Color then - Color := KF.Color; - end - else - begin - KC := C as TKOLCustomControl; - if Color <> KC.Color then - Color := KC.Color; - end; - end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.GetParentColor' ); + Log('<-TKOLCustomControl.GetParentColor'); end; end; function TKOLCustomControl.GetParentFont: Boolean; -var KF: TKOLForm; - KC: TKOLCustomControl; - C: TComponent; +var + KF: TKOLForm; + KC: TKOLCustomControl; + c: TComponent; begin asm jmp @@e_signature @@ -5402,44 +4955,41 @@ begin DB 'TKOLCustomControl.GetParentFont', 0 @@e_signature: end; - Log( '->TKOLCustomControl.GetParentFont' ); + Log('->TKOLCustomControl.GetParentFont'); try - Result := FParentFont; - if Result then - begin - C := ParentKOLControl; - if C = nil then - begin - LogOK; - Exit; + Result := FParentFont; + if Result then begin + c := ParentKOLControl; + if c = nil then begin + LogOK; + Exit; + end; + if c is TKOLForm then begin + KF := c as TKOLForm; + if not Font.Equal2(KF.Font) then + Font.Assign(KF.Font); + end + else begin + KC := c as TKOLCustomControl; + if not Font.Equal2(KC.Font) then + Font.Assign(KC.Font); + end; end; - if C is TKOLForm then - begin - KF := C as TKOLForm; - if not Font.Equal2( KF.Font ) then - Font.Assign( KF.Font ); - end - else - begin - KC := C as TKOLCustomControl; - if not Font.Equal2( KC.Font ) then - Font.Assign( KC.Font ); - end; - end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.GetParentFont' ); + Log('<-TKOLCustomControl.GetParentFont'); end; end; function TKOLCustomControl.GetTabOrder: Integer; -var I, J, N: Integer; - K, C: TComponent; - kC: TKOLCustomControl; - Found: Boolean; - L: TList; +var + I, j, N: Integer; + k, c: TComponent; + KC: TKOLCustomControl; + Found: Boolean; + L: TList; begin asm jmp @@e_signature @@ -5450,76 +5000,68 @@ begin //Log( '->TKOLCustomControl.GetTabOrder' ); try - //Old := FTabOrder; - Result := FTabOrder; - {if Old <> Result then - ShowMessage( Name + '.TabOrder := ' + IntToStr( Result ) );} - if Result = -2 then - begin - if (csLoading in ComponentState) or FAdjustingTabOrder then - begin - //LogOK; - Exit; - end; - FAdjustingTabOrder := TRUE; - L := TList.Create; - try - K := ParentForm; - if K <> nil then - begin - for I := 0 to K.ComponentCount - 1 do - begin - C := K.Components[ I ]; - //if C = Self then continue; - if not( C is TKOLCustomControl ) then continue; - kC := C as TKOLCustomControl; - if kC.Parent <> Parent then continue; - L.Add( kC ); - end; - for I := 0 to L.Count - 1 do - begin - kC := L[ I ]; - //ShowMessage( 'Check ' + kC.Name + ' with TabOrder = ' + IntToStr( kC.FTabOrder ) ); - if (kC.FTabOrder = Result) or (Result <= -2) then - begin - //ShowMessage( '! ' + kC.Name + '.TabOrder also = ' + IntToStr( Result ) ); - for N := 0 to MaxInt do - begin - Found := FALSE; - for J := 0 to L.Count - 1 do - begin - kC := L[ J ]; - if kC.FTabOrder = N then - begin - Found := TRUE; - break; + //Old := FTabOrder; + Result := FTabOrder; + {if Old <> Result then + ShowMessage( Name + '.TabOrder := ' + IntToStr( Result ) );} + if Result = -2 then begin + if (csLoading in ComponentState) or FAdjustingTabOrder then begin + //LogOK; + Exit; + end; + FAdjustingTabOrder := True; + L := TList.Create; + try + k := ParentForm; + if k <> nil then begin + for I := 0 to k.ComponentCount - 1 do begin + c := k.Components[I]; + //if C = Self then continue; + if not (c is TKOLCustomControl) then + Continue; + KC := c as TKOLCustomControl; + if KC.Parent <> Parent then + Continue; + L.Add(KC); + end; + for I := 0 to L.Count - 1 do begin + KC := L[I]; + //ShowMessage( 'Check ' + kC.Name + ' with TabOrder = ' + IntToStr( kC.FTabOrder ) ); + if (KC.FTabOrder = Result) or (Result <= -2) then begin + //ShowMessage( '! ' + kC.Name + '.TabOrder also = ' + IntToStr( Result ) ); + for N := 0 to MaxInt do begin + Found := False; + for j := 0 to L.Count - 1 do begin + KC := L[j]; + if KC.FTabOrder = N then begin + Found := True; + Break; + end; + end; + if not Found then begin + //ShowMessage( 'TabOrder ' + IntToStr( N ) + ' is not yet used. ( ). Assign to ' + Name ); + FTabOrder := N; + Break; end; end; - if not Found then - begin - //ShowMessage( 'TabOrder ' + IntToStr( N ) + ' is not yet used. ( ). Assign to ' + Name ); - FTabOrder := N; - break; - end; + Break; end; - break; end; end; + finally + FAdjustingTabOrder := False; + L.free; end; - finally - FAdjustingTabOrder := FALSE; - L.Free; end; - end; - if FTabOrder < 0 then - FTabOrder := -1; - if FTabOrder > 100000 then - FTabOrder := 100000; - Result := FTabOrder; + if FTabOrder < 0 then + FTabOrder := -1; + if FTabOrder > 100000 then + FTabOrder := 100000; + Result := FTabOrder; - //LogOK; + //LogOK; finally - //Log( '<-TKOLCustomControl.GetTabOrder' ); + //Log( '<-TKOLCustomControl.GetTabOrder' ); end; end; @@ -5531,12 +5073,12 @@ begin DB 'TKOLCustomControl.Get_Color', 0 @@e_signature: end; - Log( '->TKOLCustomControl.Get_Color' ); + Log('->TKOLCustomControl.Get_Color'); try - Result := inherited Color; - LogOK; + Result := inherited Color; + LogOK; finally - Log( '<-TKOLCustomControl.Get_Color' ); + Log('<-TKOLCustomControl.Get_Color'); end; end; @@ -5548,12 +5090,12 @@ begin DB 'TKOLCustomControl.Get_Enabled', 0 @@e_signature: end; - Log( '->TKOLCustomControl.Get_Enabled' ); + Log('->TKOLCustomControl.Get_Enabled'); try - Result := inherited Enabled; - LogOK; + Result := inherited Enabled; + LogOK; finally - Log( '<-TKOLCustomControl.Get_Enabled' ); + Log('<-TKOLCustomControl.Get_Enabled'); end; end; @@ -5565,14 +5107,14 @@ begin DB 'TKOLCustomControl.Get_Visible', 0 @@e_signature: end; - Log( '->TKOLCustomControl.Get_Visible' ); + Log('->TKOLCustomControl.Get_Visible'); //Rpt( 'where from Get_Visible called?' ); //Rpt_Stack; try - Result := inherited Visible; - LogOK; + Result := inherited Visible; + LogOK; finally - Log( '<-TKOLCustomControl.Get_Visible' ); + Log('<-TKOLCustomControl.Get_Visible'); end; end; @@ -5584,28 +5126,29 @@ begin DB 'TKOLCustomControl.IsCursorDefault', 0 @@e_signature: end; - Log( '->TKOLCustomControl.IsCursorDefault' ); + Log('->TKOLCustomControl.IsCursorDefault'); try - Result := TRUE; - if Trim( Cursor_ ) <> '' then - if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm.Cursor <> Cursor_) - or (ParentKOLControl <> ParentKOLForm) and ((ParentKOLControl as TKOLCustomControl).Cursor_ <> Cursor_) then - Result := FALSE; - LogOK; + Result := True; + if Trim(Cursor_) <> '' then + if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm.Cursor <> Cursor_) + or (ParentKOLControl <> ParentKOLForm) and ((ParentKOLControl as TKOLCustomControl).Cursor_ <> Cursor_) then + Result := False; + LogOK; finally - Log( '<-TKOLCustomControl.IsCursorDefault' ); + Log('<-TKOLCustomControl.IsCursorDefault'); end; end; procedure TKOLCustomControl.Paint; -var R, MR: TRect; - P: TPoint; - F: TKOLForm; +var + R, MR: TRect; + P: TPoint; + F: TKOLForm; - procedure PaintAdditional; - begin + procedure PaintAdditional; + begin - end; + end; begin asm @@ -5614,94 +5157,90 @@ begin DB 'TKOLCustomControl.Paint', 0 @@e_signature: end; - Log( '->TKOLCustomControl.Paint ' + Name ); + Log('->TKOLCustomControl.Paint ' + name); try - F := ParentKOLForm; - if F = nil then - begin - LogOK; - Exit; - end; - if F.FIsDestroying or (Owner = nil) or - (csDestroying in Owner.ComponentState) then - begin - LogOK; - Exit; - end; + F := ParentKOLForm; + if F = nil then begin + LogOK; + Exit; + end; + if F.FIsDestroying or (Owner = nil) or + (csDestroying in Owner.ComponentState) then begin + LogOK; + Exit; + end; - R := ClientRect; - case PaintType of - {$IFDEF _KOLCtrlWrapper_} - ptWYSIWIG: - if WYSIWIGPaintImplemented or Assigned(FKOLCtrl) then {YS} - begin - PaintAdditional; - LogOK; - Exit; - end; -{YS} - {$ELSE} - ptWYSIWIG, - {$ENDIF} - ptWYSIWIGCustom: - if WYSIWIGPaintImplemented then - begin - PaintAdditional; - LogOK; - Exit; - end; -{YS} - ptWYSIWIGFrames: - if WYSIWIGPaintImplemented - {$IFDEF _KOLCtrlWrapper_} or Assigned(FKOLCtrl) {YS} {$ENDIF} - then - begin - PaintAdditional; - if not NoDrawFrame then - begin - Canvas.Pen.Color := clBtnShadow; - Canvas.Brush.Style := bsClear; - Canvas.RoundRect( R.Left, R.Top, R.Right, R.Bottom, 3, 3 ); + R := ClientRect; + case PaintType of +{$IFDEF _KOLCtrlWrapper_} + ptWYSIWIG: + if WYSIWIGPaintImplemented or Assigned(FKOLCtrl) then {YS} begin + PaintAdditional; + LogOK; + Exit; end; - LogOK; - Exit; - end; - end; - inherited; - Canvas.Brush.Style := bsSolid; - Canvas.Brush.Color := clBtnFace; // Color; - Canvas.FillRect( R ); - Canvas.Pen.Color := clWindowText; - Canvas.Brush.Color := clDkGray; - Canvas.RoundRect( R.Left, R.Top, R.Right, R.Bottom, 3, 3 ); - InflateRect( R, -1, -1 ); - MR := DrawMargins; - if MR.Left > 1 then - Inc( R.Left, MR.Left-1 ); - if MR.Top > 1 then - Inc( R.Top, MR.Top-1 ); - if MR.Right > 1 then - Dec( R.Right, MR.Right-1 ); - if MR.Bottom > 1 then - Dec( R.Bottom, MR.Bottom-1 ); - P := Point( 0, 0 ); - P.x := (Width - Canvas.TextWidth( Name )) div 2; - if P.x < R.Left then P.x := R.Left; - P.y := (Height - Canvas.TextHeight( Name )) div 2; - if P.y < R.Top then P.y := R.Top; - Canvas.Brush.Color := clBtnFace; - //Canvas.Brush.Style := bsClear; - Canvas.TextRect( R, P.x, P.y, Name ); + {YS} +{$ELSE} + ptWYSIWIG, +{$ENDIF} + ptWYSIWIGCustom: + if WYSIWIGPaintImplemented then begin + PaintAdditional; + LogOK; + Exit; + end; + {YS} + ptWYSIWIGFrames: + if WYSIWIGPaintImplemented +{$IFDEF _KOLCtrlWrapper_} or Assigned(FKOLCtrl) {YS}{$ENDIF} then begin + PaintAdditional; + if not NoDrawFrame then begin + Canvas.Pen.Color := clBtnShadow; + Canvas.Brush.Style := bsClear; + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 3, 3); + end; + LogOK; + Exit; + end; + end; + inherited; + Canvas.Brush.Style := bsSolid; + Canvas.Brush.Color := clBtnFace; // Color; + Canvas.FillRect(R); + Canvas.Pen.Color := clWindowText; + Canvas.Brush.Color := clDkGray; + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 3, 3); + InflateRect(R, -1, -1); + MR := DrawMargins; + if MR.Left > 1 then + Inc(R.Left, MR.Left - 1); + if MR.Top > 1 then + Inc(R.Top, MR.Top - 1); + if MR.Right > 1 then + Dec(R.Right, MR.Right - 1); + if MR.Bottom > 1 then + Dec(R.Bottom, MR.Bottom - 1); + P := Point(0, 0); + P.X := (Width - Canvas.TextWidth(name)) div 2; + if P.X < R.Left then + P.X := R.Left; + P.Y := (Height - Canvas.TextHeight(name)) div 2; + if P.Y < R.Top then + P.Y := R.Top; + Canvas.Brush.Color := clBtnFace; + //Canvas.Brush.Style := bsClear; + Canvas.TextRect(R, P.X, P.Y, name); - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.Paint' ); + Log('<-TKOLCustomControl.Paint'); end; end; function TKOLCustomControl.ParentBounds: TRect; -var C: TComponent; +var + c: TComponent; begin asm jmp @@e_signature @@ -5709,25 +5248,26 @@ begin DB 'TKOLCustomControl.ParentBounds', 0 @@e_signature: end; - Log( '->TKOLCustomControl.ParentBounds' ); + Log('->TKOLCustomControl.ParentBounds'); try - Result := Rect( 0, 0, 0, 0 ); - C := ParentKOLControl; - if C<> nil then - if C is TKOLCustomControl then - Result := (C as TKOLCustomControl).BoundsRect - else - Result := ParentForm.ClientRect; + Result := Rect(0, 0, 0, 0); + c := ParentKOLControl; + if c <> nil then + if c is TKOLCustomControl then + Result := (c as TKOLCustomControl).BoundsRect + else + Result := ParentForm.ClientRect; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.ParentBounds' ); + Log('<-TKOLCustomControl.ParentBounds'); end; end; function TKOLCustomControl.ParentControlUseAlign: Boolean; -var C: TControl; +var + c: TControl; begin asm jmp @@e_signature @@ -5735,24 +5275,24 @@ begin DB 'TKOLCustomControl.ParentControlUseAlign', 0 @@e_signature: end; - Log( '->TKOLCustomControl.ParentControlUseAlign' ); + Log('->TKOLCustomControl.ParentControlUseAlign'); try - Result := False; - C := Parent; - if not(C is TForm) and (C is TKOLCustomControl) then - begin - Result := (C as TKOLCustomControl).Align <> caNone; - end; + Result := False; + c := Parent; + if not (c is TForm) and (c is TKOLCustomControl) then begin + Result := (c as TKOLCustomControl).Align <> caNone; + end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.ParentControlUseAlign' ); + Log('<-TKOLCustomControl.ParentControlUseAlign'); end; end; function TKOLCustomControl.ParentForm: TForm; -var C: TComponent; +var + c: TComponent; begin asm jmp @@e_signature @@ -5763,17 +5303,17 @@ begin //Log( '->TKOLCustomControl.ParentForm' ); try - C := Owner; - while (C <> nil) and not(C is TForm) do - C := C.Owner; - Result := nil; - if C <> nil then - if C is TForm then - Result := C as TForm; + c := Owner; + while (c <> nil) and not (c is TForm) do + c := c.Owner; + Result := nil; + if c <> nil then + if c is TForm then + Result := c as TForm; - //LogOK; + //LogOK; finally - //Log( '<-TKOLCustomControl.ParentForm' ); + //Log( '<-TKOLCustomControl.ParentForm' ); end; end; @@ -5788,24 +5328,25 @@ begin //Log( '->TKOLCustomControl.ParentKOLControl' ); try - Result := Parent; - while (Result <> nil) and - not (Result is TKOLCustomControl) and - not (Result is TForm) do - Result := (Result as TControl).Parent; - if Result <> nil then - if (Result is TForm) then - Result := ParentKOLForm; + Result := Parent; + while (Result <> nil) and + not (Result is TKOLCustomControl) and + not (Result is TForm) do + Result := (Result as TControl).Parent; + if Result <> nil then + if (Result is TForm) then + Result := ParentKOLForm; - //LogOK; + //LogOK; finally - //Log( '<-TKOLCustomControl.ParentKOLControl' ); + //Log( '<-TKOLCustomControl.ParentKOLControl' ); end; end; function TKOLCustomControl.ParentKOLForm: TKOLForm; -var C, D: TComponent; - I: Integer; +var + c, D: TComponent; + I: Integer; begin asm jmp @@e_signature @@ -5816,37 +5357,35 @@ begin //Log( '->TKOLCustomControl.ParentKOLForm' ); try - C := Parent; - {if C = nil then - C := Owner;} - while (C <> nil) and not(C is TForm) do - if C is TControl then - C := (C as TControl).Parent - else - C := nil; - Result := nil; - if C <> nil then - if C is TForm then - begin - for I := 0 to (C as TForm).ComponentCount - 1 do - begin - D := (C as TForm).Components[ I ]; - if D is TKOLForm then - begin - Result := D as TKOLForm; - break; + c := Parent; + {if C = nil then + C := Owner;} + while (c <> nil) and not (c is TForm) do + if c is TControl then + c := (c as TControl).Parent + else + c := nil; + Result := nil; + if c <> nil then + if c is TForm then begin + for I := 0 to (c as TForm).ComponentCount - 1 do begin + D := (c as TForm).Components[I]; + if D is TKOLForm then begin + Result := D as TKOLForm; + Break; + end; + end; end; - end; - end; - //LogOK; + //LogOK; finally - //Log( '<-TKOLCustomControl.ParentKOLForm' ); + //Log( '<-TKOLCustomControl.ParentKOLForm' ); end; end; function TKOLCustomControl.ParentMargin: Integer; -var C: TComponent; +var + c: TComponent; begin asm jmp @@e_signature @@ -5854,25 +5393,26 @@ begin DB 'TKOLCustomControl.ParentMargin', 0 @@e_signature: end; - Log( '->TKOLCustomControl.ParentMargin' ); + Log('->TKOLCustomControl.ParentMargin'); try - C := ParentKOLControl; - Result := 0; - if C <> nil then - if C is TKOLForm then - Result := (C as TKOLForm).Margin - else - Result := (C as TKOLCustomControl).Margin; + c := ParentKOLControl; + Result := 0; + if c <> nil then + if c is TKOLForm then + Result := (c as TKOLForm).Margin + else + Result := (c as TKOLCustomControl).Margin; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.ParentMargin' ); + Log('<-TKOLCustomControl.ParentMargin'); end; end; function TKOLCustomControl.PrevBounds: TRect; -var K: TKOLCustomControl; +var + k: TKOLCustomControl; begin asm jmp @@e_signature @@ -5880,24 +5420,25 @@ begin DB 'TKOLCustomControl.PrevBounds', 0 @@e_signature: end; - Log( '->TKOLCustomControl.PrevBounds' ); + Log('->TKOLCustomControl.PrevBounds'); try - Result := Rect( 0, 0, 0, 0 ); - K := PrevKOLControl; - if K <> nil then - Result := K.BoundsRect; + Result := Rect(0, 0, 0, 0); + k := PrevKOLControl; + if k <> nil then + Result := k.BoundsRect; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.PrevBounds' ); + Log('<-TKOLCustomControl.PrevBounds'); end; end; function TKOLCustomControl.PrevKOLControl: TKOLCustomControl; -var F: TForm; - I: Integer; - C: TComponent; +var + F: TForm; + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -5905,30 +5446,29 @@ begin DB 'TKOLCustomControl.PrevKOLControl', 0 @@e_signature: end; - Log( '->TKOLCustomControl.PrevKOLControl' ); + Log('->TKOLCustomControl.PrevKOLControl'); try - Result := nil; - if ParentKOLForm <> nil then - begin - F := (ParentKOLForm.Owner as TForm); - for I := 0 to F.ComponentCount - 1 do - begin - C := F.Components[ I ]; - if C = Self then break; - if C is TKOLCustomControl then - if (C as TKOLCustomControl).Parent = Parent then - Result := C as TKOLCustomControl; + Result := nil; + if ParentKOLForm <> nil then begin + F := (ParentKOLForm.Owner as TForm); + for I := 0 to F.ComponentCount - 1 do begin + c := F.Components[I]; + if c = Self then + Break; + if c is TKOLCustomControl then + if (c as TKOLCustomControl).Parent = Parent then + Result := c as TKOLCustomControl; + end; end; - end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.PrevKOLControl' ); + Log('<-TKOLCustomControl.PrevKOLControl'); end; end; -function TKOLCustomControl.RefName: String; +function TKOLCustomControl.RefName: string; begin asm jmp @@e_signature @@ -5936,12 +5476,13 @@ begin DB 'TKOLCustomControl.RefName', 0 @@e_signature: end; - Result := 'Result.' + Name; + Result := 'Result.' + name; end; procedure TKOLCustomControl.SetActualLeft(Value: Integer); -var P: TControl; - R: TRect; +var + P: TControl; + R: TRect; begin asm jmp @@e_signature @@ -5949,24 +5490,24 @@ begin DB 'TKOLCustomControl.SetActualLeft', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetActualLeft' ); + Log('->TKOLCustomControl.SetActualLeft'); try - P := Parent; - if P is TKOLCustomControl then - begin - R := (P as TKOLCustomControl).ClientMargins; - Inc( Value, R.Left ); - end; - Left := Value; - LogOK; + P := Parent; + if P is TKOLCustomControl then begin + R := (P as TKOLCustomControl).ClientMargins; + Inc(Value, R.Left); + end; + Left := Value; + LogOK; finally - Log( '<-TKOLCustomControl.SetActualLeft' ); + Log('<-TKOLCustomControl.SetActualLeft'); end; end; procedure TKOLCustomControl.SetActualTop(Value: Integer); -var P: TControl; - R: TRect; +var + P: TControl; + R: TRect; begin asm jmp @@e_signature @@ -5974,24 +5515,23 @@ begin DB 'TKOLCustomControl.SetActualTop', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetActualTop' ); + Log('->TKOLCustomControl.SetActualTop'); try - P := Parent; - if P is TKOLCustomControl then - begin - R := (P as TKOLCustomControl).ClientMargins; - Inc( Value, R.Top ); - end; - Top := Value; - LogOK; + P := Parent; + if P is TKOLCustomControl then begin + R := (P as TKOLCustomControl).ClientMargins; + Inc(Value, R.Top); + end; + Top := Value; + LogOK; finally - Log( '<-TKOLCustomControl.SetActualTop' ); + Log('<-TKOLCustomControl.SetActualTop'); end; end; procedure TKOLCustomControl.SetAlign(const Value: TKOLAlign); var - DoSwap: boolean; + DoSwap: Boolean; begin asm jmp @@e_signature @@ -5999,39 +5539,37 @@ begin DB 'TKOLCustomControl.SetAlign', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetAlign' ); + Log('->TKOLCustomControl.SetAlign'); try - if fAlign <> Value then - begin - DoSwap:=not (csLoading in ComponentState) and ( - ((Value in [caLeft, caRight]) and (fAlign in [caTop, caBottom])) or - ((fAlign in [caLeft, caRight]) and (Value in [caTop, caBottom]))); - fAlign := Value; - if fAlign <> caNone then - begin - PlaceRight := False; - PlaceDown := False; - PlaceUnder := False; - CenterOnParent := False; + if fAlign <> Value then begin + DoSwap := not (csLoading in ComponentState) and ( + ((Value in [caLeft, caRight]) and (fAlign in [caTop, caBottom])) or + ((fAlign in [caLeft, caRight]) and (Value in [caTop, caBottom]))); + fAlign := Value; + if fAlign <> caNone then begin + PlaceRight := False; + PlaceDown := False; + PlaceUnder := False; + CenterOnParent := False; + end; + //inherited Align := alNone; + {case Value of + caNone: inherited Align := alNone; + caLeft: inherited Align := alLeft; + caTop: inherited Align := alTop; + caRight: inherited Align := alRight; + caBottom: inherited Align := alBottom; + caClient: inherited Align := alClient; + end;} + if DoSwap then + SetBounds(Left, Top, Height, Width) + else + ReAlign(False); + Change; end; - //inherited Align := alNone; - {case Value of - caNone: inherited Align := alNone; - caLeft: inherited Align := alLeft; - caTop: inherited Align := alTop; - caRight: inherited Align := alRight; - caBottom: inherited Align := alBottom; - caClient: inherited Align := alClient; - end;} - if DoSwap then - SetBounds(Left, Top, Height, Width) - else - ReAlign( FALSE ); - Change; - end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.SetAlign' ); + Log('<-TKOLCustomControl.SetAlign'); end; end; @@ -6043,21 +5581,23 @@ begin DB 'TKOLCustomControl.Set_autoSize', 0 @@e_signature: end; - if FautoSize = Value then Exit; - Log( '->TKOLCustomControl.Set_autoSize' ); + if FautoSize = Value then + Exit; + Log('->TKOLCustomControl.Set_autoSize'); try - FautoSize := Value; - if Value and not (csLoading in ComponentState) then - AutoSizeNow; - Change; - LogOK; + FautoSize := Value; + if Value and not (csLoading in ComponentState) then + AutoSizeNow; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.Set_autoSize' ); + Log('<-TKOLCustomControl.Set_autoSize'); end; end; -procedure TKOLCustomControl.SetBounds(aLeft, aTop, aWidth, aHeight: Integer); -var R, OldBounds: TRect; +procedure TKOLCustomControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +var + R, OldBounds: TRect; begin asm jmp @@e_signature @@ -6065,63 +5605,60 @@ begin DB 'TKOLCustomControl.SetBounds', 0 @@e_signature: end; - R := Rect( aLeft, aTop, aLeft + aWidth, aTop + aHeight ); + R := Rect(ALeft, ATop, ALeft + AWidth, ATop + AHeight); OldBounds := BoundsRect; if (R.Left = OldBounds.Left) and (R.Top = OldBounds.Top) and - (R.Right = OldBounds.Right) and (R.Bottom = OldBounds.Bottom) then + (R.Right = OldBounds.Right) and (R.Bottom = OldBounds.Bottom) then Exit; - Log( '->TKOLCustomControl.SetBounds ' ); + Log('->TKOLCustomControl.SetBounds '); try - TRY - //Rpt( 'TKOLCustomControl.SetBounds0 old Height=' + IntToStr( Height ) + ', newH=' + IntToStr( aHeight ), YELLOW ); - //Log( 'TKOLCustomControl.SetBounds1' ); - if Assigned( FOnSetBounds ) then - begin - //Rpt( 'TKOLCustomControl.SetBounds1A', YELLOW ); - FOnSetBounds( Self, R ); - //Log( 'TKOLCustomControl.SetBounds1B' ); - aLeft := R.Left; - aTop := R.Top; - aWidth := R.Right - R.Left; - aHeight := R.Bottom - R.Top; + try + //Rpt( 'TKOLCustomControl.SetBounds0 old Height=' + IntToStr( Height ) + ', newH=' + IntToStr( aHeight ), YELLOW ); + //Log( 'TKOLCustomControl.SetBounds1' ); + if Assigned(FOnSetBounds) then begin + //Rpt( 'TKOLCustomControl.SetBounds1A', YELLOW ); + FOnSetBounds(Self, R); + //Log( 'TKOLCustomControl.SetBounds1B' ); + ALeft := R.Left; + ATop := R.Top; + AWidth := R.Right - R.Left; + AHeight := R.Bottom - R.Top; + end; + //Rpt( 'TKOLCustomControl.SetBounds2 old Height=' + IntToStr( Height ) + ', newH=' + IntToStr( aHeight ), YELLOW ); + R := Rect(Left, Top, Left + Width, Top + Height); + //Log( 'TKOLCustomControl.SetBounds3' ); + //Rpt( 'inherited SetBounds: aHeight=' + IntToStr( aHeight ), YELLOW ); + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + //Rpt( 'inherited SetBounds called: Height=' + IntToStr( Height ), YELLOW ); + //Log( 'TKOLCustomControl.SetBounds4' ); + //Rpt( 'H before AutoSize: ' + IntToStr( Height ) + ',aHeight' + IntToStr( aHeight ), RED ); + if autoSize then + AutoSizeNow; + //Rpt( 'H after AutoSize: ' + IntToStr( Height ), RED ); + //Log( 'TKOLCustomControl.SetBounds5' ); + if (Left <> R.Left) or (Top <> R.Top) or + (Width <> R.Right - R.Left) or (Height <> R.Bottom - R.Top) then begin + //Rpt( 'Call realign, h=' + IntToStr( Height ) + ', R.H=' + IntToStr( R.Bottom - R.Top ), RED ); + //Height := R.Bottom - R.Top; + ReAlign(False); + //Rpt( 'Realigned, h=' + IntToStr( Height ) + ', R.H=' + IntToStr( R.Bottom - R.Top ), RED ); + end; + R := BoundsRect; + if (R.Left <> OldBounds.Left) or (R.Right <> OldBounds.Right) or + (R.Top <> OldBounds.Top) or (R.Bottom <> OldBounds.Bottom) then begin + //Rpt( 'Set bounds: h=' + IntToStr( R.Bottom - R.Top ), RED ); + Change; + end; + //Log( 'TKOLCustomControl.SetBounds6 (after Change)' ); + except + on E: Exception do begin + Rpt('Exception in TKOLCustomControl.SetBounds: ' + E.Message, RED); + Rpt_Stack; + end; end; - //Rpt( 'TKOLCustomControl.SetBounds2 old Height=' + IntToStr( Height ) + ', newH=' + IntToStr( aHeight ), YELLOW ); - R := Rect( Left, Top, Left + Width, Top + Height ); - //Log( 'TKOLCustomControl.SetBounds3' ); - //Rpt( 'inherited SetBounds: aHeight=' + IntToStr( aHeight ), YELLOW ); - inherited SetBounds( aLeft, aTop, aWidth, aHeight ); - //Rpt( 'inherited SetBounds called: Height=' + IntToStr( Height ), YELLOW ); - //Log( 'TKOLCustomControl.SetBounds4' ); - //Rpt( 'H before AutoSize: ' + IntToStr( Height ) + ',aHeight' + IntToStr( aHeight ), RED ); - if AutoSize then AutoSizeNow; - //Rpt( 'H after AutoSize: ' + IntToStr( Height ), RED ); - //Log( 'TKOLCustomControl.SetBounds5' ); - if (Left <> R.Left) or (Top <> R.Top) or - (Width <> R.Right - R.Left) or (Height <> R.Bottom - R.Top) then - begin - //Rpt( 'Call realign, h=' + IntToStr( Height ) + ', R.H=' + IntToStr( R.Bottom - R.Top ), RED ); - //Height := R.Bottom - R.Top; - ReAlign( FALSE ); - //Rpt( 'Realigned, h=' + IntToStr( Height ) + ', R.H=' + IntToStr( R.Bottom - R.Top ), RED ); - end; - R := BoundsRect; - if (R.Left <> OldBounds.Left) or (R.Right <> OldBounds.Right) or - (R.Top <> OldBounds.Top) or (R.Bottom <> OldBounds.Bottom) then - begin - //Rpt( 'Set bounds: h=' + IntToStr( R.Bottom - R.Top ), RED ); - Change; - end; - //Log( 'TKOLCustomControl.SetBounds6 (after Change)' ); - EXCEPT - on E: Exception do - begin - Rpt( 'Exception in TKOLCustomControl.SetBounds: ' + E.Message, RED ); - Rpt_Stack; - end; - END; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.SetBounds' ); + Log('<-TKOLCustomControl.SetBounds'); end; end; @@ -6133,39 +5670,38 @@ begin DB 'TKOLCustomControl.SetCaption', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetCaption' ); + Log('->TKOLCustomControl.SetCaption'); try - if Faction = nil then - begin - if fCaption = Value then - begin - LogOK; - Exit; - end; - fCaption := Value; - end - else - fCaption := Faction.Caption; -{YS} - {$IFDEF _KOLCtrlWrapper_} - if Assigned(FKOLCtrl) then - FKOLCtrl.Caption:=fCaption; - {$ENDIF} -{YS} - if AutoSize then - AutoSizeNow; - Invalidate; - Change; + if Faction = nil then begin + if fCaption = Value then begin + LogOK; + Exit; + end; + fCaption := Value; + end + else + fCaption := Faction.Caption; + {YS} +{$IFDEF _KOLCtrlWrapper_} + if Assigned(FKOLCtrl) then + FKOLCtrl.Caption := fCaption; +{$ENDIF} + {YS} + if autoSize then + AutoSizeNow; + Invalidate; + Change; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.SetCaption' ); + Log('<-TKOLCustomControl.SetCaption'); end; end; procedure TKOLCustomControl.SetCenterOnParent(const Value: Boolean); -var R: TRect; +var + R: TRect; begin asm jmp @@e_signature @@ -6173,32 +5709,29 @@ begin DB 'TKOLCustomControl.SetCenterOnParent', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetCenterOnParent' ); + Log('->TKOLCustomControl.SetCenterOnParent'); try - if (fAlign <> caNone) and Value or (Value = fCenterOnParent) then - begin - LogOK; - Exit; - end; - fCenterOnParent := Value; - if Value then - begin - PlaceRight := False; - PlaceDown := False; - PlaceUnder := False; - if not (csLoading in ComponentState) then - begin - R := ParentBounds; - Left := (R.Right - R.Left - Width) div 2; - Top := (R.Bottom - R.Top - Height) div 2; + if (fAlign <> caNone) and Value or (Value = fCenterOnParent) then begin + LogOK; + Exit; end; - end; - Change; + fCenterOnParent := Value; + if Value then begin + PlaceRight := False; + PlaceDown := False; + PlaceUnder := False; + if not (csLoading in ComponentState) then begin + R := ParentBounds; + Left := (R.Right - R.Left - Width) div 2; + Top := (R.Bottom - R.Top - Height) div 2; + end; + end; + Change; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.SetCenterOnParent' ); + Log('<-TKOLCustomControl.SetCenterOnParent'); end; end; @@ -6210,14 +5743,15 @@ begin DB 'TKOLCustomControl.SetClsStyle', 0 @@e_signature: end; - if fClsStyle = Value then Exit; - Log( '->TKOLCustomControl.SetClsStyle' ); + if fClsStyle = Value then + Exit; + Log('->TKOLCustomControl.SetClsStyle'); try - fClsStyle := Value; - Change; - LogOK; + fClsStyle := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetClsStyle' ); + Log('<-TKOLCustomControl.SetClsStyle'); end; end; @@ -6229,22 +5763,23 @@ begin DB 'TKOLCustomControl.SetCtl3D', 0 @@e_signature: end; - if FCtl3D = Value then Exit; - Log( '->TKOLCustomControl.SetCtl3D' ); + if FCtl3D = Value then + Exit; + Log('->TKOLCustomControl.SetCtl3D'); try - FCtl3D := Value; - if Assigned(FKOLCtrl) and not (csLoading in ComponentState) then - FKOLCtrl.Ctl3D:=FCtl3D - else - Invalidate; - Change; - LogOK; + FCtl3D := Value; + if Assigned(FKOLCtrl) and not (csLoading in ComponentState) then + FKOLCtrl.Ctl3D := FCtl3D + else + Invalidate; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetCtl3D' ); + Log('<-TKOLCustomControl.SetCtl3D'); end; end; -procedure TKOLCustomControl.SetCursor(const Value: String); +procedure TKOLCustomControl.SetCursor(const Value: string); begin asm jmp @@e_signature @@ -6252,14 +5787,15 @@ begin DB 'TKOLCustomControl.SetCursor', 0 @@e_signature: end; - if FCursor = Value then Exit; - Log( '->TKOLCustomControl.SetCursor' ); + if FCursor = Value then + Exit; + Log('->TKOLCustomControl.SetCursor'); try - FCursor := Value; - Change; - LogOK; + FCursor := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetCursor' ); + Log('<-TKOLCustomControl.SetCursor'); end; end; @@ -6271,14 +5807,15 @@ begin DB 'TKOLCustomControl.SetDoubleBuffered', 0 @@e_signature: end; - if FDoubleBuffered = Value then Exit; - Log( '->TKOLCustomControl.SetDoubleBuffered' ); + if FDoubleBuffered = Value then + Exit; + Log('->TKOLCustomControl.SetDoubleBuffered'); try - FDoubleBuffered := Value; - Change; - LogOK; + FDoubleBuffered := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetDoubleBuffered' ); + Log('<-TKOLCustomControl.SetDoubleBuffered'); end; end; @@ -6290,14 +5827,15 @@ begin DB 'TKOLCustomControl.SetEraseBackground', 0 @@e_signature: end; - if FEraseBackground = Value then Exit; - Log( '->TKOLCustomControl.SetEraseBackground' ); + if FEraseBackground = Value then + Exit; + Log('->TKOLCustomControl.SetEraseBackground'); try - FEraseBackground := Value; - Change; - LogOK; + FEraseBackground := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetEraseBackground' ); + Log('<-TKOLCustomControl.SetEraseBackground'); end; end; @@ -6309,21 +5847,23 @@ begin DB 'TKOLCustomControl.SetExStyle', 0 @@e_signature: end; - if fExStyle = Value then Exit; - Log( '->TKOLCustomControl.SetExStyle' ); + if fExStyle = Value then + Exit; + Log('->TKOLCustomControl.SetExStyle'); try - fExStyle := Value; - Change; - LogOK; + fExStyle := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetExStyle' ); + Log('<-TKOLCustomControl.SetExStyle'); end; end; procedure TKOLCustomControl.SetFont(const Value: TKOLFont); -var KF: TKOLForm; - KC: TKOLCustomControl; - C: TComponent; +var + KF: TKOLForm; + KC: TKOLCustomControl; + c: TComponent; begin asm jmp @@e_signature @@ -6331,37 +5871,32 @@ begin DB 'TKOLCustomControl.SetFont', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetFont' ); + Log('->TKOLCustomControl.SetFont'); try - if not (csLoading in ComponentState) then - begin - C := ParentKOLControl; - if C <> nil then - if C is TKOLForm then - begin - KF := C as TKOLForm; - if not Value.Equal2( KF.Font ) then - parentFont := FALSE; - end - else - if C is TKOLCustomControl then - begin - KC := C as TKOLCustomControl; - if not Value.Equal2( KC.Font ) then - parentFont := FALSE; + if not (csLoading in ComponentState) then begin + c := ParentKOLControl; + if c <> nil then + if c is TKOLForm then begin + KF := c as TKOLForm; + if not Value.Equal2(KF.Font) then + parentFont := False; + end + else if c is TKOLCustomControl then begin + KC := c as TKOLCustomControl; + if not Value.Equal2(KC.Font) then + parentFont := False; + end; end; - end; - if not fFont.Equal2( Value ) then - begin - CollectChildrenWithParentFont; - fFont.Assign( Value ); - ApplyFontToChildren; - //if csLoading in ComponentState then - // FParentFont := DetectParentFont; - end; - LogOK; + if not fFont.Equal2(Value) then begin + CollectChildrenWithParentFont; + fFont.Assign(Value); + ApplyFontToChildren; + //if csLoading in ComponentState then + // FParentFont := DetectParentFont; + end; + LogOK; finally - Log( '<-TKOLCustomControl.SetFont' ); + Log('<-TKOLCustomControl.SetFont'); end; end; @@ -6373,18 +5908,17 @@ begin DB 'TKOLCustomControl.SetMargin', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetMargin' ); + Log('->TKOLCustomControl.SetMargin'); try - if fMargin <> Value then - begin - fMargin := Value; - ReAlign( FALSE ); - Change; - Invalidate; - end; - LogOK; + if fMargin <> Value then begin + fMargin := Value; + ReAlign(False); + Change; + Invalidate; + end; + LogOK; finally - Log( '<-TKOLCustomControl.SetMargin' ); + Log('<-TKOLCustomControl.SetMargin'); end; end; @@ -6396,17 +5930,16 @@ begin DB 'TKOLCustomControl.SetMarginBottom', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetMarginBottom' ); + Log('->TKOLCustomControl.SetMarginBottom'); try - if FMarginBottom <> Value then - begin - FMarginBottom := Value; - ReAlign( FALSE ); - Change; - end; - LogOK; + if FMarginBottom <> Value then begin + FMarginBottom := Value; + ReAlign(False); + Change; + end; + LogOK; finally - Log( '<-TKOLCustomControl.SetMarginBottom' ); + Log('<-TKOLCustomControl.SetMarginBottom'); end; end; @@ -6418,17 +5951,16 @@ begin DB 'TKOLCustomControl.SetMarginLeft', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetMarginLeft' ); + Log('->TKOLCustomControl.SetMarginLeft'); try - if FMarginLeft <> Value then - begin - FMarginLeft := Value; - ReAlign( FALSE ); - Change; - end; - LogOK; + if FMarginLeft <> Value then begin + FMarginLeft := Value; + ReAlign(False); + Change; + end; + LogOK; finally - Log( '<-TKOLCustomControl.SetMarginLeft' ); + Log('<-TKOLCustomControl.SetMarginLeft'); end; end; @@ -6440,17 +5972,16 @@ begin DB 'TKOLCustomControl.SetMarginRight', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetMarginRight' ); + Log('->TKOLCustomControl.SetMarginRight'); try - if FMarginRight <> Value then - begin - FMarginRight := Value; - ReAlign( FALSE ); - Change; - end; - LogOK; + if FMarginRight <> Value then begin + FMarginRight := Value; + ReAlign(False); + Change; + end; + LogOK; finally - Log( '<-TKOLCustomControl.SetMarginRight' ); + Log('<-TKOLCustomControl.SetMarginRight'); end; end; @@ -6462,24 +5993,24 @@ begin DB 'TKOLCustomControl.SetMarginTop', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetMarginTop' ); + Log('->TKOLCustomControl.SetMarginTop'); try - if FMarginTop <> Value then - begin - FMarginTop := Value; - ReAlign( FALSE ); - Change; - end; - LogOK; + if FMarginTop <> Value then begin + FMarginTop := Value; + ReAlign(False); + Change; + end; + LogOK; finally - Log( '<-TKOLCustomControl.SetMarginTop' ); + Log('<-TKOLCustomControl.SetMarginTop'); end; end; procedure TKOLCustomControl.SetName(const NewName: TComponentName); -var OldName, NameNew: String; - I, N: Integer; - Success: Boolean; +var + OldName, NameNew: string; + I, N: Integer; + Success: Boolean; begin asm jmp @@e_signature @@ -6487,48 +6018,44 @@ begin DB 'TKOLCustomControl.SetName', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetName' ); + Log('->TKOLCustomControl.SetName'); try - OldName := Name; - inherited SetName( NewName ); - if OldName = NewName then - begin - LogOK; - Exit; - end; - if (Copy( NewName, 1, 3 ) = 'KOL') and (OldName = '') then - begin - NameNew := Copy( NewName, 4, Length( NewName ) - 3 ); - Success := True; - if Owner <> nil then - while Owner.FindComponent( NameNew ) <> nil do - begin - Success := False; - for I := 1 to Length( NameNew ) do - begin - if AnsiChar(NameNew[ I ]) in [ '0'..'9' ] then - begin - Success := True; - N := StrToInt( Copy( NameNew, I, Length( NameNew ) - I + 1 ) ); - Inc( N ); - NameNew := Copy( NameNew, 1, I - 1 ) + IntToStr( N ); - break; - end; - end; - if not Success then break; + OldName := name; + inherited SetName(NewName); + if OldName = NewName then begin + LogOK; + Exit; end; - if Success then - Name := NameNew; - if not (csLoading in ComponentState) then - FirstCreate; - end; - Invalidate; - Change; + if (Copy(NewName, 1, 3) = 'KOL') and (OldName = '') then begin + NameNew := Copy(NewName, 4, Length(NewName) - 3); + Success := True; + if Owner <> nil then + while Owner.FindComponent(NameNew) <> nil do begin + Success := False; + for I := 1 to Length(NameNew) do begin + if AnsiChar(NameNew[I]) in ['0'..'9'] then begin + Success := True; + N := StrToInt(Copy(NameNew, I, Length(NameNew) - I + 1)); + Inc(N); + NameNew := Copy(NameNew, 1, I - 1) + IntToStr(N); + Break; + end; + end; + if not Success then + Break; + end; + if Success then + name := NameNew; + if not (csLoading in ComponentState) then + FirstCreate; + end; + Invalidate; + Change; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.SetName' ); + Log('<-TKOLCustomControl.SetName'); end; end; @@ -6540,14 +6067,15 @@ begin DB 'TKOLCustomControl.SetOnBitBtnDraw', 0 @@e_signature: end; - if @ FOnBitBtnDraw = @ Value then Exit; - Log( '->TKOLCustomControl.SetOnBitBtnDraw' ); + if @FOnBitBtnDraw = @Value then + Exit; + Log('->TKOLCustomControl.SetOnBitBtnDraw'); try - FOnBitBtnDraw := Value; - Change; - LogOK; + FOnBitBtnDraw := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetOnBitBtnDraw' ); + Log('<-TKOLCustomControl.SetOnBitBtnDraw'); end; end; @@ -6559,14 +6087,15 @@ begin DB 'TKOLCustomControl.SetOnChange', 0 @@e_signature: end; - if @ FOnChange = @ Value then Exit; - Log( '->TKOLCustomControl.SetOnChange' ); + if @FOnChange = @Value then + Exit; + Log('->TKOLCustomControl.SetOnChange'); try - FOnChange := Value; - Change; - LogOK; + FOnChange := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetOnChange' ); + Log('<-TKOLCustomControl.SetOnChange'); end; end; @@ -6578,14 +6107,15 @@ begin DB 'TKOLCustomControl.SetOnChar', 0 @@e_signature: end; - if @ FOnChar = @ Value then Exit; - Log( '->TKOLCustomControl.SetOnChar' ); + if @FOnChar = @Value then + Exit; + Log('->TKOLCustomControl.SetOnChar'); try - FOnChar := Value; - Change; - LogOK; + FOnChar := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetOnChar' ); + Log('<-TKOLCustomControl.SetOnChar'); end; end; @@ -6597,14 +6127,15 @@ begin DB 'TKOLCustomControl.SetOnClick', 0 @@e_signature: end; - if @ fOnClick = @ Value then Exit; - Log( '->TKOLCustomControl.SetOnClick' ); + if @fOnClick = @Value then + Exit; + Log('->TKOLCustomControl.SetOnClick'); try - fOnClick := Value; - Change; - LogOK; + fOnClick := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetOnClick' ); + Log('<-TKOLCustomControl.SetOnClick'); end; end; @@ -6616,14 +6147,15 @@ begin DB 'TKOLCustomControl.SetOnCloseUp', 0 @@e_signature: end; - if @ FOnCloseUp = @ Value then Exit; - Log( '->TKOLCustomControl.SetOnCloseUp' ); + if @FOnCloseUp = @Value then + Exit; + Log('->TKOLCustomControl.SetOnCloseUp'); try - FOnCloseUp := Value; - Change; - LogOK; + FOnCloseUp := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetOnCloseUp' ); + Log('<-TKOLCustomControl.SetOnCloseUp'); end; end; @@ -6635,14 +6167,15 @@ begin DB 'TKOLCustomControl.SetOnColumnClick', 0 @@e_signature: end; - if @ FOnColumnClick = @ Value then Exit; - Log( '->TKOLCustomControl.SetOnColumnClick' ); + if @FOnColumnClick = @Value then + Exit; + Log('->TKOLCustomControl.SetOnColumnClick'); try - FOnColumnClick := Value; - Change; - LogOK; + FOnColumnClick := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetOnColumnClick' ); + Log('<-TKOLCustomControl.SetOnColumnClick'); end; end; @@ -6654,14 +6187,15 @@ begin DB 'TKOLCustomControl.SetOnCompareLVItems', 0 @@e_signature: end; - if @ FOnCompareLVItems = @ Value then Exit; - Log( '->TKOLCustomControl.SetOnCompareLVItems' ); + if @FOnCompareLVItems = @Value then + Exit; + Log('->TKOLCustomControl.SetOnCompareLVItems'); try - FOnCompareLVItems := Value; - Change; - LogOK; + FOnCompareLVItems := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetOnCompareLVItems' ); + Log('<-TKOLCustomControl.SetOnCompareLVItems'); end; end; @@ -6673,7 +6207,8 @@ begin DB 'TKOLCustomControl.SetOnDeleteAllLVItems', 0 @@e_signature: end; - if @ FOnDeleteAllLVItems = @ Value then Exit; + if @FOnDeleteAllLVItems = @Value then + Exit; FOnDeleteAllLVItems := Value; Change; end; @@ -6686,7 +6221,8 @@ begin DB 'TKOLCustomControl.SetOnDeleteLVItem', 0 @@e_signature: end; - if @ FOnDeleteLVItem = @ Value then Exit; + if @FOnDeleteLVItem = @Value then + Exit; FOnDeleteLVItem := Value; Change; end; @@ -6699,7 +6235,8 @@ begin DB 'TKOLCustomControl.SetOnDestroy', 0 @@e_signature: end; - if @ FOnDestroy = @ Value then Exit; + if @FOnDestroy = @Value then + Exit; FOnDestroy := Value; Change; end; @@ -6712,7 +6249,8 @@ begin DB 'TKOLCustomControl.SetOnDrawItem', 0 @@e_signature: end; - if @ FOnDrawItem = @ Value then Exit; + if @FOnDrawItem = @Value then + Exit; FOnDrawItem := Value; Change; end; @@ -6725,7 +6263,8 @@ begin DB 'TKOLCustomControl.SetOnDropDown', 0 @@e_signature: end; - if @ FOnDropDown = @ Value then Exit; + if @FOnDropDown = @Value then + Exit; FOnDropDown := Value; Change; end; @@ -6738,7 +6277,8 @@ begin DB 'TKOLCustomControl.SetOnDropFiles', 0 @@e_signature: end; - if @ FOnDropFiles = @ Value then Exit; + if @FOnDropFiles = @Value then + Exit; FOnDropFiles := Value; Change; end; @@ -6751,7 +6291,8 @@ begin DB 'TKOLCustomControl.SetOnEndEditLVItem', 0 @@e_signature: end; - if @ FOnEndEditLVItem = @ Value then Exit; + if @FOnEndEditLVItem = @Value then + Exit; FOnEndEditLVItem := Value; Change; end; @@ -6764,7 +6305,8 @@ begin DB 'TKOLCustomControl.SetOnEnter', 0 @@e_signature: end; - if @ FOnEnter = @ Value then Exit; + if @FOnEnter = @Value then + Exit; FOnEnter := Value; Change; end; @@ -6777,7 +6319,8 @@ begin DB 'TKOLCustomControl.SetOnEraseBkgnd', 0 @@e_signature: end; - if @ FOnEraseBkgnd = @ Value then Exit; + if @FOnEraseBkgnd = @Value then + Exit; FOnEraseBkgnd := Value; Change; end; @@ -6790,7 +6333,8 @@ begin DB 'TKOLCustomControl.SetOnHide', 0 @@e_signature: end; - if @ FOnHide = @ Value then Exit; + if @FOnHide = @Value then + Exit; FOnHide := Value; Change; end; @@ -6803,7 +6347,8 @@ begin DB 'TKOLCustomControl.SetOnKeyDown', 0 @@e_signature: end; - if @ FOnKeyDown = @ Value then Exit; + if @FOnKeyDown = @Value then + Exit; FOnKeyDown := Value; Change; end; @@ -6816,7 +6361,8 @@ begin DB 'TKOLCustomControl.SetOnKeyUp', 0 @@e_signature: end; - if @ FOnKeyUp = @ Value then Exit; + if @FOnKeyUp = @Value then + Exit; FOnKeyUp := Value; Change; end; @@ -6829,7 +6375,8 @@ begin DB 'TKOLCustomControl.SetOnLeave', 0 @@e_signature: end; - if @ FOnLeave = @ Value then Exit; + if @FOnLeave = @Value then + Exit; FOnLeave := Value; Change; end; @@ -6842,7 +6389,8 @@ begin DB 'TKOLCustomControl.SetOnLVData', 0 @@e_signature: end; - if @ FOnLVData = @ Value then Exit; + if @FOnLVData = @Value then + Exit; FOnLVData := Value; Change; end; @@ -6855,7 +6403,8 @@ begin DB 'TKOLCustomControl.SetOnLVStateChange', 0 @@e_signature: end; - if @ FOnLVStateChange = @ Value then Exit; + if @FOnLVStateChange = @Value then + Exit; FOnLVStateChange := Value; Change; end; @@ -6868,7 +6417,8 @@ begin DB 'TKOLCustomControl.SetOnMeasureItem', 0 @@e_signature: end; - if @ FOnMeasureItem = @ Value then Exit; + if @FOnMeasureItem = @Value then + Exit; FOnMeasureItem := Value; Change; end; @@ -6881,7 +6431,8 @@ begin DB 'TKOLCustomControl.SetOnMessage', 0 @@e_signature: end; - if @ FOnMessage = @ Value then Exit; + if @FOnMessage = @Value then + Exit; FOnMessage := Value; Change; end; @@ -6894,7 +6445,8 @@ begin DB 'TKOLCustomControl.SetOnMouseDblClk', 0 @@e_signature: end; - if @ fOnMouseDblClk = @ Value then Exit; + if @fOnMouseDblClk = @Value then + Exit; fOnMouseDblClk := Value; Change; end; @@ -6907,7 +6459,8 @@ begin DB 'TKOLCustomControl.SetOnMouseDown', 0 @@e_signature: end; - if @ FOnMouseDown = @ Value then Exit; + if @FOnMouseDown = @Value then + Exit; FOnMouseDown := Value; Change; end; @@ -6920,7 +6473,8 @@ begin DB 'TKOLCustomControl.SetOnMouseEnter', 0 @@e_signature: end; - if @ FOnMouseEnter = @ Value then Exit; + if @FOnMouseEnter = @Value then + Exit; FOnMouseEnter := Value; Change; end; @@ -6933,7 +6487,8 @@ begin DB 'TKOLCustomControl.SetOnMouseLeave', 0 @@e_signature: end; - if @ FOnMouseLeave = @ Value then Exit; + if @FOnMouseLeave = @Value then + Exit; FOnMouseLeave := Value; Change; end; @@ -6946,7 +6501,8 @@ begin DB 'TKOLCustomControl.SetOnMouseMove', 0 @@e_signature: end; - if @ FOnMouseMove = @ Value then Exit; + if @FOnMouseMove = @Value then + Exit; FOnMouseMove := Value; Change; end; @@ -6959,7 +6515,8 @@ begin DB 'TKOLCustomControl.SetOnMouseUp', 0 @@e_signature: end; - if @ FOnMouseUp = @ Value then Exit; + if @FOnMouseUp = @Value then + Exit; FOnMouseUp := Value; Change; end; @@ -6972,7 +6529,8 @@ begin DB 'TKOLCustomControl.SetOnMouseWheel', 0 @@e_signature: end; - if @ FOnMouseWheel = @ Value then Exit; + if @FOnMouseWheel = @Value then + Exit; FOnMouseWheel := Value; Change; end; @@ -6985,7 +6543,8 @@ begin DB 'TKOLCustomControl.SetOnMove', 0 @@e_signature: end; - if @ FOnMove = @ Value then Exit; + if @FOnMove = @Value then + Exit; FOnMove := Value; Change; end; @@ -6998,7 +6557,8 @@ begin DB 'TKOLCustomControl.SetOnPaint', 0 @@e_signature: end; - if @ FOnPaint = @ Value then Exit; + if @FOnPaint = @Value then + Exit; FOnPaint := Value; Change; end; @@ -7011,7 +6571,8 @@ begin DB 'TKOLCustomControl.SetOnProgress', 0 @@e_signature: end; - if @ FOnProgress = @ Value then Exit; + if @FOnProgress = @Value then + Exit; FOnProgress := Value; Change; end; @@ -7024,7 +6585,8 @@ begin DB 'TKOLCustomControl.SetOnResize', 0 @@e_signature: end; - if @ FOnResize = @ Value then Exit; + if @FOnResize = @Value then + Exit; FOnResize := Value; Change; end; @@ -7037,7 +6599,8 @@ begin DB 'TKOLCustomControl.SetOnRE_InsOvrMode_Change', 0 @@e_signature: end; - if @ FOnRE_InsOvrMode_Change = @ Value then Exit; + if @FOnRE_InsOvrMode_Change = @Value then + Exit; FOnRE_InsOvrMode_Change := Value; Change; end; @@ -7050,7 +6613,8 @@ begin DB 'TKOLCustomControl.SetOnRE_OverURL', 0 @@e_signature: end; - if @ FOnRE_OverURL = @ Value then Exit; + if @FOnRE_OverURL = @Value then + Exit; FOnRE_OverURL := Value; Change; end; @@ -7063,7 +6627,8 @@ begin DB 'TKOLCustomControl.SetOnRE_URLClick', 0 @@e_signature: end; - if @ FOnRE_URLClick = @ Value then Exit; + if @FOnRE_URLClick = @Value then + Exit; FOnRE_URLClick := Value; Change; end; @@ -7076,7 +6641,8 @@ begin DB 'TKOLCustomControl.SetOnSelChange', 0 @@e_signature: end; - if @ FOnSelChange = @ Value then Exit; + if @FOnSelChange = @Value then + Exit; FOnSelChange := Value; Change; end; @@ -7089,7 +6655,8 @@ begin DB 'TKOLCustomControl.SetOnShow', 0 @@e_signature: end; - if @ FOnShow = @ Value then Exit; + if @FOnShow = @Value then + Exit; FOnShow := Value; Change; end; @@ -7102,7 +6669,8 @@ begin DB 'TKOLCustomControl.SetOnSplit', 0 @@e_signature: end; - if @ FOnSplit = @ Value then Exit; + if @FOnSplit = @Value then + Exit; FOnSplit := Value; Change; end; @@ -7115,7 +6683,8 @@ begin DB 'TKOLCustomControl.SetOnTBDropDown', 0 @@e_signature: end; - if @ FOnTBDropDown = @ Value then Exit; + if @FOnTBDropDown = @Value then + Exit; FOnTBDropDown := Value; Change; end; @@ -7128,7 +6697,8 @@ begin DB 'TKOLCustomControl.SetOnTVBeginDrag', 0 @@e_signature: end; - if @ FOnTVBeginDrag = @ Value then Exit; + if @FOnTVBeginDrag = @Value then + Exit; FOnTVBeginDrag := Value; Change; end; @@ -7141,7 +6711,8 @@ begin DB 'TKOLCustomControl.SetOnTVBeginEdit', 0 @@e_signature: end; - if @ FOnTVBeginEdit = @ Value then Exit; + if @FOnTVBeginEdit = @Value then + Exit; FOnTVBeginEdit := Value; Change; end; @@ -7154,7 +6725,8 @@ begin DB 'TKOLCustomControl.SetOnTVDelete', 0 @@e_signature: end; - if @ FOnTVDelete = @ Value then Exit; + if @FOnTVDelete = @Value then + Exit; FOnTVDelete := Value; Change; end; @@ -7167,7 +6739,8 @@ begin DB 'TKOLCustomControl.SetOnTVEndEdit', 0 @@e_signature: end; - if @ FOnTVEndEdit = @ Value then Exit; + if @FOnTVEndEdit = @Value then + Exit; FOnTVEndEdit := Value; Change; end; @@ -7180,7 +6753,8 @@ begin DB 'TKOLCustomControl.SetOnTVExpanded', 0 @@e_signature: end; - if @ FOnTVExpanded = @ Value then Exit; + if @FOnTVExpanded = @Value then + Exit; FOnTVExpanded := Value; Change; end; @@ -7193,7 +6767,8 @@ begin DB 'TKOLCustomControl.SetOnTVExpanding', 0 @@e_signature: end; - if @ FOnTVExpanding = @ Value then Exit; + if @FOnTVExpanding = @Value then + Exit; FOnTVExpanding := Value; Change; end; @@ -7206,19 +6781,21 @@ begin DB 'TKOLCustomControl.SetOnTVSelChanging', 0 @@e_signature: end; - if @ FOnTVSelChanging = @ Value then Exit; + if @FOnTVSelChanging = @Value then + Exit; FOnTVSelChanging := Value; Change; end; procedure TKOLCustomControl.SetParent(Value: TWinControl); -var PF: TKOLFont; - {$IFDEF _KOLCTRLWRAPPER_} - PT: TPaintType; - {$ENDIF} - CodeAddr: procedure of object; - F: TKOLForm; - Cname: String; +var + PF: TKOLFont; +{$IFDEF _KOLCTRLWRAPPER_} + PT: TPaintType; +{$ENDIF} + CodeAddr: procedure of object; + F: TKOLForm; + Cname: string; begin asm jmp @@e_signature @@ -7226,53 +6803,52 @@ begin DB 'TKOLCustomControl.SetParent', 0 @@e_signature: end; - Cname := Name; - Log( '->TKOLCustomControl.SetParent(' + Cname + ')' ); + Cname := name; + Log('->TKOLCustomControl.SetParent(' + Cname + ')'); try - Log( '1 - inherited' ); - inherited; + Log('1 - inherited'); + inherited; - Log( '2 - ParentKOLForm' ); - F := ParentKOLForm; - if (F <> nil) and not F.FIsDestroying and (Owner <> nil) and - not( csDestroying in Owner.ComponentState ) then begin - Log( '3 - Value <> nil?' ); - if Value <> nil then - if (Value is TKOLCustomControl) or (Value is TForm) then begin - Log( '4 - Get_ParentFont' ); - PF := Get_ParentFont; - Log( '5 - Font(=' + Int2Hex( DWORD( Font), 6 ) + ').Assign( PF(=' + Int2Hex( DWORD( PF ), 6 ) + ') )' ); - try - Font.Assign(PF); {YS} - except - on E: Exception do - begin - Log( 'Exception while assigning a font:' + E.message ); + Log('2 - ParentKOLForm'); + F := ParentKOLForm; + if (F <> nil) and not F.FIsDestroying and (Owner <> nil) and + not (csDestroying in Owner.ComponentState) then begin + Log('3 - Value <> nil?'); + if Value <> nil then + if (Value is TKOLCustomControl) or (Value is TForm) then begin + Log('4 - Get_ParentFont'); + PF := Get_ParentFont; + Log('5 - Font(=' + Int2Hex(DWORD(Font), 6) + ').Assign( PF(=' + Int2Hex(DWORD(PF), 6) + ') )'); + try + Font.Assign(PF); {YS} + except + on E: Exception do begin + Log('Exception while assigning a font:' + E.Message); + end; + end; end; + {YS} +{$IFDEF _KOLCtrlWrapper_} + Log('6 - PaintType'); + PT := PaintType; + FAllowSelfPaint := PT in [ptWYSIWIG, ptWYSIWIGFrames]; + FAllowCustomPaint := PT <> ptWYSIWIG; +{$ENDIF} + {YS} + Log('7 - CodeAddr := Change'); + CodeAddr := Change; + try + Log('8 - Change'); + Change; + except on E: Exception do + Log('Exception in TKOLCustomControl.SetParent: ' + E.Message); end; end; - {YS} - {$IFDEF _KOLCtrlWrapper_} - Log( '6 - PaintType' ); - PT := PaintType; - FAllowSelfPaint := PT in [ptWYSIWIG, ptWYSIWIGFrames]; - FAllowCustomPaint:=PT <> ptWYSIWIG; - {$ENDIF} - {YS} - Log( '7 - CodeAddr := Change' ); - CodeAddr := Change; - TRY - Log( '8 - Change' ); - Change; - EXCEPT on E: Exception do - Log( 'Exception in TKOLCustomControl.SetParent: ' + E.Message ); - END; - end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.SetParent(' + Cname + ')' ); + Log('<-TKOLCustomControl.SetParent(' + Cname + ')'); end; end; @@ -7284,20 +6860,18 @@ begin DB 'TKOLCustomControl.SetparentColor', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetparentColor' ); + Log('->TKOLCustomControl.SetparentColor'); try - FParentColor := Value; - if Value then - begin - if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm <> nil) then - Color := ParentKOLForm.Color - else - if ParentKOLControl <> nil then - Color := (ParentKOLControl as TKOLCustomControl).Color; - end; - LogOK; + FParentColor := Value; + if Value then begin + if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm <> nil) then + Color := ParentKOLForm.Color + else if ParentKOLControl <> nil then + Color := (ParentKOLControl as TKOLCustomControl).Color; + end; + LogOK; finally - Log( '<-TKOLCustomControl.SetparentColor' ); + Log('<-TKOLCustomControl.SetparentColor'); end; end; @@ -7309,27 +6883,27 @@ begin DB 'TKOLCustomControl.SetParentFont', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetParentFont' ); + Log('->TKOLCustomControl.SetParentFont'); try - FParentFont := Value; - if Value then - begin - if FFont = nil then Exit; - if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm <> nil) then - Font.Assign( ParentKOLForm.Font ) - else - if ParentKOLControl <> nil then - Font.Assign( (ParentKOLControl as TKOLCustomControl).Font ); - end; - LogOK; + FParentFont := Value; + if Value then begin + if fFont = nil then + Exit; + if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm <> nil) then + Font.Assign(ParentKOLForm.Font) + else if ParentKOLControl <> nil then + Font.Assign((ParentKOLControl as TKOLCustomControl).Font); + end; + LogOK; finally - Log( '<-TKOLCustomControl.SetParentFont' ); + Log('<-TKOLCustomControl.SetParentFont'); end; end; procedure TKOLCustomControl.SetPlaceDown(const Value: Boolean); -var R: TRect; - M: Integer; +var + R: TRect; + M: Integer; begin asm jmp @@e_signature @@ -7337,37 +6911,35 @@ begin DB 'TKOLCustomControl.SetPlaceDown', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetPlaceDown' ); + Log('->TKOLCustomControl.SetPlaceDown'); try - if (fAlign <> caNone) and Value or (Value = fPlaceDown) then - begin - LogOK; - Exit; - end; - fPlaceDown := Value; - if Value then - begin - fPlaceRight := False; - fPlaceUnder := False; - fCenterOnParent := False; - if not (csLoading in ComponentState) then - begin - R := PrevBounds; - M := ParentMargin; - Left := M; - Top := R.Bottom + M; + if (fAlign <> caNone) and Value or (Value = fPlaceDown) then begin + LogOK; + Exit; end; - end; - Change; - LogOK; + fPlaceDown := Value; + if Value then begin + fPlaceRight := False; + fPlaceUnder := False; + fCenterOnParent := False; + if not (csLoading in ComponentState) then begin + R := PrevBounds; + M := ParentMargin; + Left := M; + Top := R.Bottom + M; + end; + end; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetPlaceDown' ); + Log('<-TKOLCustomControl.SetPlaceDown'); end; end; procedure TKOLCustomControl.SetPlaceRight(const Value: Boolean); -var R: TRect; - M: Integer; +var + R: TRect; + M: Integer; begin asm jmp @@e_signature @@ -7375,37 +6947,35 @@ begin DB 'TKOLCustomControl.SetPlaceRight', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetPlaceRight' ); + Log('->TKOLCustomControl.SetPlaceRight'); try - if (fAlign <> caNone) and Value or (Value = fPlaceRight) then - begin - LogOK; - Exit; - end; - fPlaceRight := Value; - if Value then - begin - fPlaceDown := False; - fPlaceUnder := False; - fCenterOnParent := False; - if not (csLoading in ComponentState) then - begin - R := PrevBounds; - M := ParentMargin; - Left := R.Right + M; - Top := R.Top; + if (fAlign <> caNone) and Value or (Value = fPlaceRight) then begin + LogOK; + Exit; end; - end; - Change; - LogOK; + fPlaceRight := Value; + if Value then begin + fPlaceDown := False; + fPlaceUnder := False; + fCenterOnParent := False; + if not (csLoading in ComponentState) then begin + R := PrevBounds; + M := ParentMargin; + Left := R.Right + M; + Top := R.Top; + end; + end; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetPlaceRight' ); + Log('<-TKOLCustomControl.SetPlaceRight'); end; end; procedure TKOLCustomControl.SetPlaceUnder(const Value: Boolean); -var R: TRect; - M: Integer; +var + R: TRect; + M: Integer; begin asm jmp @@e_signature @@ -7413,31 +6983,28 @@ begin DB 'TKOLCustomControl.SetPlaceUnder', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetPlaceUnder' ); + Log('->TKOLCustomControl.SetPlaceUnder'); try - if (fAlign <> caNone) and Value or (Value = fPlaceUnder) then - begin - LogOK; - Exit; - end; - fPlaceUnder := Value; - if Value then - begin - fPlaceDown := False; - fPlaceRight := False; - fCenterOnParent := False; - if not (csLoading in ComponentState) then - begin - R := PrevBounds; - M := ParentMargin; - Left := R.Left; - Top := R.Bottom + M; + if (fAlign <> caNone) and Value or (Value = fPlaceUnder) then begin + LogOK; + Exit; end; - end; - Change; - LogOK; + fPlaceUnder := Value; + if Value then begin + fPlaceDown := False; + fPlaceRight := False; + fCenterOnParent := False; + if not (csLoading in ComponentState) then begin + R := PrevBounds; + M := ParentMargin; + Left := R.Left; + Top := R.Bottom + M; + end; + end; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetPlaceUnder' ); + Log('<-TKOLCustomControl.SetPlaceUnder'); end; end; @@ -7449,15 +7016,16 @@ begin DB 'TKOLCustomControl.SetShadowDeep', 0 @@e_signature: end; - if FShadowDeep = Value then Exit; - Log( '->TKOLCustomControl.SetShadowDeep' ); + if FShadowDeep = Value then + Exit; + Log('->TKOLCustomControl.SetShadowDeep'); try - FShadowDeep := Value; - Invalidate; - Change; - LogOK; + FShadowDeep := Value; + Invalidate; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetShadowDeep' ); + Log('<-TKOLCustomControl.SetShadowDeep'); end; end; @@ -7469,23 +7037,25 @@ begin DB 'TKOLCustomControl.SetStyle', 0 @@e_signature: end; - if fStyle = Value then Exit; - Log( '->TKOLCustomControl.SetStyle' ); + if fStyle = Value then + Exit; + Log('->TKOLCustomControl.SetStyle'); try - fStyle := Value; - Change; - LogOK; + fStyle := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetStyle' ); + Log('<-TKOLCustomControl.SetStyle'); end; end; procedure TKOLCustomControl.SetTabOrder(const Value: Integer); -var K, C: TComponent; - I, Old, N, MinIdx: Integer; - L: TList; - kC, kMin: TKOLCustomControl; - Found: Boolean; +var + k, c: TComponent; + I, Old, N, MinIdx: Integer; + L: TList; + KC, kMin: TKOLCustomControl; + Found: Boolean; begin asm jmp @@e_signature @@ -7493,108 +7063,102 @@ begin DB 'TKOLCustomControl.SetTabOrder', 0 @@e_signature: end; - if FTabOrder = Value then Exit; - Log( '->TKOLCustomControl.SetTabOrder' ); + if FTabOrder = Value then + Exit; + Log('->TKOLCustomControl.SetTabOrder'); try - Old := FTabOrder; - FTabOrder := Value; - if FTabOrder < -2 then - FTabOrder := -1; - if FTabOrder > 100000 then - FTabOrder := 100000; - if FTabOrder >= 0 then - if not(csLoading in ComponentState) and not FAdjustingTabOrder then - begin - FAdjustingTabOrder := TRUE; - TRY + Old := FTabOrder; + FTabOrder := Value; + if FTabOrder < -2 then + FTabOrder := -1; + if FTabOrder > 100000 then + FTabOrder := 100000; + if FTabOrder >= 0 then + if not (csLoading in ComponentState) and not FAdjustingTabOrder then begin + FAdjustingTabOrder := True; + try - L := TList.Create; - K := ParentForm; - if K <> nil then - try - for I := 0 to K.ComponentCount - 1 do - begin - C := K.Components[ I ]; - //if C = Self then continue; - if not( C is TKOLCustomControl ) then continue; - kC := C as TKOLCustomControl; - if kC.Parent <> Parent then continue; - L.Add( kC ); - end; - // 1. Move TabOrder for all controls with TabOrder >= Value up. - // 1. Переместить TabOrder для всех, кто имеет такой же и выше, на 1 вверх. - for I := 0 to L.Count - 1 do - begin - kC := L.Items[ I ]; - if kC = Self then continue; - if kC.FTabOrder >= Value then - Inc( kC.FTabOrder ); - end; - // 2. "Squeeze" to prevent holes. (To prevent situation, when N, N+k, - // values are present and N+1 is not used). - for N := 0 to L.Count - 1 do - begin - Found := FALSE; - for I := 0 to L.Count - 1 do - begin - kC := L.Items[ I ]; - if kC.FTabOrder = N then - begin - Found := TRUE; - break; + L := TList.Create; + k := ParentForm; + if k <> nil then try + for I := 0 to k.ComponentCount - 1 do begin + c := k.Components[I]; + //if C = Self then continue; + if not (c is TKOLCustomControl) then + Continue; + KC := c as TKOLCustomControl; + if KC.Parent <> Parent then + Continue; + L.Add(KC); end; - end; - if not Found then - begin - // Value N is not used as a TabOrder. Try to find next used TabOrder - // value and move it to N. - MinIdx := -1; - for I := 0 to L.Count - 1 do - begin - kC := L.Items[ I ]; - if kC.FTabOrder > MaxInt div 4 - 1 then continue; - if kC.FTabOrder < -MaxInt div 4 + 1 then continue; - if (kC.FTabOrder > N) then - begin - if (MinIdx >= 0) then - begin - kMin := L.Items[ MinIdx ]; - if kC.FTabOrder < kMin.FTabOrder then - MinIdx := I; - end - else - MinIdx := I; + // 1. Move TabOrder for all controls with TabOrder >= Value up. + // 1. Переместить TabOrder для всех, кто имеет такой же и выше, на 1 вверх. + for I := 0 to L.Count - 1 do begin + KC := L.Items[I]; + if KC = Self then + Continue; + if KC.FTabOrder >= Value then + Inc(KC.FTabOrder); + end; + // 2. "Squeeze" to prevent holes. (To prevent situation, when N, N+k, + // values are present and N+1 is not used). + for N := 0 to L.Count - 1 do begin + Found := False; + for I := 0 to L.Count - 1 do begin + KC := L.Items[I]; + if KC.FTabOrder = N then begin + Found := True; + Break; + end; + end; + if not Found then begin + // Value N is not used as a TabOrder. Try to find next used TabOrder + // value and move it to N. + MinIdx := -1; + for I := 0 to L.Count - 1 do begin + KC := L.Items[I]; + if KC.FTabOrder > MaxInt div 4 - 1 then + Continue; + if KC.FTabOrder < -MaxInt div 4 + 1 then + Continue; + if (KC.FTabOrder > N) then begin + if (MinIdx >= 0) then begin + kMin := L.Items[MinIdx]; + if KC.FTabOrder < kMin.FTabOrder then + MinIdx := I; + end + else + MinIdx := I; + end; + end; + if MinIdx < 0 then + Break; + // Such TabOrder value found at control with MinIdx index in a list. + kMin := L.Items[MinIdx]; + MinIdx := kMin.FTabOrder; + for I := 0 to L.Count - 1 do begin + KC := L.Items[I]; + if KC.FTabOrder > N then begin + KC.FTabOrder := KC.FTabOrder - (MinIdx - N); + //ShowMessage( kC.Name + '.TabOrder := ' + IntToStr( kC.TabOrder ) ); + end; + end; end; end; - if MinIdx < 0 then break; - // Such TabOrder value found at control with MinIdx index in a list. - kMin := L.Items[ MinIdx ]; - MinIdx := kMin.FTabOrder; - for I := 0 to L.Count - 1 do - begin - kC := L.Items[ I ]; - if kC.FTabOrder > N then - begin - kC.FTabOrder := kC.FTabOrder - (MinIdx - N); - //ShowMessage( kC.Name + '.TabOrder := ' + IntToStr( kC.TabOrder ) ); - end; - end; - end; - end; - finally - L.Free; + finally + L.free; + end; + finally + FAdjustingTabOrder := False; + end; end; - FINALLY - FAdjustingTabOrder := FALSE; - END; - end; - if Old <> FTabOrder then - ReAlign( TRUE ); - Change; - LogOK; + if Old <> FTabOrder then + ReAlign(True); + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetTabOrder' ); + Log('<-TKOLCustomControl.SetTabOrder'); end; end; @@ -7608,14 +7172,15 @@ begin DB 'TKOLCustomControl.SetTabStop', 0 @@e_signature: end; - if FTabStop = Value then Exit; - Log( '->TKOLCustomControl.SetTabStop' ); + if FTabStop = Value then + Exit; + Log('->TKOLCustomControl.SetTabStop'); try - FTabStop := Value; - Change; - LogOK; + FTabStop := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetTabStop' ); + Log('<-TKOLCustomControl.SetTabStop'); end; end; @@ -7627,14 +7192,15 @@ begin DB 'TKOLCustomControl.SetTag', 0 @@e_signature: end; - if FTag = Value then Exit; - Log( '->TKOLCustomControl.SetTag' ); - TRY - FTag := Value; - Change; - LogOK; + if FTag = Value then + Exit; + Log('->TKOLCustomControl.SetTag'); + try + FTag := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetTabStop' ); + Log('<-TKOLCustomControl.SetTabStop'); end; end; @@ -7646,25 +7212,26 @@ begin DB 'TKOLCustomControl.SetTextAlign', 0 @@e_signature: end; - if FTextAlign = Value then Exit; - Log( '->TKOLCustomControl.SetTextAlign' ); + if FTextAlign = Value then + Exit; + Log('->TKOLCustomControl.SetTextAlign'); try - FTextAlign := Value; -{YS} - {$IFDEF _KOLCtrlWrapper_} - if Assigned(FKOLCtrl) then - FKOLCtrl.TextAlign:=kol.TTextAlign(Value); - {$ENDIF} -{YS} - Invalidate; - Change; - LogOK; + FTextAlign := Value; + {YS} +{$IFDEF _KOLCtrlWrapper_} + if Assigned(FKOLCtrl) then + FKOLCtrl.TextAlign := KOL.TTextAlign(Value); +{$ENDIF} + {YS} + Invalidate; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetTextAlign' ); + Log('<-TKOLCustomControl.SetTextAlign'); end; end; -function Color2Str( Color: TColor ): String; +function Color2Str(Color: TColor): string; begin asm jmp @@e_signature @@ -7673,55 +7240,55 @@ begin @@e_signature: end; case Color of - clScrollBar: Result := 'clScrollBar'; - clBackground: Result := 'clBackground'; - clActiveCaption: Result := 'clActiveCaption'; - clInactiveCaption: Result := 'clInactiveCaption'; - clMenu: Result := 'clMenu'; - clWindow: Result := 'clWindow'; - clWindowFrame: Result := 'clWindowFrame'; - clMenuText: Result := 'clMenuText'; - clWindowText: Result := 'clWindowText'; - clCaptionText: Result := 'clCaptionText'; - clActiveBorder: Result := 'clActiveBorder'; - clInactiveBorder: Result := 'clInactiveBorder'; - clAppWorkSpace: Result := 'clAppWorkSpace'; - clHighlight: Result := 'clHighlight'; - clHighlightText: Result := 'clHighlightText'; - clBtnFace: Result := 'clBtnFace'; - clBtnShadow: Result := 'clBtnShadow'; - clGrayText: Result := 'clGrayText'; - clBtnText: Result := 'clBtnText'; - clInactiveCaptionText: Result := 'clInactiveCaptionText'; - clBtnHighlight: Result := 'clBtnHighlight'; - cl3DDkShadow: Result := 'cl3DDkShadow'; - cl3DLight: Result := 'cl3DLight'; - clInfoText: Result := 'clInfoText'; - clInfoBk: Result := 'clInfoBk'; + clScrollBar: Result := 'clScrollBar'; + clBackground: Result := 'clBackground'; + clActiveCaption: Result := 'clActiveCaption'; + clInactiveCaption: Result := 'clInactiveCaption'; + clMenu: Result := 'clMenu'; + clWindow: Result := 'clWindow'; + clWindowFrame: Result := 'clWindowFrame'; + clMenuText: Result := 'clMenuText'; + clWindowText: Result := 'clWindowText'; + clCaptionText: Result := 'clCaptionText'; + clActiveBorder: Result := 'clActiveBorder'; + clInactiveBorder: Result := 'clInactiveBorder'; + clAppWorkSpace: Result := 'clAppWorkSpace'; + clHighlight: Result := 'clHighlight'; + clHighlightText: Result := 'clHighlightText'; + clBtnFace: Result := 'clBtnFace'; + clBtnShadow: Result := 'clBtnShadow'; + clGrayText: Result := 'clGrayText'; + clBtnText: Result := 'clBtnText'; + clInactiveCaptionText: Result := 'clInactiveCaptionText'; + clBtnHighlight: Result := 'clBtnHighlight'; + cl3DDkShadow: Result := 'cl3DDkShadow'; + cl3DLight: Result := 'cl3DLight'; + clInfoText: Result := 'clInfoText'; + clInfoBk: Result := 'clInfoBk'; - clBlack: Result := 'clBlack'; - clMaroon: Result := 'clMaroon'; - clGreen: Result := 'clGreen'; - clOlive: Result := 'clOlive'; - clNavy: Result := 'clNavy'; - clPurple: Result := 'clPurple'; - clTeal: Result := 'clTeal'; - clGray: Result := 'clGray'; - clSilver: Result := 'clSilver'; - clRed: Result := 'clRed'; - clLime: Result := 'clLime'; - clYellow: Result := 'clYellow'; - clBlue: Result := 'clBlue'; - clFuchsia: Result := 'clFuchsia'; - clAqua: Result := 'clAqua'; - //clLtGray: Result := 'clLtGray'; - //clDkGray: Result := 'clDkGray'; - clWhite: Result := 'clWhite'; - clNone: Result := 'clNone'; - clDefault: Result := 'clDefault'; + clBlack: Result := 'clBlack'; + clMaroon: Result := 'clMaroon'; + clGreen: Result := 'clGreen'; + clOlive: Result := 'clOlive'; + clNavy: Result := 'clNavy'; + clPurple: Result := 'clPurple'; + clTeal: Result := 'clTeal'; + clGray: Result := 'clGray'; + clSilver: Result := 'clSilver'; + clRed: Result := 'clRed'; + clLime: Result := 'clLime'; + clYellow: Result := 'clYellow'; + clBlue: Result := 'clBlue'; + clFuchsia: Result := 'clFuchsia'; + clAqua: Result := 'clAqua'; + //clLtGray: Result := 'clLtGray'; + //clDkGray: Result := 'clDkGray'; + clWhite: Result := 'clWhite'; + clNone: Result := 'clNone'; + clDefault: Result := 'clDefault'; else - Result := '$' + Int2Hex( Color, 6 ); + Result := '$' + Int2Hex(Color, 6); end; end; @@ -7733,15 +7300,14 @@ begin DB 'TKOLCustomControl.SetTransparent', 0 @@e_signature: end; - if FTransparent = Value then Exit; + if FTransparent = Value then + Exit; FTransparent := Value; Invalidate; Change; end; -procedure TKOLCustomControl.SetupColor(SL: TStrings; const AName: String); -var KF: TKOLForm; - C: DWORD; +procedure TKOLCustomControl.SetupColor(SL: TStrings; const AName: string); begin asm jmp @@e_signature @@ -7750,39 +7316,23 @@ begin @@e_signature: end; - KF := ParentKOLForm; - - if (Brush.Bitmap = nil) or Brush.Bitmap.Empty then - begin - if Brush.BrushStyle <> bsSolid then - Brush.GenerateCode( SL, AName ) - else - begin - if DefaultKOLParentColor and not parentColor or - not DefaultKOLParentColor and (Color <> DefaultColor) then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetColor', '' ); - C := Color; - if C and $FF000000 = $FF000000 then - C := C and $FFFFFF or $80000000; - C := (C shl 1) or (C shr 31); - RptDetailed( 'Prepare FormSetColor parameter, src color =$' + - Int2Hex( Color, 2 ) + ', coded color =$' + - Int2Hex( C, 2 ), CYAN ); - KF.FormAddNumParameter( C ); - //SL.Add( '//Color = ' + IntToStr( Color ) ); - end else - SL.Add( ' ' + AName + '.Color := TColor(' + Color2Str( Color ) + ');' ); - end; + if (Brush.Bitmap = nil) or Brush.Bitmap.Empty then begin + if Brush.BrushStyle <> bsSolid then + Brush.GenerateCode(SL, AName) + else begin + if DefaultKOLParentColor and not parentColor or + not DefaultKOLParentColor and (Color <> DefaultColor) then + SL.Add(' ' + AName + '.Color := TColor(' + Color2Str(Color) + ');'); + end; end else - Brush.GenerateCode( SL, AName ); + Brush.GenerateCode(SL, AName); end; procedure TKOLCustomControl.SetupConstruct(SL: TStringList; const AName, AParent, - Prefix: String); -var S: String; + Prefix: string); +var + s: string; begin asm jmp @@e_signature @@ -7790,36 +7340,22 @@ begin DB 'TKOLCustomControl.SetupConstruct', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetupConstruct' ); + Log('->TKOLCustomControl.SetupConstruct'); try - if ParentKOLForm.FormCompact - and SupportsFormCompact then - begin - if HasCompactConstructor then - SetupConstruct_Compact - else - SL.Add( Prefix + AName + ' := New' + TypeName + '( ' - + SetupParams( AName, AParent ) + ' );' ); - GenerateTransparentInits_Compact; - end - else - begin - S := GenerateTransparentInits; - SL.Add( Prefix + AName + ' := New' + TypeName + '( ' - + SetupParams( AName, AParent ) + ' )' + S + ';' ); - end; - SetupName( SL, AName, AParent, Prefix ); - SetupSetUnicode( SL, AName ); - LogOK; + s := GenerateTransparentInits; + SL.Add(Prefix + AName + ' := New' + TypeName + '( ' + + SetupParams(AName, AParent) + ' )' + s + ';'); + SetupName(SL, AName, AParent, Prefix); + SetupSetUnicode(SL, AName); + LogOK; finally - Log( '<-TKOLCustomControl.SetupConstruct' ); + Log('<-TKOLCustomControl.SetupConstruct'); end; end; -procedure TKOLCustomControl.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -var KF: TKOLForm; - CompactCode: Boolean; +procedure TKOLCustomControl.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +var + KF: TKOLForm; begin asm jmp @@e_signature @@ -7827,250 +7363,121 @@ begin DB 'TKOLCustomControl.SetupFirst', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetupFirst' ); + Log('->TKOLCustomControl.SetupFirst'); try - fOrderChild := 0; - SetupConstruct( SL, AName, AParent, Prefix ); - SetupName( SL, AName, AParent, Prefix ); + fOrderChild := 0; + SetupConstruct(SL, AName, AParent, Prefix); + SetupName(SL, AName, AParent, Prefix); - KF := ParentKOLForm; - CompactCode := (KF <> nil) and KF.FormCompact and SupportsFormCompact; + KF := ParentKOLForm; - if Tag <> 0 then - begin - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetTag', '' ); - KF.FormAddNumParameter( Tag ); - end + if Tag <> 0 then begin + if Tag < 0 then + SL.Add(Prefix + AName + '.Tag := DWORD(' + IntToStr(Tag) + ');') else - begin - if Tag < 0 then - SL.Add( Prefix + AName + '.Tag := DWORD(' + IntToStr(Tag) + ');' ) - else - SL.Add( Prefix + AName + '.Tag := ' + IntToStr(Tag) + ';' ); - end; - end; + SL.Add(Prefix + AName + '.Tag := ' + IntToStr(Tag) + ';'); + end; - if not Ctl3D then - if CompactCode then - KF.FormAddCtlCommand( Name, 'FormResetCtl3D', '' ) - else - SL.Add( Prefix + AName + '.Ctl3D := False;' ); + if not Ctl3D then + SL.Add(Prefix + AName + '.Ctl3D := False;'); - if FHasBorder <> FDefHasBorder then - begin - if CompactCode then - begin - if HasBorder then - KF.FormAddCtlCommand( Name, 'TControl.SetHasBorder', '' ) - // param = 1 - else - KF.FormAddCtlCommand( Name, 'FormSetHasBorderFalse', '' ); - end else - SL.Add( Prefix + AName + '.HasBorder := ' + BoolVals[ FHasBorder ] + ';' ); - //ShowMessage( AName + '.HasBorder := ' + BoolVals[ FHasBorder ] ); - end; + if FHasBorder <> FDefHasBorder then begin + SL.Add(Prefix + AName + '.HasBorder := ' + BoolVals[FHasBorder] + ';'); + end; - SetupTabStop( SL, AName ); - SetupFont( SL, AName ); - SetupTextAlign( SL, AName ); - if (csAcceptsControls in ControlStyle) or BorderNeeded then - if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm.Border <> Border) - or (ParentKOLControl <> ParentKOLForm) and ((ParentKOLControl as TKOLCustomControl).Border <> Border) then - if CompactCode then - begin - if Border = 1 then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetBorder', '' ); - // param = 1 - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetBorder', '' ); - KF.FormAddNumParameter( Border ); - end; - end else - begin + SetupTabStop(SL, AName); + SetupFont(SL, AName); + SetupTextAlign(SL, AName); + if (csAcceptsControls in ControlStyle) or BorderNeeded then + if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm.Border <> Border) + or (ParentKOLControl <> ParentKOLForm) and ((ParentKOLControl as TKOLCustomControl).Border <> Border) then //SL.Add( Prefix + AName + '.Border := ' + IntToStr( Border ) + ';' ); //--- moved to GenerateTransparentInits + + if MarginTop <> DefaultMarginTop then + SL.Add(Prefix + AName + '.MarginTop := ' + IntToStr(MarginTop) + ';'); + + if MarginBottom <> DefaultMarginBottom then + SL.Add(Prefix + AName + '.MarginBottom := ' + IntToStr(MarginBottom) + ';'); + + if MarginLeft <> DefaultMarginLeft then + SL.Add(Prefix + AName + '.MarginLeft := ' + IntToStr(MarginLeft) + ';'); + + if MarginRight <> DefaultMarginRight then + SL.Add(Prefix + AName + '.MarginRight := ' + IntToStr(MarginRight) + ';'); + + if not IsCursorDefault then + if Copy(Cursor_, 1, 4) = 'IDC_' then + SL.Add(Prefix + AName + '.Cursor := LoadCursor( 0, ' + Cursor_ + ' );') + else + SL.Add(Prefix + AName + '.Cursor := LoadCursor( hInstance, ''' + Trim(Cursor_) + ''' );'); + + if not Visible and (Faction = nil) then + SL.Add(Prefix + AName + '.Visible := False;'); + + if not Enabled and (Faction = nil) then + SL.Add(Prefix + AName + '.Enabled := False;'); + + if DoubleBuffered and not Transparent then + SL.Add(Prefix + AName + '.DoubleBuffered := True;'); + + if Owner <> nil then + if Transparent and ((Owner is TKOLCustomControl) + and not (Owner as TKOLCustomControl).Transparent + or not (Owner is TKOLCustomControl) + and not ParentKOLForm.Transparent) then + SL.Add(Prefix + AName + '.Transparent := True;'); + + if Owner = nil then + if Transparent then + SL.Add(Prefix + AName + '.Transparent := TRUE;'); + + if EraseBackground then + SL.Add(Prefix + AName + '.EraseBackground := TRUE;'); + + if MinWidth > 0 then + SL.Add(Prefix + AName + '.MinWidth := ' + IntToStr(MinWidth) + ';'); + + if MinHeight > 0 then + SL.Add(Prefix + AName + '.MinHeight := ' + IntToStr(MinHeight) + ';'); + + if MaxWidth > 0 then + SL.Add(Prefix + AName + '.MaxWidth := ' + IntToStr(MaxWidth) + ';'); + + if MaxHeight > 0 then + SL.Add(Prefix + AName + '.MaxHeight := ' + IntToStr(MaxHeight) + ';'); + + if IgnoreDefault <> FDefIgnoreDefault then + SL.Add(Prefix + AName + '.IgnoreDefault := ' + BoolVals[IgnoreDefault] + ';'); + + //Rpt( '-------- FHint = ' + FHint ); + if (Trim(FHint) <> '') and (Faction = nil) and KF.AssignTextToControls then begin + if (ParentKOLForm <> nil) and ParentKOLForm.ShowHint then begin + SL.Add(Prefix + '{$IFDEF USE_MHTOOLTIP}'); + SL.Add(Prefix + AName + '.Hint.Text := ' + StringConstant('Hint', Hint) + ';'); + SL.Add(Prefix + '{$ENDIF USE_MHTOOLTIP}'); end; + end; - if MarginTop <> DefaultMarginTop then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetMarginTop', '' ); - KF.FormAddNumParameter( MarginTop ); - end else - SL.Add( Prefix + AName + '.MarginTop := ' + IntToStr( MarginTop ) + ';' ); + if SetupColorFirst then + SetupColor(SL, AName); - if MarginBottom <> DefaultMarginBottom then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetMarginBottom', '' ); - KF.FormAddNumParameter( MarginBottom ); - end else - SL.Add( Prefix + AName + '.MarginBottom := ' + IntToStr( MarginBottom ) + ';' ); + {-- move to SetupLast: + if Assigned( FpopupMenu ) then + SL.Add( Prefix + AName + '.SetAutoPopupMenu( Result.' + FpopupMenu.Name + + ' );' ); + } - if MarginLeft <> DefaultMarginLeft then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetMarginLeft', '' ); - KF.FormAddNumParameter( MarginLeft ); - end else - SL.Add( Prefix + AName + '.MarginLeft := ' + IntToStr( MarginLeft ) + ';' ); - - if MarginRight <> DefaultMarginRight then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetMarginRight', '' ); - KF.FormAddNumParameter( MarginRight ); - end else - SL.Add( Prefix + AName + '.MarginRight := ' + IntToStr( MarginRight ) + ';' ); - - if not IsCursorDefault then - if Copy( Cursor_, 1, 4 ) = 'IDC_' then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormCursorLoad_0', '' ); - KF.FormAddNumParameter( IDC2Number( Cursor_ ) ); - end else - SL.Add( Prefix + AName + '.Cursor := LoadCursor( 0, ' + Cursor_ + ' );' ) - else - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormCursorLoad_hInstance', '' ); - KF.FormAddStrParameter( Cursor_ ); - end else - SL.Add( Prefix + AName + '.Cursor := LoadCursor( hInstance, ''' + Trim( Cursor_ ) + ''' );' ); - - if not Visible and (Faction = nil) then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetVisibleFalse', '' ); - end else - SL.Add( Prefix + AName + '.Visible := False;' ); - - if not Enabled and (Faction = nil) then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetEnabledFalse', '' ); - end else - SL.Add( Prefix + AName + '.Enabled := False;' ); - - if DoubleBuffered and not Transparent then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetDoubleBuffered', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.DoubleBuffered := True;' ); - - if Owner <> nil then - if Transparent and ((Owner is TKOLCustomControl) - and not (Owner as TKOLCustomControl).Transparent - or not(Owner is TKOLCustomControl) - and not ParentKOLForm.Transparent) then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetTransparent', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.Transparent := True;' ); - - if Owner = nil then - if Transparent then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetTransparent', '' ); - // param = 1 - end else - SL.Add( Prefix + AName + '.Transparent := TRUE;' ); - - if EraseBackground then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetEraseBkgndTrue', '' ); - end else - SL.Add( Prefix + AName + '.EraseBackground := TRUE;' ); - - if MinWidth > 0 then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetMinWidth', '' ); - KF.FormAddNumParameter( MinWidth ); - end else - SL.Add( Prefix + AName + '.MinWidth := ' + IntToStr( MinWidth ) + ';' ); - - if MinHeight > 0 then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetMinHeight', '' ); - KF.FormAddNumParameter( MinHeight ); - end else - SL.Add( Prefix + AName + '.MinHeight := ' + IntToStr( MinHeight ) + ';' ); - - if MaxWidth > 0 then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetMaxWidth', '' ); - KF.FormAddNumParameter( MaxWidth ); - end else - SL.Add( Prefix + AName + '.MaxWidth := ' + IntToStr( MaxWidth ) + ';' ); - - if MaxHeight > 0 then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetMaxHeight', '' ); - KF.FormAddNumParameter( MaxHeight ); - end else - SL.Add( Prefix + AName + '.MaxHeight := ' + IntToStr( MaxHeight ) + ';' ); - - if IgnoreDefault <> FDefIgnoreDefault then - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetIgnoreDefault', '' ); - KF.FormAddNumParameter( Integer( not IgnoreDefault ) ); - end else - SL.Add( Prefix + AName + '.IgnoreDefault := ' + BoolVals[ IgnoreDefault ] + ';' ); - - //Rpt( '-------- FHint = ' + FHint ); - if (Trim( FHint ) <> '') and (Faction = nil) and KF.AssignTextToControls then - begin - if (ParentKOLForm <> nil) and ParentKOLForm.ShowHint then - begin - if CompactCode then - begin - KF.FormAddCtlCommand( Name, 'FormSetHintText', '' ); - KF.FormAddStrParameter( Hint ); - end - else - begin - SL.Add( Prefix + '{$IFDEF USE_MHTOOLTIP}' ); - SL.Add( Prefix + AName + '.Hint.Text := ' + StringConstant( 'Hint', Hint ) + ';' ); - SL.Add( Prefix + '{$ENDIF USE_MHTOOLTIP}' ); - end; - end; - end; - - if SetupColorFirst then - SetupColor( SL, AName ); - - {-- move to SetupLast: - if Assigned( FpopupMenu ) then - SL.Add( Prefix + AName + '.SetAutoPopupMenu( Result.' + FpopupMenu.Name + - ' );' ); - } - - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.SetupFirst' ); + Log('<-TKOLCustomControl.SetupFirst'); end; end; -procedure TKOLCustomControl.SetupFont(SL: TStrings; const AName: String); -var PFont: TKOLFont; +procedure TKOLCustomControl.SetupFont(SL: TStrings; const AName: string); +var + PFont: TKOLFont; begin asm jmp @@e_signature @@ -8078,20 +7485,18 @@ begin DB 'TKOLCustomControl.SetupFont', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetupFont' ); + Log('->TKOLCustomControl.SetupFont'); try - PFont := Get_ParentFont; - if (PFont <> nil) and (not Assigned(Font) or not Font.Equal2( PFont )) then - Font.GenerateCode( SL, AName, PFont ); - LogOK; + PFont := Get_ParentFont; + if (PFont <> nil) and (not Assigned(Font) or not Font.Equal2(PFont)) then + Font.GenerateCode(SL, AName, PFont); + LogOK; finally - Log( '<-TKOLCustomControl.SetupFont' ); + Log('<-TKOLCustomControl.SetupFont'); end; end; -procedure TKOLCustomControl.SetupLast(SL: TStringList; const AName, AParent, Prefix: String); -var KF: TKOLForm; - i: Integer; +procedure TKOLCustomControl.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin asm jmp @@e_signature @@ -8101,114 +7506,76 @@ begin end; //Log( '->TKOLCustomControl.SetupLast' ); try + RptDetailed('Setuplast for ' + AName + ' entered', WHITE); - KF := ParentKOLForm; - RptDetailed( 'Setuplast for ' + AName + ' entered', WHITE ); + if not SetupColorFirst then + SetupColor(SL, AName); - if not SetupColorFirst then - SetupColor( SL, AName ); + if Assigned(FpopupMenu) then + SL.Add(Prefix + AName + '.SetAutoPopupMenu( Result.' + FpopupMenu.name + + ' );'); - if Assigned( FpopupMenu ) then - SL.Add( Prefix + AName + '.SetAutoPopupMenu( Result.' + FpopupMenu.Name + - ' );' ); + RptDetailed('AssignEvents for control calling', WHITE); + RptDetailed(name, YELLOW); + FAssignOnlyUserEvents := False; + AssignEvents(SL, AName); + FAssignOnlyWinEvents := False; + RptDetailed('AssignEvents for control called', WHITE); + RptDetailed(name, YELLOW); - RptDetailed( 'AssignEvents for control calling', WHITE ); - RptDetailed( Name, YELLOW ); - FAssignOnlyUserEvents := FALSE; - if (KF <> nil) and KF.FormCompact then - FAssignOnlyWinEvents := TRUE; - AssignEvents( SL, AName ); - FAssignOnlyWinEvents := FALSE; - RptDetailed( 'AssignEvents for control called', WHITE ); - RptDetailed( Name, YELLOW ); + if FDefaultBtn then + SL.Add(Prefix + AName + '.DefaultBtn := TRUE;'); - if fDefaultBtn then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetDefaultBtn', '' ); - KF.FormAddNumParameter( 13 ); - //KF.FormAddNumParameter( 1 ); - // param = 1 - end else - SL.Add( Prefix + AName + '.DefaultBtn := TRUE;' ); + if FCancelBtn then + SL.Add(Prefix + AName + '.CancelBtn := TRUE;'); - if fCancelBtn then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetDefaultBtn', '' ); - KF.FormAddNumParameter( 27 ); - //KF.FormAddNumParameter( 1 ); - // param = 1 - end else - SL.Add( Prefix + AName + '.CancelBtn := TRUE;' ); + if AnchorRight or AnchorBottom then + SL.Add(Prefix + AName + '.Anchor(' + + BoolVals[AnchorLeft] + ', ' + + BoolVals[AnchorTop] + ', ' + + BoolVals[AnchorRight] + ', ' + + BoolVals[AnchorBottom] + ');'); - if AnchorRight or AnchorBottom then - if (KF <> nil) and KF.FormCompact then - begin - i := Integer( AnchorLeft ) + - Integer( AnchorTop ) shl 1 + - Integer( AnchorRight ) shl 2 + - Integer( AnchorBottom ) shl 3; - if i = 1 then - KF.FormAddCtlCommand( Name, 'TControl.SetAnchor', '' ) - else - begin - KF.FormAddCtlCommand( Name, 'FormSetAnchor', '' ); - KF.FormAddNumParameter( i ); - end; - end else - SL.Add( Prefix + AName + '.Anchor(' + - BoolVals[ AnchorLeft ] + ', ' + - BoolVals[ AnchorTop ] + ', ' + - BoolVals[ AnchorRight ] + ', ' + - BoolVals[ AnchorBottom ] + ');' ); + if FOverrideScrollbars and FHasScrollbarsToOverride then begin + SL.Add(Prefix + '{$IFDEF OVERRIDE_SCROLLBARS}'); + SL.Add(Prefix + 'OverrideScrollbars( ' + AName + ');'); + SL.Add(Prefix + '{$ENDIF OVERRIDE_SCROLLBARS}'); + end; - if FOverrideScrollbars and FHasScrollbarsToOverride then - begin - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormOverrideScrollbars', '' ); - end - else - begin - SL.Add( Prefix + '{$IFDEF OVERRIDE_SCROLLBARS}' ); - SL.Add( Prefix + 'OverrideScrollbars( ' + AName + ');' ); - SL.Add( Prefix + '{$ENDIF OVERRIDE_SCROLLBARS}' ); - end; - end; + SetupTabOrder(SL, AName); + RptDetailed('Setuplast for form finished', WHITE); - SetupTabOrder( SL, AName ); - RptDetailed( 'Setuplast for form finished', WHITE ); - - //LogOK; + //LogOK; finally - //Log( '<-TKOLCustomControl.SetupLast' ); + //Log( '<-TKOLCustomControl.SetupLast' ); end; end; procedure TKOLCustomControl.SetAnchorLeft(const Value: Boolean); begin - if FAnchorLeft = Value then Exit; + if FAnchorLeft = Value then + Exit; FAnchorLeft := Value; if Value then - Anchors := Anchors + [ akLeft ] + Anchors := Anchors + [akLeft] else - Anchors := Anchors - [ akLeft ]; + Anchors := Anchors - [akLeft]; Change; end; procedure TKOLCustomControl.SetAnchorTop(const Value: Boolean); begin - if FAnchorTop = Value then Exit; + if FAnchorTop = Value then + Exit; FAnchorTop := Value; if Value then - Anchors := Anchors + [ akTop ] + Anchors := Anchors + [akTop] else - Anchors := Anchors - [ akTop ]; + Anchors := Anchors - [akTop]; Change; end; -function TKOLCustomControl.SetupParams( const AName, AParent: TDelphiString ): TDelphiString; +function TKOLCustomControl.SetupParams(const AName, AParent: TDelphiString): TDelphiString; begin asm jmp @@e_signature @@ -8219,7 +7586,7 @@ begin Result := AParent; end; -procedure TKOLCustomControl.SetupTabStop(SL: TStringList; const AName: String); +procedure TKOLCustomControl.SetupTabStop(SL: TStringList; const AName: string); {var K, C: TComponent; I, N: Integer; kC: TKOLCustomControl;} @@ -8232,7 +7599,6 @@ procedure TKOLCustomControl.SetupTabStop(SL: TStringList; const AName: String); порядок генерации конструкторов для визуальных объектов, при котором TabOrder получается такой, какой нужно. } -var KF: TKOLForm; begin asm jmp @@e_signature @@ -8240,34 +7606,22 @@ begin DB 'TKOLCustomControl.SetupTabStop', 0 @@e_signature: end; - Log( '->TKOLCustomControl.SetupTabStop' ); - - KF := ParentKOLForm; + Log('->TKOLCustomControl.SetupTabStop'); try - if not TabStop and TabStopByDefault then - begin - if FResetTabStopByStyle then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormResetStyles', '' ); - KF.FormAddNumParameter( WS_TABSTOP ); - end else - SL.Add( ' ' + AName + '.Style := ' + AName + '.Style and not WS_TABSTOP;' ) - else - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Name, 'FormSetTabStopFalse', '' ); - end else - SL.Add( ' ' + AName + '.TabStop := FALSE;' ); - end; - LogOK; + if not TabStop and TabStopByDefault then begin + if FResetTabStopByStyle then + SL.Add(' ' + AName + '.Style := ' + AName + '.Style and not WS_TABSTOP;') + else + SL.Add(' ' + AName + '.TabStop := FALSE;'); + end; + LogOK; finally - Log( '<-TKOLCustomControl.SetupTabStop' ); + Log('<-TKOLCustomControl.SetupTabStop'); end; end; -procedure TKOLCustomControl.SetupTextAlign(SL: TStrings; const AName: String); +procedure TKOLCustomControl.SetupTextAlign(SL: TStrings; const AName: string); begin asm jmp @@e_signature @@ -8286,16 +7640,18 @@ begin DB 'TKOLCustomControl.SetVerticalAlign', 0 @@e_signature: end; - if FVerticalAlign = Value then Exit; + if FVerticalAlign = Value then + Exit; FVerticalAlign := Value; Invalidate; Change; end; procedure TKOLCustomControl.Set_Color(const Value: TColor); -var KF: TKOLForm; - KC: TKOLCustomControl; - C: TComponent; +var + KF: TKOLForm; + KC: TKOLCustomControl; + c: TComponent; begin asm jmp @@e_signature @@ -8303,67 +7659,61 @@ begin DB 'TKOLCustomControl.Set_Color', 0 @@e_signature: end; - Log( '->TKOLCustomControl.Set_Color' ); + Log('->TKOLCustomControl.Set_Color'); try - if not CanChangeColor and (Value <> DefaultColor) or (inherited Color = Value) then - begin - //ShowMessage( 'This control can not change Color value.' ); - LogOK; - Exit; - end; - if not (csLoading in ComponentState) then - begin - C := ParentKOLControl; - if C <> nil then - if C is TKOLForm then - begin - KF := C as TKOLForm; - if Value <> KF.Color then - parentColor := FALSE; - end - else - if C is TKOLCustomControl then - begin - KC := C as TKOLCustomControl; - if Value <> KC.Color then - parentColor := FALSE; + if not CanChangeColor and (Value <> DefaultColor) or (inherited Color = Value) then begin + //ShowMessage( 'This control can not change Color value.' ); + LogOK; + Exit; end; - end; - CollectChildrenWithParentColor; - if Brush <> nil then - Brush.Color := Value; - TRY - Log( 'inherited Color := Value' ); - inherited Color := Value; - EXCEPT - Log( 'failed !!! inherited Color := Value' ); - END; -{YS} - {$IFDEF _KOLCtrlWrapper_} - if Assigned(FKOLCtrl) then - begin - Log( 'FKOLCtrl.Color := Value' ); - TRY - FKOLCtrl.Color := Value; - EXCEPT - Log( 'exception!!! FKOLCtrl = ' + IntToHex( Integer( FKOLCtrl ), 6 ) ); - END; - end; - {$ENDIF} -{YS} - Log( 'Invalidate' ); - Invalidate; - Log( 'ApplyColorToChildren' ); - ApplyColorToChildren; - Log( 'Change' ); - Change; - //if csLoading in ComponentState then - // FParentColor := DetectParentColor; + if not (csLoading in ComponentState) then begin + c := ParentKOLControl; + if c <> nil then + if c is TKOLForm then begin + KF := c as TKOLForm; + if Value <> KF.Color then + parentColor := False; + end + else if c is TKOLCustomControl then begin + KC := c as TKOLCustomControl; + if Value <> KC.Color then + parentColor := False; + end; + end; + CollectChildrenWithParentColor; + if Brush <> nil then + Brush.Color := Value; + try + Log('inherited Color := Value'); + inherited Color := Value; + except + Log('failed !!! inherited Color := Value'); + end; + {YS} +{$IFDEF _KOLCtrlWrapper_} + if Assigned(FKOLCtrl) then begin + Log('FKOLCtrl.Color := Value'); + try + FKOLCtrl.Color := Value; + except + Log('exception!!! FKOLCtrl = ' + IntToHex(Integer(FKOLCtrl), 6)); + end; + end; +{$ENDIF} + {YS} + Log('Invalidate'); + Invalidate; + Log('ApplyColorToChildren'); + ApplyColorToChildren; + Log('Change'); + Change; + //if csLoading in ComponentState then + // FParentColor := DetectParentColor; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.Set_Color' ); + Log('<-TKOLCustomControl.Set_Color'); end; end; @@ -8375,21 +7725,19 @@ begin DB 'TKOLCustomControl.Set_Enabled', 0 @@e_signature: end; - Log( '->TKOLCustomControl.Set_Enabled' ); + Log('->TKOLCustomControl.Set_Enabled'); try - if inherited Enabled <> Value then - begin - if Faction = nil then - inherited Enabled := Value - else - inherited Enabled := Faction.Enabled; - Change; - //dufa - Invalidate; - end; - LogOK; + if inherited Enabled <> Value then begin + if Faction = nil then + inherited Enabled := Value + else + inherited Enabled := Faction.Enabled; + Change; + Invalidate; //dufa + end; + LogOK; finally - Log( '<-TKOLCustomControl.Set_Enabled' ); + Log('<-TKOLCustomControl.Set_Enabled'); end; end; @@ -8401,23 +7749,22 @@ begin DB 'TKOLCustomControl.Set_Visible', 0 @@e_signature: end; - Log( '->TKOLCustomControl.Set_Visible' ); + Log('->TKOLCustomControl.Set_Visible'); try - if inherited Visible <> Value then - begin - if Faction = nil then - inherited Visible := Value - else - inherited Visible := Faction.Visible; - Change; - end; - LogOK; + if inherited Visible <> Value then begin + if Faction = nil then + inherited Visible := Value + else + inherited Visible := Faction.Visible; + Change; + end; + LogOK; finally - Log( '<-TKOLCustomControl.Set_Visible' ); + Log('<-TKOLCustomControl.Set_Visible'); end; end; -function TKOLCustomControl.TypeName: String; +function TKOLCustomControl.TypeName: string; begin asm jmp @@e_signature @@ -8427,14 +7774,14 @@ begin end; //Log( '->TKOLCustomControl.TypeName' ); try - Result := ClassName; - if UpperCase( Copy( Result, 1, 4 ) ) = 'TKOL' then - Result := Copy( Result, 5, Length( Result ) - 4 ); - if not Windowed then - Result := 'Graph' + Result; - //LogOK; + Result := ClassName; + if UpperCase(Copy(Result, 1, 4)) = 'TKOL' then + Result := Copy(Result, 5, Length(Result) - 4); + if not Windowed then + Result := 'Graph' + Result; + //LogOK; finally - //Log( '<-TKOLCustomControl.TypeName' ); + //Log( '<-TKOLCustomControl.TypeName' ); end; end; @@ -8446,10 +7793,10 @@ begin DB 'TKOLCustomControl.TabStopByDefault', 0 @@e_signature: end; - Result := FALSE; + Result := False; end; -function TKOLCustomControl.FontPropName: String; +function TKOLCustomControl.FontPropName: string; begin asm jmp @@e_signature @@ -8460,7 +7807,7 @@ begin Result := 'Font'; end; -procedure TKOLCustomControl.AfterFontChange( SL: TStrings; const AName, Prefix: String ); +procedure TKOLCustomControl.AfterFontChange(SL: TStrings; const AName, Prefix: string); begin asm jmp @@e_signature @@ -8471,7 +7818,7 @@ begin // end; -procedure TKOLCustomControl.BeforeFontChange( SL: TStrings; const AName, Prefix: String ); +procedure TKOLCustomControl.BeforeFontChange(SL: TStrings; const AName, Prefix: string); begin asm jmp @@e_signature @@ -8483,8 +7830,9 @@ begin end; procedure TKOLCustomControl.SetHasBorder(const Value: Boolean); -var CodeAddr: procedure of object; - CodeAddr1: procedure( const V: Boolean ) of object; +var + CodeAddr: procedure of object; + CodeAddr1: procedure(const V: Boolean) of object; begin asm jmp @@e_signature @@ -8492,26 +7840,27 @@ begin DB 'TKOLCustomControl.SetHasBorder', 0 @@e_signature: end; - if FHasBorder = Value then Exit; - Log( '->TKOLCustomControl.SetHasBorder' ); + if FHasBorder = Value then + Exit; + Log('->TKOLCustomControl.SetHasBorder'); try - FHasBorder := Value; -{YS} - {$IFDEF _KOLCtrlWrapper_} - if Assigned(FKOLCtrl) then - FKOLCtrl.HasBorder:=Value; - {$ENDIF} -{YS} - //Log( 'SetHasBorder - Change, Self=$' + Int2Hex( DWORD( Self ), 6 ) ); - CodeAddr := Change; - //Log( 'SetHasBorder - Change Addr: $' + Int2Hex( DWORD( TMethod( CodeAddr ).Code ), 6 ) ); - CodeAddr1 := SetHasBorder; - //Log( 'SetHasBorder = own Addr: $' + Int2Hex( DWORD( TMethod( CodeAddr1 ).code ), 6 ) ); - Change; - Invalidate; - LogOK; + FHasBorder := Value; + {YS} +{$IFDEF _KOLCtrlWrapper_} + if Assigned(FKOLCtrl) then + FKOLCtrl.HasBorder := Value; +{$ENDIF} + {YS} + //Log( 'SetHasBorder - Change, Self=$' + Int2Hex( DWORD( Self ), 6 ) ); + CodeAddr := Change; + //Log( 'SetHasBorder - Change Addr: $' + Int2Hex( DWORD( TMethod( CodeAddr ).Code ), 6 ) ); + CodeAddr1 := SetHasBorder; + //Log( 'SetHasBorder = own Addr: $' + Int2Hex( DWORD( TMethod( CodeAddr1 ).code ), 6 ) ); + Change; + Invalidate; + LogOK; finally - Log( '<-TKOLCustomControl.SetHasBorder' ); + Log('<-TKOLCustomControl.SetHasBorder'); end; end; @@ -8523,7 +7872,8 @@ begin DB 'TKOLCustomControl.SetOnScroll', 0 @@e_signature: end; - if @ FOnScroll = @ Value then Exit; + if @FOnScroll = @Value then + Exit; FOnScroll := Value; Change; end; @@ -8536,13 +7886,14 @@ begin DB 'TKOLCustomControl.SetEditTabChar', 0 @@e_signature: end; - if FEditTabChar = Value then Exit; + if FEditTabChar = Value then + Exit; FEditTabChar := Value; - WantTabs( Value ); + WantTabs(Value); Change; end; -procedure TKOLCustomControl.WantTabs( Want: Boolean ); +procedure TKOLCustomControl.WantTabs(Want: Boolean); begin asm jmp @@e_signature @@ -8560,7 +7911,7 @@ begin DB 'TKOLCustomControl.CanNotChangeFontColor', 0 @@e_signature: end; - Result := FALSE; + Result := False; end; function TKOLCustomControl.DefaultColor: TColor; @@ -8604,7 +7955,7 @@ begin DB 'TKOLCustomControl.DefaultKOLParentColor', 0 @@e_signature: end; - Result := TRUE; + Result := True; end; function TKOLCustomControl.CanChangeColor: Boolean; @@ -8615,7 +7966,7 @@ begin DB 'TKOLCustomControl.CanChangeColor', 0 @@e_signature: end; - Result := TRUE; + Result := True; end; function TKOLCustomControl.PaintType: TPaintType; @@ -8626,14 +7977,14 @@ begin DB 'TKOLCustomControl.PaintType', 0 @@e_signature: end; - Log( '->TKOLCustomControl.PaintType' ); + Log('->TKOLCustomControl.PaintType'); try - Result := ptWYSIWIG; - if ParentKOLForm <> nil then - Result := ParentKOLForm.PaintType; - LogOK; + Result := ptWYSIWIG; + if ParentKOLForm <> nil then + Result := ParentKOLForm.PaintType; + LogOK; finally - Log( '<-TKOLCustomControl.PaintType' ); + Log('<-TKOLCustomControl.PaintType'); end; end; @@ -8645,10 +7996,10 @@ begin DB 'TKOLCustomControl.WYSIWIGPaintImplemented', 0 @@e_signature: end; - Result := FALSE; + Result := False; end; -function TKOLCustomControl.CompareFirst(c, n: string): boolean; +function TKOLCustomControl.CompareFirst(c, N: string): Boolean; begin asm jmp @@e_signature @@ -8656,10 +8007,10 @@ begin DB 'TKOLCustomControl.CompareFirst', 0 @@e_signature: end; - Result := FALSE; + Result := False; end; -procedure TKOLCustomControl.PrepareCanvasFontForWYSIWIGPaint( ACanvas: TCanvas ); +procedure TKOLCustomControl.PrepareCanvasFontForWYSIWIGPaint(ACanvas: TCanvas); //var RFont: TKOLFont; begin asm @@ -8668,37 +8019,37 @@ begin DB 'TKOLCustomControl.PrepareCanvasFontForWYSIWIGPaint', 0 @@e_signature: end; - Log( '->TKOLCustomControl.PrepareCanvasFontForWYSIWIGPaint ' + Name ); + Log('->TKOLCustomControl.PrepareCanvasFontForWYSIWIGPaint ' + name); try - TRY - //Rpt( 'Call RunTimeFont', WHITE ); //Rpt_Stack; - if not Font.Equal2(nil) then begin - //Rpt( 'Font different ! Color=' + Int2Hex( Color2RGB( Font.Color ), 8 ), - // WHITE ); - ACanvas.Font.Name:= Font.FontName; - ACanvas.Font.Height:= Font.FontHeight; - //ACanvas.Font.Color:= Font.Color; - ACanvas.Font.Style:= TFontStyles( Font.FontStyle ); - ACanvas.Font.Charset:= Font.FontCharset; - ACanvas.Font.Pitch:= Font.FontPitch; - end else - ACanvas.Font.Handle:=GetDefaultControlFont; + try + //Rpt( 'Call RunTimeFont', WHITE ); //Rpt_Stack; + if not Font.Equal2(nil) then begin + //Rpt( 'Font different ! Color=' + Int2Hex( Color2RGB( Font.Color ), 8 ), + // WHITE ); + ACanvas.Font.name := Font.FontName; + ACanvas.Font.Height := Font.FontHeight; + //ACanvas.Font.Color:= Font.Color; + ACanvas.Font.Style := TFontStyles(Font.FontStyle); + ACanvas.Font.Charset := Font.FontCharset; + ACanvas.Font.Pitch := Font.FontPitch; + end + else + ACanvas.Font.Handle := GetDefaultControlFont; - ACanvas.Font.Color:= Font.Color; // !!!!!! - ACanvas.Brush.Color := Color; + ACanvas.Font.Color := Font.Color; // !!!!!! + ACanvas.Brush.Color := Color; + + except + on E: Exception do begin + Showmessage('Can not prepare WYSIWIG font, exception: ' + E.Message); + end; - EXCEPT - on E: Exception do - begin - ShowMessage( 'Can not prepare WYSIWIG font, exception: ' + E.Message ); end; - END; - - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.PrepareCanvasFontForWYSIWIGPaint' ); + Log('<-TKOLCustomControl.PrepareCanvasFontForWYSIWIGPaint'); end; end; @@ -8710,12 +8061,13 @@ begin DB 'TKOLCustomControl.NoDrawFrame', 0 @@e_signature: end; - Result := FALSE; + Result := False; end; -procedure TKOLCustomControl.ReAlign( ParentOnly: Boolean ); -var ParentK: TComponent; - ParentF: TKOLForm; +procedure TKOLCustomControl.ReAlign(ParentOnly: Boolean); +var + ParentK: TComponent; + ParentF: TKOLForm; begin asm jmp @@e_signature @@ -8723,32 +8075,29 @@ begin DB 'TKOLCustomControl.ReAlign', 0 @@e_signature: end; - Log( '->TKOLCustomControl.ReAlign' ); + Log('->TKOLCustomControl.ReAlign'); try - if not (csLoading in ComponentState) then - begin - ParentF := ParentKOLForm; - ParentK := ParentKOLControl; - if (ParentK <> nil) and (ParentF <> nil) then - begin - if ParentK is TKOLForm then - (ParentK as TKOLForm).AlignChildren( nil, FALSE ) + if not (csLoading in ComponentState) then begin + ParentF := ParentKOLForm; + ParentK := ParentKOLControl; + if (ParentK <> nil) and (ParentF <> nil) then begin + if ParentK is TKOLForm then + (ParentK as TKOLForm).AlignChildren(nil, False) + else if ParentK is TKOLCustomControl then + if ParentF <> nil then + ParentF.AlignChildren(ParentK as TKOLCustomControl, False); + if not ParentOnly then + ParentF.AlignChildren(Self, False); + end else - if ParentK is TKOLCustomControl then - if ParentF <> nil then - ParentF.AlignChildren( ParentK as TKOLCustomControl, FALSE ); - if not ParentOnly then - ParentF.AlignChildren( Self, FALSE ); - end - else - //Rpt( 'TKOLCustomControl.ReAlign -- did nothing' ) - ; - end; + //Rpt( 'TKOLCustomControl.ReAlign -- did nothing' ) + ; + end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.ReAlign' ); + Log('<-TKOLCustomControl.ReAlign'); end; end; @@ -8761,15 +8110,15 @@ begin DB 'TKOLCustomControl.NotifyLinkedComponent', 0 @@e_signature: end; - Log( '->TKOLCustomControl.NotifyLinkedComponent' ); + Log('->TKOLCustomControl.NotifyLinkedComponent'); try - if Operation = noRemoved then - if Assigned( fNotifyList ) then - fNotifyList.Remove( Sender ); - Invalidate; - LogOK; + if Operation = noRemoved then + if Assigned(fNotifyList) then + fNotifyList.Remove(Sender); + Invalidate; + LogOK; finally - Log( '<-TKOLCustomControl.NotifyLinkedComponent' ); + Log('<-TKOLCustomControl.NotifyLinkedComponent'); end; end; @@ -8781,57 +8130,61 @@ begin DB 'TKOLCustomControl.AddToNotifyList', 0 @@e_signature: end; - Log( '->TKOLCustomControl.AddToNotifyList' ); + Log('->TKOLCustomControl.AddToNotifyList'); try - if Assigned( fNotifyList ) then - if fNotifyList.IndexOf( Sender ) < 0 then - fNotifyList.Add( Sender ); - LogOK; + if Assigned(fNotifyList) then + if fNotifyList.IndexOf(Sender) < 0 then + fNotifyList.Add(Sender); + LogOK; finally - Log( '<-TKOLCustomControl.AddToNotifyList' ); + Log('<-TKOLCustomControl.AddToNotifyList'); end; end; procedure TKOLCustomControl.SetMaxHeight(const Value: Integer); begin - if FMaxHeight = Value then Exit; + if FMaxHeight = Value then + Exit; FMaxHeight := Value; Change; end; procedure TKOLCustomControl.SetMaxWidth(const Value: Integer); begin - if FMaxWidth = Value then Exit; + if FMaxWidth = Value then + Exit; FMaxWidth := Value; Change; end; procedure TKOLCustomControl.SetMinHeight(const Value: Integer); begin - if FMinHeight = Value then Exit; + if FMinHeight = Value then + Exit; FMinHeight := Value; Change; end; procedure TKOLCustomControl.SetMinWidth(const Value: Integer); begin - if FMinWidth = Value then Exit; + if FMinWidth = Value then + Exit; FMinWidth := Value; Change; end; procedure TKOLCustomControl.Loaded; begin - Log( '->TKOLCustomControl.Loaded' ); + Log('->TKOLCustomControl.Loaded'); try - inherited; - CollectChildrenWithParentFont; - Font.Change; - if AutoSize then - AutoSizeNow; - LogOK; + inherited; + CollectChildrenWithParentFont; + Font.Change; + if autoSize then + AutoSizeNow; + LogOK; finally - Log( '<-TKOLCustomControl.Loaded' ); + Log('<-TKOLCustomControl.Loaded'); end; end; @@ -8842,83 +8195,59 @@ end; function TKOLCustomControl.AutoSizeRunTime: Boolean; begin - Result := TRUE; + Result := True; end; procedure TKOLCustomControl.SetLocalizy(const Value: TLocalizyOptions); begin - if FLocalizy = Value then Exit; + if FLocalizy = Value then + Exit; FLocalizy := Value; Change; end; -function TKOLCustomControl.StringConstant( const Propname, Value: TDelphiString ): TDelphiString; +function TKOLCustomControl.StringConstant(const Propname, Value: TDelphiString): TDelphiString; begin - Log( '->TKOLCustomControl.StringConstant' ); + Log('->TKOLCustomControl.StringConstant'); try - if (Value <> '') AND - ((Localizy = loForm) and (ParentKOLForm <> nil) and - (ParentKOLForm.Localizy) or (Localizy = loYes)) then - begin - Result := ParentKOLForm.Name + '_' + Name + '_' + Propname; - ParentKOLForm.MakeResourceString( Result, Value ); - end - else - begin - Result := String2Pascal( Value, '+' ); - end; - LogOK; + if (Value <> '') and + ((Localizy = loForm) and (ParentKOLForm <> nil) and + (ParentKOLForm.Localizy) or (Localizy = loYes)) then begin + Result := ParentKOLForm.name + '_' + name + '_' + Propname; + ParentKOLForm.MakeResourceString(Result, Value); + end + else begin + Result := String2Pascal(Value, '+'); + end; + LogOK; finally - Log( '<-TKOLCustomControl.StringConstant' ); + Log('<-TKOLCustomControl.StringConstant'); end; end; function PCharStringConstant(Sender: TObject; const Propname, - Value: String): String; + Value: string): string; begin if Sender is TKOLCustomControl then - Result := (Sender as TKOLCustomControl).StringConstant( Propname, Value ) - else - if Sender is TKOLObj then - Result := (Sender as TKOLObj).StringConstant( Propname, Value ) - else - if Sender is TKOLForm then - Result := (Sender as TKOLForm).StringConstant( PropName, Value ) - else - begin + Result := (Sender as TKOLCustomControl).StringConstant(Propname, Value) + else if Sender is TKOLObj then + Result := (Sender as TKOLObj).StringConstant(Propname, Value) + else if Sender is TKOLForm then + Result := (Sender as TKOLForm).StringConstant(Propname, Value) + else begin Result := 'error'; Exit; end; if Result <> '' then - if Result[ 1 ] <> '''' then + if Result[1] <> '''' then Result := 'PKOLChar( ' + Result + ' )'; end; -function P_PCharStringConstant( Sender: TObject; const Propname, Value: String ): String; -begin - if Sender is TKOLCustomControl then - Result := (Sender as TKOLCustomControl).P_StringConstant( Propname, Value ) - else - if Sender is TKOLObj then - Result := (Sender as TKOLObj).P_StringConstant( Propname, Value ) - else - if Sender is TKOLForm then - Result := (Sender as TKOLForm).P_StringConstant( PropName, Value ) - else - begin - Result := 'error'; - Exit; - end; - {if Result <> '' then - if not (Result[ 1 ] in ['''']) then - Result := 'PChar( ' + Result + ' )';} -end; - procedure TKOLCustomControl.SetHelpContext(const Value: Integer); begin - if Faction = nil then - begin - if FHelpContext1 = Value then Exit; + if Faction = nil then begin + if FHelpContext1 = Value then + Exit; FHelpContext1 := Value; end else @@ -8927,127 +8256,123 @@ begin end; procedure TKOLCustomControl.SetCancelBtn(const Value: Boolean); -var F: TKOLForm; +var + F: TKOLForm; begin - Log( '->TKOLCustomControl.SetCancelBtn' ); + Log('->TKOLCustomControl.SetCancelBtn'); try - if FCancelBtn <> Value then - begin - FCancelBtn := Value; - if Value then - begin - //DefaultBtn := FALSE; - F := ParentKOLForm; - if F <> nil then - begin - if (F.fCancelBtnCtl <> nil) and (F.fCancelBtnCtl <> Self) then - F.fCancelBtnCtl.CancelBtn := FALSE; - F.fCancelBtnCtl := Self; + if FCancelBtn <> Value then begin + FCancelBtn := Value; + if Value then begin + //DefaultBtn := FALSE; + F := ParentKOLForm; + if F <> nil then begin + if (F.fCancelBtnCtl <> nil) and (F.fCancelBtnCtl <> Self) then + F.fCancelBtnCtl.CancelBtn := False; + F.fCancelBtnCtl := Self; + end; end; + Change; end; - Change; - end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.SetCancelBtn' ); + Log('<-TKOLCustomControl.SetCancelBtn'); end; end; procedure TKOLCustomControl.SetDefaultBtn(const Value: Boolean); -var F: TKOLForm; +var + F: TKOLForm; begin - Log( '->TKOLCustomControl.SetDefaultBtn' ); + Log('->TKOLCustomControl.SetDefaultBtn'); try - if FDefaultBtn <> Value then - begin - FDefaultBtn := Value; - if Value then - begin - //CancelBtn := FALSE; - F := ParentKOLForm; - if F <> nil then - begin - if (F.fDefaultBtnCtl <> nil) and (F.FDefaultBtnCtl <> Self) then - F.fDefaultBtnCtl.DefaultBtn := FALSE; - F.fDefaultBtnCtl := Self; + if FDefaultBtn <> Value then begin + FDefaultBtn := Value; + if Value then begin + //CancelBtn := FALSE; + F := ParentKOLForm; + if F <> nil then begin + if (F.fDefaultBtnCtl <> nil) and (F.fDefaultBtnCtl <> Self) then + F.fDefaultBtnCtl.DefaultBtn := False; + F.fDefaultBtnCtl := Self; + end; end; + if Assigned(FKOLCtrl) then + with FKOLCtrl^ do + if FDefaultBtn then + Style := Style or BS_DEFPUSHBUTTON + else + Style := Style and not BS_DEFPUSHBUTTON; + Change; end; - if Assigned(FKOLCtrl) then - with FKOLCtrl^ do - if FDefaultBtn then - Style := Style or BS_DEFPUSHBUTTON - else - Style := Style and not BS_DEFPUSHBUTTON; - Change; - end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.SetDefaultBtn' ); + Log('<-TKOLCustomControl.SetDefaultBtn'); end; end; -function TKOLCustomControl.Generate_SetSize: String; -const BoolVals: array[ Boolean ] of String = ( 'FALSE', 'TRUE' ); -var W, H: Integer; - SizeWasSet: Boolean; +function TKOLCustomControl.Generate_SetSize: string; +const + BoolVals: array[Boolean] of string = ('FALSE', 'TRUE'); +var + W, H: Integer; + SizeWasSet: Boolean; begin - Log( '->TKOLCustomControl.Generate_SetSize' ); + Log('->TKOLCustomControl.Generate_SetSize'); try - SizeWasSet := FALSE; - W := 0; - H := 0; - if Align <> caClient then - if (Width <> DefaultWidth) or (Height <> DefaultHeight) or not Windowed then - begin - if ((Width <> DefaultWidth) or not Windowed) and not (Align in [ caTop, caBottom ]) then - W := Width; - if ((Height <> DefaultHeight) or not Windowed) and not (Align in [ caLeft, caRight ]) then - H := Height; - end; + SizeWasSet := False; + W := 0; + H := 0; + if Align <> caClient then + if (Width <> DefaultWidth) or (Height <> DefaultHeight) or not Windowed then begin + if ((Width <> DefaultWidth) or not Windowed) and not (Align in [caTop, caBottom]) then + W := Width; + if ((Height <> DefaultHeight) or not Windowed) and not (Align in [caLeft, caRight]) then + H := Height; + end; - if IsGenerateSize or not Windowed then - if not (autoSize and AutoSizeRunTime) or WordWrap or fNoAutoSizeX then - begin - if autoSize and AutoSizeRunTime then - H := 0; - if (W <> 0) or (H <> 0) then - begin - Result := Result + '.SetSize( ' + IntToStr( W ) + ', ' + IntToStr( H ) + ' )'; - SizeWasSet := TRUE; - end; - end; - if WordWrap then - Result := Result + '.MakeWordWrap'; - if (AutoSize and AutoSizeRunTime) xor DefaultAutoSize then - Result := Result + '.AutoSize( ' + BoolVals[ AutoSize ] + ' )'; + if IsGenerateSize or not Windowed then + if not (autoSize and AutoSizeRunTime) or WordWrap or fNoAutoSizeX then begin + if autoSize and AutoSizeRunTime then + H := 0; + if (W <> 0) or (H <> 0) then begin + Result := Result + '.SetSize( ' + IntToStr(W) + ', ' + IntToStr(H) + ' )'; + SizeWasSet := True; + end; + end; + if WordWrap then + Result := Result + '.MakeWordWrap'; + if (autoSize and AutoSizeRunTime) xor DefaultAutoSize then + Result := Result + '.AutoSize( ' + BoolVals[autoSize] + ' )'; - if not SizeWasSet then - //Result := Result + '{Generate_SetSize W' + IntToStr(W) + 'H' + IntToStr(H) + '} ' - ; + if not SizeWasSet then + //Result := Result + '{Generate_SetSize W' + IntToStr(W) + 'H' + IntToStr(H) + '} ' + ; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.Generate_SetSize' ); + Log('<-TKOLCustomControl.Generate_SetSize'); end; end; procedure TKOLCustomControl.SetIgnoreDefault(const Value: Boolean); begin - if FIgnoreDefault = Value then Exit; + if FIgnoreDefault = Value then + Exit; FIgnoreDefault := Value; Change; end; procedure TKOLCustomControl.SetBrush(const Value: TKOLBrush); begin - FBrush.Assign( Value ); + fBrush.Assign(Value); Change; end; function TKOLCustomControl.BorderNeeded: Boolean; begin - Result := FALSE; + Result := False; end; procedure TKOLCustomControl.SetIsGenerateSize(const Value: Boolean); @@ -9058,12 +8383,13 @@ end; procedure TKOLCustomControl.SetIsGeneratePosition(const Value: Boolean); begin - if FIsGeneratePosition = Value then Exit; + if FIsGeneratePosition = Value then + Exit; FIsGeneratePosition := Value; Change; end; -function TKOLCustomControl.BestEventName: String; +function TKOLCustomControl.BestEventName: string; begin Result := 'OnClick'; end; @@ -9071,31 +8397,31 @@ end; procedure TKOLCustomControl.KOLControlRecreated; begin {$IFNDEF NOT_USE_KOLCTRLWRAPPER} - Log( '->TKOLCustomControl.KOLControlRecreated' ); + Log('->TKOLCustomControl.KOLControlRecreated'); try - if Assigned(FKOLCtrl) then begin - FKOLCtrl.Color:=Color; - FKOLCtrl.Caption:=Caption; - Font.Change; - Brush.Change; - end; - LogOK; + if Assigned(FKOLCtrl) then begin + FKOLCtrl.Color := Color; + FKOLCtrl.Caption := Caption; + Font.Change; + Brush.Change; + end; + LogOK; finally - Log( '<-TKOLCustomControl.KOLControlRecreated' ); + Log('<-TKOLCustomControl.KOLControlRecreated'); end; {$ENDIF NOT_USE_KOLCTRLWRAPPER} end; function TKOLCustomControl.GetDefaultControlFont: HFONT; begin - Result:=GetStockObject(SYSTEM_FONT); + Result := GetStockObject(SYSTEM_FONT); end; -procedure TKOLCustomControl.SetHint(const Value: String); +procedure TKOLCustomControl.SetHint(const Value: string); begin - if Faction = nil then - begin - if FHint = Value then exit; + if Faction = nil then begin + if FHint = Value then + Exit; FHint := Value; end else @@ -9104,8 +8430,9 @@ begin end; function TKOLCustomControl.OwnerKOLForm(AOwner: TComponent): TKOLForm; -var C, D: TComponent; - I: Integer; +var + c, D: TComponent; + I: Integer; begin asm jmp @@e_signature @@ -9113,101 +8440,96 @@ begin DB 'TKOLCustomControl.OwnerKOLForm', 0 @@e_signature: end; - Log( '->TKOLCustomControl.OwnerKOLForm' ); + Log('->TKOLCustomControl.OwnerKOLForm'); try - //Rpt( 'Where from TKOLCustomControl.OwnerKOLForm called?' ); - //Rpt_Stack; + //Rpt( 'Where from TKOLCustomControl.OwnerKOLForm called?' ); + //Rpt_Stack; - C := AOwner; - Log( '*1 TKOLCustomControl.OwnerKOLForm' ); - while (C <> nil) and not(C is TForm) do - C := C.Owner; - Log( '*2 TKOLCustomControl.OwnerKOLForm' ); - Result := nil; - if C <> nil then - if C is TForm then - begin - Log( '*3 TKOLCustomControl.OwnerKOLForm' ); - for I := 0 to (C as TForm).ComponentCount - 1 do - begin - D := (C as TForm).Components[ I ]; - if D is TKOLForm then - begin - Result := D as TKOLForm; - break; + c := AOwner; + Log('*1 TKOLCustomControl.OwnerKOLForm'); + while (c <> nil) and not (c is TForm) do + c := c.Owner; + Log('*2 TKOLCustomControl.OwnerKOLForm'); + Result := nil; + if c <> nil then + if c is TForm then begin + Log('*3 TKOLCustomControl.OwnerKOLForm'); + for I := 0 to (c as TForm).ComponentCount - 1 do begin + D := (c as TForm).Components[I]; + if D is TKOLForm then begin + Result := D as TKOLForm; + Break; + end; + end; + Log('*4 TKOLCustomControl.OwnerKOLForm'); end; - end; - Log( '*4 TKOLCustomControl.OwnerKOLForm' ); - end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.OwnerKOLForm' ); + Log('<-TKOLCustomControl.OwnerKOLForm'); end; end; procedure TKOLCustomControl.DoNotifyLinkedComponents( Operation: TNotifyOperation); -var I: Integer; - C: TComponent; +var + I: Integer; + c: TComponent; begin - Log( '->TKOLCustomControl.DoNotifyLinkedComponents' ); + Log('->TKOLCustomControl.DoNotifyLinkedComponents'); try - if Assigned( fNotifyList ) then - for I := fNotifyList.Count-1 downto 0 do - begin - C := fNotifyList[ I ]; - if C is TKOLObj then - (C as TKOLObj).NotifyLinkedComponent( Self, Operation ) - else - if C is TKOLCustomControl then - (C as TKOLCustomControl).NotifyLinkedComponent( Self, Operation ); - end; + if Assigned(fNotifyList) then + for I := fNotifyList.Count - 1 downto 0 do begin + c := fNotifyList[I]; + if c is TKOLObj then + (c as TKOLObj).NotifyLinkedComponent(Self, Operation) + else if c is TKOLCustomControl then + (c as TKOLCustomControl).NotifyLinkedComponent(Self, Operation); + end; - LogOK; + LogOK; finally - Log( '<-TKOLCustomControl.DoNotifyLinkedComponents' ); + Log('<-TKOLCustomControl.DoNotifyLinkedComponents'); end; end; function TKOLCustomControl.Get_ParentFont: TKOLFont; begin - Log( '->TKOLCustomControl.Get_ParentFont' ); + Log('->TKOLCustomControl.Get_ParentFont'); try - if (ParentKOLControl <> nil) then - begin - if ParentKOLControl = ParentKOLForm then - Result := ParentKOLForm.Font + if (ParentKOLControl <> nil) then begin + if ParentKOLControl = ParentKOLForm then + Result := ParentKOLForm.Font + else + Result := (ParentKOLControl as TKOLCustomControl).Font; + end else - Result := (ParentKOLControl as TKOLCustomControl).Font; - end - else - Result := nil; - LogOK; + Result := nil; + LogOK; finally - Log( '<-TKOLCustomControl.Get_ParentFont' ); + Log('<-TKOLCustomControl.Get_ParentFont'); end; end; {$IFDEF NOT_USE_KOLCTRLWRAPPER} -procedure TKOLCustomControl.CreateKOLControl(Recreating: boolean); + +procedure TKOLCustomControl.CreateKOLControl(Recreating: Boolean); begin - Log( 'TKOLCustomControl.CreateKOLControl(' + IntToStr( Integer( Recreating ) ) + ')' ); + Log('TKOLCustomControl.CreateKOLControl(' + IntToStr(Integer(Recreating)) + ')'); end; procedure TKOLCustomControl.UpdateAllowSelfPaint; begin - Log( 'TKOLCustomControl.UpdateAllowSelfPaint' ); + Log('TKOLCustomControl.UpdateAllowSelfPaint'); end; {$ENDIF NOT_USE_KOLCTRLWRAPPER} procedure TKOLCustomControl.Setaction(const Value: TKOLAction); begin - Log( '->TKOLCustomControl.Setaction' ); + Log('->TKOLCustomControl.Setaction'); try - if Faction <> Value then - begin + if Faction <> Value then begin if Faction <> nil then Faction.UnLinkComponent(Self); Faction := Value; @@ -9217,7 +8539,7 @@ begin end; LogOK; finally - Log( '<-TKOLCustomControl.Setaction' ); + Log('<-TKOLCustomControl.Setaction'); end; end; @@ -9227,799 +8549,123 @@ begin try //Rpt( 'Where from TKOLCustomControl.Notification called:' ); //Rpt_Stack; - inherited; - if Operation = opRemove then - if AComponent = Faction then - begin - //Rpt( 'Faction.UnLinkComponent(Self);' ); - Faction.UnLinkComponent(Self); - Faction := nil; - //Rpt( 'eeeeeeeeeeeeeeeeeeeeeeeee' ); - end; - //LogOK; + inherited; + if Operation = opRemove then + if AComponent = Faction then begin + //Rpt( 'Faction.UnLinkComponent(Self);' ); + Faction.UnLinkComponent(Self); + Faction := nil; + //Rpt( 'eeeeeeeeeeeeeeeeeeeeeeeee' ); + end; + //LogOK; finally - //Log( '<-TKOLCustomControl.Notification' ); + //Log( '<-TKOLCustomControl.Notification' ); end; end; procedure TKOLCustomControl.SetWindowed(const Value: Boolean); begin - if FWindowed = Value then Exit; + if FWindowed = Value then + Exit; FWindowed := Value; Change; end; procedure TKOLCustomControl.SetWordWrap(const Value: Boolean); begin - if fWordWrap = Value then Exit; - fWordWrap := Value; + if FWordWrap = Value then + Exit; + FWordWrap := Value; Change; end; -function TKOLCustomControl.Pcode_Generate: Boolean; -begin - Result := FALSE; -end; - -procedure TKOLCustomControl.P_BeforeFontChange(SL: TStrings; const AName, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_BeforeFontChange', 0 - @@e_signature: - end; - // -end; - -procedure TKOLCustomControl.P_SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_SetupLast', 0 - @@e_signature: - end; - //Log( '->TKOLCustomControl.SetupLast' ); - try - //P_SetupColor( SL, AName, ControlInStack ); - if P_AssignEvents( SL, AName, TRUE ) then - begin - {P}SL.Add( ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + - Name ); - P_AssignEvents( SL, AName, FALSE ); - {P}SL.Add( ' DEL //' + Name ); - end; - if fDefaultBtn then - //SL.Add( Prefix + AName + '.DefaultBtn := TRUE;' ) - begin - {P}SL.Add( ' L(1) L(13) ' + - 'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name + - ' TControl_.SetDefaultBtn<3>' ); - end; - if fCancelBtn then - //SL.Add( Prefix + AName + '.CancelBtn := TRUE;' ); - begin - {P}SL.Add( ' L(1) L(27) ' + - 'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name + - ' TControl_.SetDefaultBtn<3>' ); - end; - - //LogOK; - finally - //Log( '<-TKOLCustomControl.SetupLast' ); - end; -end; - -procedure TKOLCustomControl.P_SetupColor(SL: TStrings; - const AName: String; var ControlInStack: Boolean); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_SetupColor', 0 - @@e_signature: - end; - if (Brush.Bitmap = nil) or Brush.Bitmap.Empty then - begin - if Brush.BrushStyle <> bsSolid then - begin - Brush.P_GenerateCode( SL, AName ); - end - else - begin - if DefaultKOLParentColor and not parentColor or - not DefaultKOLParentColor and (Color <> DefaultColor) then - //SL.Add( ' ' + AName + '.Color := ' + Color2Str( Color ) + ';' ); - begin - {P}SL.Add( ' L($' + Int2Hex( Color, 6 ) + ')' ); - {P}SL.Add( ' C1 TControl_.SetCtlColor<2>' ); - end; - end; - end - else - begin - Brush.P_GenerateCode( SL, AName ); - end; -end; - -function TKOLCustomControl.P_AssignEvents(SL: TStringList; - const AName: String; CheckOnly: Boolean): Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_AssignEvents', 0 - @@e_signature: - end; - Log( '->TKOLCustomControl.P_AssignEvents' ); - Result := TRUE; - try - if P_DoAssignEvents( SL, AName, - [ 'OnClick', 'OnMouseDblClk', 'OnMessage', 'OnMouseDown', 'OnMouseMove', 'OnMouseUp', 'OnMouseWheel', 'OnMouseEnter', 'OnMouseLeave' ], - [ @OnClick, @ OnMouseDblClk, @OnMessage, @OnMouseDown, @OnMouseMove, @OnMouseUp, @OnMouseWheel, @OnMouseEnter, @OnMouseLeave ], - [ FALSE, TRUE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ], - CheckOnly ) and CheckOnly then Exit; - if P_DoAssignEvents( SL, AName, - [ 'OnDestroy', 'OnEnter', 'OnLeave', 'OnKeyDown', 'OnKeyUp', 'OnKeyChar', 'OnKeyDeadChar' ], - [ @ OnDestroy, @OnEnter, @OnLeave, @OnKeyDown, @OnKeyUp, @OnKeyChar , @OnKeyDeadChar ], - [ FALSE, FALSE, FALSE, TRUE, TRUE, TRUE , TRUE ], - CheckOnly ) and CheckOnly then Exit; - if P_DoAssignEvents( SL, AName, - [ 'OnChange', 'OnSelChange', 'OnPaint', 'OnEraseBkgnd', 'OnResize', 'OnMove', 'OnMoving', 'OnBitBtnDraw', 'OnDropDown', 'OnCloseUp', 'OnProgress' ], - [ @OnChange, @OnSelChange, @OnPaint, @ OnEraseBkgnd, @OnResize, @ OnMove, @ OnMoving, @OnBitBtnDraw, @OnDropDown, @ OnCloseUp, @ OnProgress ], - [ FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE ], - CheckOnly ) and CheckOnly then Exit; - if P_DoAssignEvents( SL, AName, - [ 'OnDeleteAllLVItems', 'OnDeleteLVItem', 'OnLVData', 'OnCompareLVItems', 'OnColumnClick', 'OnLVStateChange', 'OnEndEditLVItem' ], - [ @ OnDeleteAllLVItems, @ OnDeleteLVItem, @ OnLVData, @ OnCompareLVItems, @ OnColumnClick, @ OnLVStateChange, @ OnEndEditLVItem ], - [ TRUE, TRUE, TRUE, FALSE, TRUE, TRUE ], - CheckOnly ) and CheckOnly then Exit; - if P_DoAssignEvents( SL, AName, - [ 'OnDrawItem', 'OnMeasureItem', 'OnTBDropDown|OnDropDown', 'OnDropFiles', 'OnShow', 'OnHide', 'OnSplit', 'OnScroll' ], - [ @ OnDrawItem, @ OnMeasureItem, @ OnTBDropDown, @ OnDropFiles, @ OnShow, @ OnHide, @ OnSplit, @ OnScroll ], - [ TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, FALSE, TRUE ], - CheckOnly ) and CheckOnly then Exit; - if P_DoAssignEvents( SL, AName, - [ 'OnRE_URLClick', 'OnRE_InsOvrMode_Change|fOnREInsModeChg', 'OnRE_OverURL' ], - [ @ OnRE_URLClick, @ OnRE_InsOvrMode_Change, @ OnRE_OverURL ], - [ TRUE, FALSE, TRUE ], - CheckOnly ) and CheckOnly then Exit; - if P_DoAssignEvents( SL, AName, - [ 'OnTVBeginDrag', 'OnTVBeginEdit', 'OnTVEndEdit', 'OnTVExpanded', 'OnTVExpanding', 'OnTVSelChanging', 'OnTVDelete' ], - [ @ OnTVBeginDrag, @ OnTVBeginEdit, @ OnTVEndEdit, @ OnTVExpanded, @ OnTVExpanding, @ OnTVSelChanging, @ OnTVDelete ], - [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE ], - CheckOnly ) and CheckOnly then Exit; - Result := FALSE; - LogOK; - finally - if Result and CheckOnly then LogOK; - Log( '<-TKOLCustomControl.AssignEvents' ); - end; -end; - -function TKOLCustomControl.P_DoAssignEvents(SL: TStringList; - const AName: String; const EventNames: array of PChar; - const EventHandlers: array of Pointer; - const EventAssignProc: array of Boolean; CheckOnly: Boolean): Boolean; -var I: Integer; - s, p: KOLString; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_DoAssignEvents', 0 - @@e_signature: - end; - Result := TRUE; - //Log( '->TKOLCustomControl.P_DoAssignEvents' ); - try - - for I := 0 to High( EventHandlers ) do - begin - if EventHandlers[ I ] <> nil then - begin - if CheckOnly then Exit; - p := EventNames[ I ]; - s := Trim( Parse( p, '|' ) ); - p := Trim( p ); - //SL.Add( ' ' + AName + '.' + EventNames[ I ] + ' := Result.' + - // ParentForm.MethodName( EventHandlers[ I ] ) + ';' ); - if EventAssignProc[ I ] then - begin - if p = '' then p := 'Set' + s - else p := s; - {P}SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' + - ParentForm.MethodName( EventHandlers[ I ] ) ); - {P}SL.Add( ' C2 TControl_.' + p + '<1>' - ); - end - else - begin - if p = '' then p := s; - {P}SL.Add( ' Load4 ####T' + ParentKOLForm.formName + '.' + - (Owner as TForm).MethodName( EventHandlers[ I ] ) ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.f' + p ); - {P}SL.Add( ' LoadSELF C1 AddWord_Store ##(4+TControl_.f' + p + ')' ); - end; - end; - end; - if CheckOnly then - Result := FALSE; - - //LogOK; - finally - //if CheckOnly and Result then LogOK; - //Log( '<-TKOLCustomControl.P_DoAssignEvents' ); - end; -end; - -procedure TKOLCustomControl.P_SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_SetupFirst', 0 - @@e_signature: - end; - Log( '->TKOLCustomControl.P_SetupFirst' ); - try - - P_SetupConstruct( SL, AName, AParent, Prefix ); - if Tag <> 0 then - begin - {if Tag < 0 then - SL.Add( Prefix + AName + '.Tag := DWORD(' + IntToStr(Tag) + ');' ) - else - SL.Add( Prefix + AName + '.Tag := ' + IntToStr(Tag) + ';' );} - {P}SL.Add( ' L(' + IntToStr( Tag ) + ')' ); - {P}SL.Add( ' C1 AddByte_Store #TObj_.fTag' ); - end; - if not Ctl3D then - //SL.Add( Prefix + AName + '.Ctl3D := False;' ); - begin - {P}SL.Add( ' L(0) C1 TControl_.SetCtl3D<2>' ); - end; - if FHasBorder <> FDefHasBorder then - begin - //SL.Add( Prefix + AName + '.HasBorder := ' + BoolVals[ FHasBorder ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( FHasBorder ) ) + ')' ); - {P}SL.Add( ' C1 TControl_.SetHasBorder<2>' ); - end; - P_SetupTabStop( SL, AName ); - P_SetupFont( SL, AName ); - P_SetupTextAlign( SL, AName ); - //SetupColor( SL, AName ); - if (csAcceptsControls in ControlStyle) or BorderNeeded then - if (ParentKOLControl = ParentKOLForm) and (ParentKOLForm.Border <> Border) - or (ParentKOLControl <> ParentKOLForm) and ((ParentKOLControl as TKOLCustomControl).Border <> Border) then - //SL.Add( Prefix + AName + '.Border := ' + IntToStr( Border ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( Border ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fMargin' ); - end; - if MarginTop <> DefaultMarginTop then - //SL.Add( Prefix + AName + '.MarginTop := ' + IntToStr( MarginTop ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MarginTop ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fClientTop' ); - end; - if MarginBottom <> DefaultMarginBottom then - //SL.Add( Prefix + AName + '.MarginBottom := ' + IntToStr( MarginBottom ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MarginBottom ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fClientBottom' ); - end; - if MarginLeft <> DefaultMarginLeft then - //SL.Add( Prefix + AName + '.MarginLeft := ' + IntToStr( MarginLeft ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MarginLeft ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fClientLeft' ); - end; - if MarginRight <> DefaultMarginRight then - //SL.Add( Prefix + AName + '.MarginRight := ' + IntToStr( MarginRight ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MarginRight ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fClientRight' ); - end; - if not IsCursorDefault then - if Copy( Cursor_, 1, 4 ) = 'IDC_' then - //SL.Add( Prefix + AName + '.Cursor := LoadCursor( 0, ' + Cursor_ + ' );' ) - begin - {P}SL.Add( ' L(' + IntToStr( IDC2Number( Cursor_ ) ) + ') //' + Cursor_ ); - {P}SL.Add( ' L(0) LoadCursor RESULT C1 TControl_.SetCursor<2>' ); - end - else - //SL.Add( Prefix + AName + '.Cursor := LoadCursor( hInstance, ''' + Trim( Cursor_ ) + ''' );' ); - begin - {P}SL.Add( ' LoadStr ' + P_String2Pascal( Cursor_ ) ); - {P}SL.Add( ' Load_hInstance LoadCursor RESULT C1 TControl_.SetCursor<2>' ); - end; - if not Visible and (Faction = nil) then - //SL.Add( Prefix + AName + '.Visible := False;' ); - begin - {P}SL.Add( ' L(0) C1 TControl_.SetVisible<2>' ); - end; - if not Enabled and (Faction = nil) then - //SL.Add( Prefix + AName + '.Enabled := False;' ); - begin - {P}SL.Add( ' L(0) C1 TControl_.SetEnabled<2>' ); - end; - if DoubleBuffered and not Transparent then - //SL.Add( Prefix + AName + '.DoubleBuffered := True;' ); - begin - {P}SL.Add( ' L(1) C1 TControl_.SetDoubleBuffered<2>' ); - end; - if Owner <> nil then - if Transparent and ((Owner is TKOLCustomControl) and not (Owner as TKOLCustomControl).Transparent or - not(Owner is TKOLCustomControl) and not ParentKOLForm.Transparent) then - //SL.Add( Prefix + AName + '.Transparent := True;' ); - begin - {P}SL.Add( ' L(1) C1 TControl_.SetTransparent<2>' ); - end; - if Owner = nil then - if Transparent then - //SL.Add( Prefix + AName + '.Transparent := TRUE;' ); - begin - {P}SL.Add( ' L(1) C1 TControl_.SetTransparent<2>' ); - end; - //AssignEvents( SL, AName ); - if EraseBackground then - //SL.Add( Prefix + AName + '.EraseBackground := TRUE;' ); - begin - {P}SL.Add( ' L(1) C1 AddWord_StoreB ##TControl_.fEraseUpdRgn' ); - end; - if MinWidth > 0 then - //SL.Add( Prefix + AName + '.MinWidth := ' + IntToStr( MinWidth ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MinWidth ) + ')' ); - {P}SL.Add( ' L(0) C2 TControl_.SetConstraint<3>' ); - end; - if MinHeight > 0 then - //SL.Add( Prefix + AName + '.MinHeight := ' + IntToStr( MinHeight ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MinHeight ) + ')' ); - {P}SL.Add( ' L(1) C2 TControl_.SetConstraint<3>' ); - end; - if MaxWidth > 0 then - //SL.Add( Prefix + AName + '.MaxWidth := ' + IntToStr( MaxWidth ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MaxWidth ) + ')' ); - {P}SL.Add( ' L(2) C2 TControl_.SetConstraint<3>' ); - end; - if MaxHeight > 0 then - //SL.Add( Prefix + AName + '.MaxHeight := ' + IntToStr( MaxHeight ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MaxHeight ) + ')' ); - {P}SL.Add( ' L(3) C2 TControl_.SetConstraint<3>' ); - end; - if IgnoreDefault <> FDefIgnoreDefault then - //SL.Add( Prefix + AName + '.IgnoreDefault := ' + BoolVals[ IgnoreDefault ] + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( Integer( IgnoreDefault ) ) + ')' ); - {P}SL.Add( ' C1 AddWord_StoreB ##TControl_.FIgnoreDefault' ); - end; - //Rpt( '-------- FHint = ' + FHint ); - if (Trim( FHint ) <> '') and (Faction = nil) then - begin - if (ParentKOLForm <> nil) and ParentKOLForm.ShowHint then - begin - SL.Add( Prefix + '{$IFDEF USE_MHTOOLTIP}' ); - SL.Add( Prefix + AName + '.Hint.Text := ' + StringConstant( 'Hint', Hint ) + ';' ); - SL.Add( Prefix + '{$ENDIF USE_MHTOOLTIP}' ); - end; - end; - P_SetupColor( SL, AName, ControlInStack ); - if Assigned( FpopupMenu ) then - //SL.Add( Prefix + AName + '.SetAutoPopupMenu( Result.' + FpopupMenu.Name + ' );' ); - begin - {P}SL.Add( ' LoadSELF AddWord_LoadRef ##T' + - ParentKOLForm.FormName + '.' + FpopupMenu.Name ); - {P}SL.Add( ' C1 TControl.SetAutoPopupMenu<2>' ); - end; - LogOK; - finally - Log( '<-TKOLCustomControl.P_SetupFirst' ); - end; -end; - -procedure TKOLCustomControl.P_SetupConstruct(SL: TStringList; const AName, - AParent, Prefix: String); -var S: String; - nparams: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_SetupConstruct', 0 - @@e_signature: - end; - Log( '->TKOLCustomControl.P_SetupConstruct' ); - try - S := P_GenerateTransparentInits; - //SL.Add( Prefix + AName + ' := New' + TypeName + '( ' - // + SetupParams( AName, AParent ) + ' )' + S + ';' ); - {P}SL.Add( P_SetupParams( AName, AParent, nparams ) ); - if nparams > 0 then - {P}SL.Add( ' New' + TypeName + '<' + IntToStr( Min( 3, nparams ) ) + '>' ) - else - {P}SL.Add( ' New' + TypeName ); - {P}SL.Add( ' RESULT' ); - if S <> '' then - SL.Add( S ); - {P}SL.Add( ' DUP LoadSELF AddWord_Store ##T' + ParentKOLForm.FormName + '.' + AName ); // SELF = form owner object - P_SetupName( SL ); - LogOK; - finally - Log( '<-TKOLCustomControl.P_SetupConstruct' ); - end; -end; - -procedure TKOLCustomControl.P_SetupTabStop(SL: TStringList; - const AName: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_SetupTabOrder', 0 - @@e_signature: - end; - Log( '->TKOLCustomControl.P_SetupTabOrder' ); - try - if not TabStop and TabStopByDefault then - begin - if FResetTabStopByStyle then - //SL.Add( ' ' + AName + '.Style := ' + AName + '.Style and not WS_TABSTOP;' ) - begin - {P}SL.Add( ' DUP AddWord_LoadRef ##TControl_.fStyle' ); - {P}SL.Add( ' L(' + IntToStr( WS_TABSTOP ) + ')' ); - {P}SL.Add( ' ~ & C1 TControl_.SetStyle<2>' ); - end - else - //SL.Add( ' ' + AName + '.TabStop := FALSE;' ); - begin - {P}SL.Add( ' L(0) C1 AddWord_Store ##TControl_.fTabStop' ); - end; - end; - LogOK; - finally - Log( '<-TKOLCustomControl.P_SetupTabOrder' ); - end; -end; - -procedure TKOLCustomControl.P_SetupFont(SL: TStrings; const AName: String); -var PFont: TKOLFont; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_SetupFont', 0 - @@e_signature: - end; - Log( '->TKOLCustomControl.P_SetupFont' ); - try - PFont := Get_ParentFont; - if (PFont <> nil) and (not Assigned(Font) or not Font.Equal2( PFont )) then - Font.P_GenerateCode( SL, AName, PFont ); - LogOK; - finally - Log( '<-TKOLCustomControl.P_SetupFont' ); - end; -end; - -procedure TKOLCustomControl.P_SetupTextAlign(SL: TStrings; - const AName: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_SetupTextAlign', 0 - @@e_signature: - end; - // nothing here -end; - -function TKOLCustomControl.P_GenerateTransparentInits: String; -var KF: TKOLForm; - S, S1, S2: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_GenerateTransparentInits', 0 - @@e_signature: - end; - Log( '->TKOLCustomControl.P_GenerateTransparentInits' ); - try - - S := ''; // пока ничего не надо - if Align = caNone then - begin - if IsGenerateSize then - begin - if PlaceRight then - //S := '.PlaceRight' - {P}S := S + ' DUP TControl.PlaceRight<1>' - else - if PlaceDown then - //S := '.PlaceDown' - {P}S := S + ' DUP TControl.PlaceDown<1>' - else - if PlaceUnder then - //S := '.PlaceUnder' - {P}S := S + ' DUP TControl.PlaceUnder<1>' - else - if not CenterOnParent then - if (actualLeft <> ParentMargin) or (actualTop <> ParentMargin) then - begin - S1 := IntToStr( actualLeft ); - S2 := IntToStr( actualTop ); - //S := '.SetPosition( ' + S1 + ', ' + S2 + ' )'; - {P}S := S + ' L(' + S2 + ') L(' + S1 + ') C2 TControl.SetPosition<3>'; - end; - end; - end; - if Align <> caNone then - //S := S + '.SetAlign ( ' + AlignValues[ Align ] + ' )'; - {P}S := S + ' L(' + IntToStr( Integer( Align ) ) + ') C1 TControl_.SetAlign<2>'; - S := S + P_Generate_SetSize; - if CenterOnParent and (Align = caNone) then - //S := S + '.CenterOnParent'; - {P}S := S + ' DUP TControl.CenterOnParent<1>'; - KF := ParentKOLForm; - if KF <> nil then - if KF.zOrderChildren then - //S := S + '.BringToFront'; - {P}S := S + ' DUP TControl.BringToFront<1>'; - if EditTabChar then - //S := S + '.EditTabChar'; - {P}S := S + ' DUP TControl.EditTabChar<1>'; - if (HelpContext <> 0) and (Faction = nil) then - //S := S + '.AssignHelpContext( ' + IntToStr( HelpContext ) + ' )' ; - {P}S := S + ' L(' + IntToStr( HelpContext ) + ') C1 TControl.AssignHelpContext<2>'; - if (KF <> nil) and KF.Unicode then - //S := S + '.SetUnicode( TRUE )'; - {P}S := S + #13#10' IFNDEF(UNICODE_CTRLS)'#13#10' L(1) C1 TControl.SetUnicode<2>'+ - #13#10' ENDIF'; - if MouseTransparent then - //S := S + '.MouseTransparent'; - {P}S := S + #13#10' DUP TControl.MouseTransparent<1>'; - if LikeSpeedButton then - //S := S + '.LikeSpeedButton'; - {P}S := S + #13#10' DUP TControl.LikeSpeedButton<1>'; - Result := Trim( S ); - - LogOK; - finally - Log( '<-TKOLCustomControl.P_GenerateTransparentInits' ); - end; -end; - -function TKOLCustomControl.P_SetupParams(const AName, AParent: String; - var nparams: Integer): String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_SetupParams', 0 - @@e_signature: - end; - nparams := 1; - {P}Result := //AParent; - ' DUP'; -end; - -function TKOLCustomControl.P_Generate_SetSize: String; -var W, H: Integer; -begin - Log( '->TKOLCustomControl.P_Generate_SetSize' ); - try - - W := 0; - H := 0; - if Align <> caClient then - if (Width <> DefaultWidth) or (Height <> DefaultHeight) or not Windowed then - begin - if ((Width <> DefaultWidth) or not Windowed) and not (Align in [ caTop, caBottom ]) then - W := Width; - if ((Height <> DefaultHeight) or not Windowed) and not (Align in [ caLeft, caRight ]) then - H := Height; - end; - - if IsGenerateSize or not Windowed then - if not (autoSize and AutoSizeRunTime) or WordWrap or fNoAutoSizeX then - begin - if autoSize and AutoSizeRunTime then - H := 0; - if (W <> 0) or (H <> 0) then - //Result := Result + '.SetSize( ' + IntToStr( W ) + ', ' + IntToStr( H ) + ' )'; - begin - {P}Result := Result + ' L(' + IntToStr( H ) + ') L(' + IntToStr( W ) + ')'; - {P}Result := Result + ' C2 TControl.SetSize<3>'; - end; - end; - if WordWrap then - //Result := Result + '.MakeWordWrap'; - {P}Result := Result + ' DUP TControl.MakeWordWrap<1>'; - if (AutoSize and AutoSizeRunTime) xor DefaultAutoSize then - //Result := Result + '.AutoSize( ' + BoolVals[ AutoSize ] + ' )'; - {P}Result := Result + ' L(' + IntToStr( Integer( AutoSize ) ) + ') C1 ' + - 'TControl.AutoSize<2>'; - - - LogOK; - finally - Log( '<-TKOLCustomControl.P_Generate_SetSize' ); - end; -end; - -function TKOLCustomControl.P_StringConstant(const Propname, - Value: String): String; -begin - Log( '->TKOLCustomControl.StringConstant' ); - try - - if (Value <> '') AND - ((Localizy = loForm) and (ParentKOLForm <> nil) and - (ParentKOLForm.Localizy) or (Localizy = loYes)) then - begin - //Result := ParentKOLForm.Name + '_' + Name + '_' + Propname; - {P}Result := ' ResourceString(' + Name + '_' + PropName + ')'; - ParentKOLForm.MakeResourceString( Result, Value ); - end - else - begin - //Result := String2Pascal( Value ); - {P}Result := ' LoadAnsiStr ' + P_String2Pascal( Value ); - end; - - LogOK; - finally - Log( '<-TKOLCustomControl.StringConstant' ); - end; -end; - function TKOLCustomControl.SetupColorFirst: Boolean; begin - Result := TRUE; -end; - -procedure TKOLCustomControl.P_ProvideFakeType(SL: TStrings; - const Declaration: String); -var i: Integer; -begin - for i := 0 to SL.Count-1 do - if AnsiCompareText( SL[ i ], Declaration ) = 0 then Exit; - SL.Insert( 1, Declaration ); + Result := True; end; function TKOLCustomControl.VerticalAlignAsKOLVerticalAlign: Integer; begin - CASE VerticalAlign OF - vaCenter: Result := 0; - vaTop: Result := 1; - vaBottom: Result := 2; - else Result := 0; - END; + case VerticalAlign of + vaCenter: Result := 0; + vaTop: Result := 1; + vaBottom: Result := 2; + else + Result := 0; + end; end; procedure TKOLCustomControl.SetAnchorBottom(const Value: Boolean); begin - if FAnchorBottom = Value then Exit; + if FAnchorBottom = Value then + Exit; FAnchorBottom := Value; if Value then begin if Value then begin - Anchors := Anchors + [ akBottom ]; + Anchors := Anchors + [akBottom]; if FAnchorTop then - Anchors := AnChors + [ akTop ] + Anchors := Anchors + [akTop] else - Anchors := AnChors - [ akTop ]; - end else - Anchors := Anchors - [ akBottom ]; + Anchors := Anchors - [akTop]; + end + else + Anchors := Anchors - [akBottom]; end; Change; end; procedure TKOLCustomControl.SetAnchorRight(const Value: Boolean); begin - if FAnchorRight = Value then Exit; + if FAnchorRight = Value then + Exit; FAnchorRight := Value; if Value then begin if Value then begin - Anchors := Anchors + [ akRight ]; + Anchors := Anchors + [akRight]; if FAnchorLeft then - Anchors := Anchors + [ akLeft ] + Anchors := Anchors + [akLeft] else - Anchors := Anchors - [ akLeft ]; - end else - Anchors := Anchors - [ akRight ]; + Anchors := Anchors - [akLeft]; + end + else + Anchors := Anchors - [akRight]; end; Change; end; procedure TKOLCustomControl.SetpopupMenu(const Value: TKOLPopupMenu); begin - if FpopupMenu = Value then Exit; + if FpopupMenu = Value then + Exit; FpopupMenu := Value; Change; end; -procedure TKOLCustomControl.P_AfterFontChange(SL: TStrings; const AName, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.P_AfterFontChange', 0 - @@e_signature: - end; - // -end; - function TKOLCustomControl.GetWindowed: Boolean; begin - {$IFDEF DISABLE_GRAPHIC_CTRLS} - Result := TRUE; - {$ELSE} +{$IFDEF DISABLE_GRAPHIC_CTRLS} + Result := True; +{$ELSE} Result := FWindowed; - {$ENDIF} +{$ENDIF} end; procedure TKOLCustomControl.SetupName(SL: TStringList; const AName, AParent, - Prefix: String); -var KF: TKOLForm; + Prefix: string); +var + KF: TKOLForm; begin - if FNameSetuped then Exit; + if FNameSetuped then + Exit; KF := ParentKOLForm; - if KF = nil then Exit; - if (Name <> '') and KF.GenerateCtlNames then - begin - if KF.FormCompact and SupportsFormCompact then - begin - if AParent <> 'nil' then - begin - KF.FormAddCtlCommand( Name, 'FormSetName', '' ); - KF.FormAddStrParameter( Name ); - end - else - SL.Add(Format( '%s%s.SetName( Result, ''%s'' ); ', [Prefix, AName, Name])); - end - else - begin - if AParent <> 'nil' then // this control placed NOT on datamodule - SL.Add(Format( '%s%s.SetName( Result.Form, ''%s'' ); ', [Prefix, AName, Name])) - else // not on form - SL.Add(Format( '%s%s.SetName( Result, ''%s'' ); ', [Prefix, AName, Name])); - end; - FNameSetuped := TRUE; - end; -end; - -procedure TKOLCustomControl.P_SetupName(SL: TStringList); -begin - if fP_NameSetuped then Exit; - if Name <> '' then - begin - //SL.Add( ' {$IFDEF USE_NAMES}' ); - //SL.Add( Prefix + AName + '.Name := ''' + Name + ''';' ); - //SL.Add( ' {$ENDIF}' ); - { - if AParent <> 'nil' then // this control placed NOT on datamodule - Sl.Add(Format( '%s%s.SetName( Result.Form, ''%s'' ); ', [Prefix, AName, Name])) - else // not on form - Sl.Add(Format( '%s%s.SetName( Result, ''%s'' ); ', [Prefix, AName, Name])); - } - {P}SL.Add( ' IFDEF(USE_NAMES)' ); - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( Name ) ); - {P}SL.Add( ' LoadSELF' ); // второй фактический (1-й формальный параметр) - - // объект-хозяин, держатель списка именованных объектов - {P}SL.Add( ' C3 TObj_.SetName<3>' ); - {P}SL.Add( ' DelAnsiStr' ); - {P}SL.Add( ' ENDIF' ); - fP_NameSetuped := TRUE; + if KF = nil then + Exit; + if (name <> '') and KF.GenerateCtlNames then begin + if AParent <> 'nil' then // this control placed NOT on datamodule + SL.Add(Format('%s%s.SetName( Result.Form, ''%s'' ); ', [Prefix, AName, name])) + else // not on form + SL.Add(Format('%s%s.SetName( Result, ''%s'' ); ', [Prefix, AName, name])); + FNameSetuped := True; end; end; @@ -10031,14 +8677,15 @@ begin DB 'TKOLCustomControl.SetOnChar', 0 @@e_signature: end; - if @ FOnDeadChar = @ Value then Exit; - Log( '->TKOLCustomControl.SetOnChar' ); + if @FOnDeadChar = @Value then + Exit; + Log('->TKOLCustomControl.SetOnChar'); try - FOnDeadChar := Value; - Change; - LogOK; + FOnDeadChar := Value; + Change; + LogOK; finally - Log( '<-TKOLCustomControl.SetOnChar' ); + Log('<-TKOLCustomControl.SetOnChar'); end; end; @@ -10050,44 +8697,45 @@ begin DB 'TKOLCustomControl.SetOnMove', 0 @@e_signature: end; - if @ FOnMoving = @ Value then Exit; + if @FOnMoving = @Value then + Exit; FOnMoving := Value; Change; end; -procedure TKOLCustomControl.SetupSetUnicode(SL: TStringList; const AName: String); -var KF: TKOLForm; +procedure TKOLCustomControl.SetupSetUnicode(SL: TStringList; const AName: string); +var + KF: TKOLForm; begin - KF := ParentKOLForm; - if KF = nil then Exit; - if KF.Unicode then - begin - if KF.FormCompact and SupportsFormCompact then - KF.FormAddCtlCommand( Name, 'FormSetUnicode', '' ) - else - SL.Add( ' ' + AName + '.SetUnicode(TRUE);' ); - end; + KF := ParentKOLForm; + if KF = nil then + Exit; + if KF.Unicode then begin + SL.Add(' ' + AName + '.SetUnicode(TRUE);'); + end; end; procedure TKOLCustomControl.SetAcceptChildren(const Value: Boolean); begin FAcceptChildren := Value; if Value then - ControlStyle := ControlStyle + [ csAcceptsControls ] + ControlStyle := ControlStyle + [csAcceptsControls] else - ControlStyle := ControlStyle - [ csAcceptsControls ]; + ControlStyle := ControlStyle - [csAcceptsControls]; end; procedure TKOLCustomControl.SetMouseTransparent(const Value: Boolean); begin - if FMouseTransparent = Value then Exit; + if FMouseTransparent = Value then + Exit; FMouseTransparent := Value; Change; end; procedure TKOLCustomControl.SetOverrideScrollbars(const Value: Boolean); begin - if fOverrideScrollbars = Value then Exit; + if FOverrideScrollbars = Value then + Exit; FOverrideScrollbars := Value; Change; end; @@ -10104,251 +8752,75 @@ begin Change; end; -function TKOLCustomControl.SupportsFormCompact: Boolean; +procedure TKOLCustomControl.GenerateVerticalAlign(SL: TStrings; const AName: string); begin - Result := FALSE; + SL.Add(' ' + AName + '.VerticalAlign := KOL.' + VertAligns[VerticalAlign] + ';'); end; -procedure TKOLCustomControl.GenerateTransparentInits_Compact; -var KF: TKOLForm; +procedure TKOLCustomControl.GenerateTextAlign(SL: TStrings; const AName: string); begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLCustomControl.GenerateTransparentInits_Compact', 0 - @@e_signature: - end; - Log( '->TKOLCustomControl.GenerateTransparentInits_Compact' ); - try - - KF := ParentKOLForm; - if KF = nil then Exit; - - if Align = caNone then - begin - if IsGenerateSize then - begin - if PlaceRight then - KF.FormAddCtlCommand( Name, 'TControl.PlaceRight', '' ) - else - if PlaceDown then - KF.FormAddCtlCommand( Name, 'TControl.PlaceDown', '' ) - else - if PlaceUnder then - KF.FormAddCtlCommand( Name, 'TControl.PlaceUnder', '' ) - else - if not CenterOnParent then - if (actualLeft <> ParentMargin) or (actualTop <> ParentMargin) then - begin - KF.FormAddCtlCommand( Name, 'FormSetPosition', '' ); - KF.FormAddNumParameter( actualLeft ); - KF.FormAddNumParameter( actualTop ); - end; - end; - end; - if Align <> caNone then - begin - if Integer( Align ) = 1 then - begin - KF.FormAddCtlCommand( Name, 'TControl.Set_Align', '' ); - // param = 1 - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetAlign', '' ); - KF.FormAddNumParameter( Integer( Align ) ); - end; - end; - Generate_SetSize_Compact; - if CenterOnParent and (Align = caNone) then - KF.FormAddCtlCommand( Name, 'TControl.CenterOnParent', '' ); - if KF.zOrderChildren then - KF.FormAddCtlCommand( Name, 'TControl.BringToFront', '' ); - if EditTabChar then - KF.FormAddCtlCommand( Name, 'TControl.EditTabChar', '' ); - if (HelpContext <> 0) and (Faction = nil) then - begin - KF.FormAddCtlCommand( Name, 'FormAssignHelpContext', '' ); - KF.FormAddNumParameter( HelpContext ); - end; - if MouseTransparent then - KF.FormAddCtlCommand( Name, 'TControl.MouseTransparent', '' ); - if LikeSpeedButton then - KF.FormAddCtlCommand( Name, 'TControl.LikeSpeedButton', '' ); - - LogOK; - finally - Log( '<-TKOLCustomControl.GenerateTransparentInits_Compact' ); - end; + SL.Add(' ' + AName + '.TextAlign := KOL.' + TextAligns[TextAlign] + ';'); end; -procedure TKOLCustomControl.SetupConstruct_Compact; +procedure TKOLCustomControl.DefineFormEvents(const EventNamesAndDefs: array of string); +var + I: Integer; + s: KOLString; + ev_name: string; + StoreDef: PChar; begin - // must be overriden when SupportsFormCompact returns TRUE - ParentKOLForm.FormAddCtlParameter( Name ); - ParentKOLForm.FormCurrentCtlForTransparentCalls := Name; -end; - -procedure TKOLCustomControl.Generate_SetSize_Compact; -const BoolVals: array[ Boolean ] of String = ( 'FALSE', 'TRUE' ); -var W, H: Integer; - SizeWasSet: Boolean; - KF: TKOLForm; -begin - Log( '->TKOLCustomControl.Generate_SetSize_Compact' ); - try - - KF := ParentKOLForm; - if KF = nil then Exit; - - SizeWasSet := FALSE; - W := 0; - H := 0; - if Align <> caClient then - if (Width <> DefaultWidth) or (Height <> DefaultHeight) or not Windowed then - begin - if ((Width <> DefaultWidth) or not Windowed) - and not (Align in [ caTop, caBottom ]) then - W := Width; - if ((Height <> DefaultHeight) or not Windowed) - and not (Align in [ caLeft, caRight ]) then - H := Height; + if FEventDefs = nil then + FEventDefs := TStringList.Create; + for I := 0 to High(EventNamesAndDefs) do begin + s := EventNamesAndDefs[I]; + ev_name := {$IFDEF UNICODE_CTRLS}ParseW{$ELSE}Parse{$ENDIF}(s, ':'); + if FEventDefs.IndexOf(ev_name) >= 0 then + Continue; + s := Trim(s); + GetMem(StoreDef, Length(s) + 1); + Move(s[1], StoreDef^, Length(s) + 1); + FEventDefs.AddObject(ev_name, Pointer(StoreDef)); end; - - if IsGenerateSize or not Windowed then - if not (autoSize and AutoSizeRunTime) or WordWrap or fNoAutoSizeX then - begin - if autoSize and AutoSizeRunTime then - H := 0; - if (W <> 0) or (H <> 0) then - begin - KF.FormAddCtlCommand( Name, 'FormSetSize', '' ); - KF.FormAddNumParameter( W ); - KF.FormAddNumParameter( H ); - SizeWasSet := TRUE; - end; - end; - if WordWrap then - KF.FormAddCtlCommand( Name, 'TControl.MakeWordWrap', '' ); // param = 1 - if (AutoSize and AutoSizeRunTime) xor DefaultAutoSize then - KF.FormAddCtlCommand( Name, 'TControl.AutoSize', '' ); // param = 1 - - if not SizeWasSet then - //Result := Result + '{Generate_SetSize W' + IntToStr(W) + 'H' + IntToStr(H) + '} ' - ; - - LogOK; - finally - Log( '<-TKOLCustomControl.Generate_SetSize_Compact' ); - end; -end; - -procedure TKOLCustomControl.GenerateVerticalAlign( SL: TStrings; const AName: String ); -var KF: TKOLForm; -begin - KF := ParentKOLForm; - if (KF <> nil) and KF.FormCompact then - begin - if Integer( VerticalAlign ) = 1 then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetVerticalAlign', '' ); - // param = 1 - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetVTextVAlign', '' ); - KF.FormAddNumParameter( Integer( VerticalAlign ) ); - end; - end else - SL.Add( ' ' + AName + '.VerticalAlign := KOL.' + VertAligns[ VerticalAlign ] + ';' ); -end; - -procedure TKOLCustomControl.GenerateTextAlign(SL: TStrings; - const AName: String); -var KF: TKOLForm; -begin - KF := ParentKOLForm; - if (KF <> nil) and KF.FormCompact then - begin - if Integer( TextAlign ) = 1 then - begin - KF.FormAddCtlCommand( Name, 'TControl.SetTextAlign', '' ); - // param = 1 - end - else - begin - KF.FormAddCtlCommand( Name, 'FormSetTextAlign', '' ); - KF.FormAddNumParameter( Integer( TextAlign ) ); - end; - end else - SL.Add( ' ' + AName + '.TextAlign := KOL.' + TextAligns[ TextAlign ] + ';' ); -end; - -function TKOLCustomControl.HasCompactConstructor: Boolean; -begin - Result := SupportsFormCompact; -end; - -procedure TKOLCustomControl.DefineFormEvents( - const EventNamesAndDefs: array of String); -var i: Integer; - s: KOLString; - ev_name: String; - StoreDef: PChar; -begin - if FEventDefs = nil then - FEventDefs := TStringList.Create; - for i := 0 to High(EventNamesAndDefs) do - begin - s := EventNamesAndDefs[i]; - ev_name := {$IFDEF UNICODE_CTRLS} ParseW {$ELSE} Parse {$ENDIF} ( s, ':' ); - if FEventDefs.IndexOf( ev_name ) >= 0 then - continue; - s := Trim(s); - GetMem( StoreDef, Length( s )+1 ); - Move( s[1], StoreDef^, Length(s)+1 ); - FEventDefs.AddObject( ev_name, Pointer( StoreDef ) ); - end; end; procedure TKOLCustomControl.SetupTabOrder(SL: TStringList; - const AName: String); + const AName: string); begin - RptDetailed( 'SetupLast for ' + AName + ', TabStop = ' + IntToStr( Integer( TabStop ) ), - YELLOW ); - if not TabStop then Exit; - Rpt( 'TabOrder = ' + IntToStr( FTabOrder ) + - ', Creation order = ' + IntToStr( Integer( fCreationOrder ) ), - YELLOW ); - if (TabOrder <> fCreationOrder) and ParentKOLForm.AssignTabOrders then - SL.Add( ' ' + AName + '.TabOrder := ' + IntToStr( TabOrder ) + ';' ); + RptDetailed('SetupLast for ' + AName + ', TabStop = ' + IntToStr(Integer(TabStop)), + YELLOW); + if not TabStop then + Exit; + Rpt('TabOrder = ' + IntToStr(FTabOrder) + + ', Creation order = ' + IntToStr(Integer(fCreationOrder)), + YELLOW); + if (TabOrder <> fCreationOrder) and ParentKOLForm.AssignTabOrders then + SL.Add(' ' + AName + '.TabOrder := ' + IntToStr(TabOrder) + ';'); end; function TKOLCustomControl.DefaultBorder: Integer; begin - Result := 2; + Result := 2; end; function TKOLCustomControl.ParentBorder: Integer; -var C: TWinControl; +var + c: TWinControl; begin - Result := -1; - C := Parent; - if C <> nil then - begin - if C is TKOLCustomControl then - Result := (C as TKOLCustomControl).Border - else if C is TCustomForm then - begin - if ParentKOLForm <> nil then - Result := ParentKOLForm.Border; - end; + Result := -1; + c := Parent; + if c <> nil then begin + if c is TKOLCustomControl then + Result := (c as TKOLCustomControl).Border + else if c is TCustomForm then begin + if ParentKOLForm <> nil then + Result := ParentKOLForm.Border; end; + end; end; { TKOLApplet } -procedure TKOLApplet.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLApplet.AssignEvents(SL: TStringList; const AName: string); begin asm jmp @@e_signature @@ -10356,17 +8828,15 @@ begin DB 'TKOLApplet.AssignEvents', 0 @@e_signature: end; - Log( '->TKOLApplet.AssignEvents' ); - TRY - - DoAssignEvents( SL, AName, - [ 'OnMessage', 'OnDestroy', 'OnClose', 'OnQueryEndSession', 'OnMinimize', 'OnRestore' ], - [ @OnMessage, @ OnDestroy, @ OnClose, @ OnQueryEndSession, @ OnMinimize, @ OnRestore ] ); - - LogOK; - FINALLY - Log( '<-TKOLApplet.AssignEvents' ); - END; + Log('->TKOLApplet.AssignEvents'); + try + DoAssignEvents(SL, AName, + ['OnMessage', 'OnDestroy', 'OnClose', 'OnQueryEndSession', 'OnMinimize', 'OnRestore'], + [@OnMessage, @OnDestroy, @OnClose, @OnQueryEndSession, @OnMinimize, @OnRestore]); + LogOK; + finally + Log('<-TKOLApplet.AssignEvents'); + end; end; function TKOLApplet.AutoCaption: Boolean; @@ -10377,16 +8847,17 @@ begin DB 'TKOLApplet.AutoCaption', 0 @@e_signature: end; - Result := TRUE; + Result := True; end; -function TKOLApplet.BestEventName: String; +function TKOLApplet.BestEventName: string; begin Result := 'OnMessage'; end; -procedure TKOLApplet.Change( Sender : TComponent ); -var S: String; +procedure TKOLApplet.Change(Sender: TComponent); +var + s: string; begin asm jmp @@e_signature @@ -10394,122 +8865,113 @@ begin DB 'TKOLApplet.Change', 0 @@e_signature: end; - Log( '->TKOLApplet.Change' ); - TRY - - RptDetailed( 'Sender class: ' + Sender.ClassName, YELLOW ); - Rpt_Stack; - - if fChangingNow or ( csLoading in ComponentState ) or (Name = '') or fIsDestroying or - (Owner = nil) or (csDestroying in Owner.ComponentState) then - begin - LogOK; Exit; - end; - //if Creating_DoNotGenerateCode then Exit; - fChangingNow := TRUE; + Log('->TKOLApplet.Change'); try - FChanged := TRUE; - if KOLProject <> nil then - begin - try - S := KOLProject.SourcePath; - except - on E: Exception do - begin - ShowMessage( 'Can not obtain KOLProject.SourcePath, exception: ' + - E.Message ); - S := fSourcePath; + RptDetailed('Sender class: ' + Sender.ClassName, YELLOW); + Rpt_Stack; + + if fChangingNow or (csLoading in ComponentState) or (name = '') or FIsDestroying or + (Owner = nil) or (csDestroying in Owner.ComponentState) then begin + LogOK; + Exit; + end; + //if Creating_DoNotGenerateCode then Exit; + fChangingNow := True; + try + FChanged := True; + + if KOLProject <> nil then begin + try + s := KOLProject.sourcePath; + except + on E: Exception do begin + Showmessage('Can not obtain KOLProject.SourcePath, exception: ' + + E.Message); + s := fSourcePath; + end; end; - end; - fSourcePath := S; - if (csLoading in ComponentState) then - begin - LogOK; Exit; - end; - if Sender <> nil then - begin - if (Self is TKOLForm) and ((Sender as TKOLForm).FormName <> '') then - Rpt( Sender.Name + '(' + (Sender as TKOLForm).FormName + '): ' + - Sender.ClassName + ' changed.', WHITE ) - else - Rpt( Sender.Name + ': ' + Sender.ClassName + ' changed.', WHITE ); - //Rpt_Stack; - end; - //if (Sender <> nil) and (Sender.Name <> '') then - KOLProject.Change; - end - else - if (fSourcePath = '') or not DirectoryExists( fSourcePath ) or - (ToolServices = nil) or not(Self is TKOLForm) then - begin - if FShowingWarnAbtMainForm then - begin - LogOK; Exit; - end; - if Abs( Integer( GetTickCount ) - FLastWarnTimeAbtMainForm ) > 3000 then - begin - FLastWarnTimeAbtMainForm := GetTickCount; - if (csLoading in ComponentState) then - begin - LogOK; Exit; + fSourcePath := s; + if (csLoading in ComponentState) then begin + LogOK; + Exit; end; - S := Name; - if (Sender <> nil) and (Sender.Name <> '') then - S := Sender.Name; - if S = '' then - begin - LogOK; Exit; - end; - FShowingWarnAbtMainForm := True; - ShowMessage( S + ' is changed, but changes can not ' + - 'be applied because TKOLProject component is not found. ' + - 'Be sure that your main form is opened in designer and ' + - 'TKOLProject component present on it to provide automatic ' + - 'or manual code generation for all changes made at design ' + - 'time.' ); - FLastWarnTimeAbtMainForm := GetTickCount; - FShowingWarnAbtMainForm := False; - end; - end - else - begin - try - if (csLoading in ComponentState) then - begin - LogOK; Exit; - end; - if Sender <> nil then - begin - if (Self is TKOLForm) and ((Sender as TKOLForm).FormName <> '') then - Rpt( Sender.Name + '(' + (Sender as TKOLForm).FormName + '): ' + - Sender.ClassName + ' changed.', WHITE ) + if Sender <> nil then begin + if (Self is TKOLForm) and ((Sender as TKOLForm).formName <> '') then + Rpt(Sender.name + '(' + (Sender as TKOLForm).formName + '): ' + + Sender.ClassName + ' changed.', WHITE) else - Rpt( Sender.Name + ': ' + Sender.ClassName + ' changed.', WHITE ); + Rpt(Sender.name + ': ' + Sender.ClassName + ' changed.', WHITE); + //Rpt_Stack; end; - //S := ToolServices.GetCurrentFile; - S := (Self as TKOLForm).formUnit; // by Speller - //S := IncludeTrailingPathDelimiter( fSourcePath ) + ExtractFileName( S ); - S := IncludeTrailingPathDelimiter(fSourcePath) + S; // by Speller - RptDetailed( 'Call GenerateUnit from AppletChanged for ' + Name, LIGHT+ CYAN ); - (Self as TKOLForm).GenerateUnit( S ); - //ShowMessage( S + ' is changed and is regenerated!' ); - except - on E: Exception do - begin - ShowMessage( 'Can not handle Applet.Change, exception: ' + E.Message ); + //if (Sender <> nil) and (Sender.Name <> '') then + KOLProject.Change; + end + else if (fSourcePath = '') or not DirectoryExists(fSourcePath) or + (ToolServices = nil) or not (Self is TKOLForm) then begin + if FShowingWarnAbtMainForm then begin + LogOK; + Exit; + end; + if Abs(Integer(GetTickCount) - FLastWarnTimeAbtMainForm) > 3000 then begin + FLastWarnTimeAbtMainForm := GetTickCount; + if (csLoading in ComponentState) then begin + LogOK; + Exit; + end; + s := name; + if (Sender <> nil) and (Sender.name <> '') then + s := Sender.name; + if s = '' then begin + LogOK; + Exit; + end; + FShowingWarnAbtMainForm := True; + Showmessage(s + ' is changed, but changes can not ' + + 'be applied because TKOLProject component is not found. ' + + 'Be sure that your main form is opened in designer and ' + + 'TKOLProject component present on it to provide automatic ' + + 'or manual code generation for all changes made at design ' + + 'time.'); + FLastWarnTimeAbtMainForm := GetTickCount; + FShowingWarnAbtMainForm := False; + end; + end + else begin + try + if (csLoading in ComponentState) then begin + LogOK; + Exit; + end; + if Sender <> nil then begin + if (Self is TKOLForm) and ((Sender as TKOLForm).formName <> '') then + Rpt(Sender.name + '(' + (Sender as TKOLForm).formName + '): ' + + Sender.ClassName + ' changed.', WHITE) + else + Rpt(Sender.name + ': ' + Sender.ClassName + ' changed.', WHITE); + end; + //S := ToolServices.GetCurrentFile; + s := (Self as TKOLForm).formUnit; // by Speller + //S := IncludeTrailingPathDelimiter( fSourcePath ) + ExtractFileName( S ); + s := IncludeTrailingPathDelimiter(fSourcePath) + s; // by Speller + RptDetailed('Call GenerateUnit from AppletChanged for ' + name, LIGHT + CYAN); + (Self as TKOLForm).GenerateUnit(s); + //ShowMessage( S + ' is changed and is regenerated!' ); + except + on E: Exception do begin + Showmessage('Can not handle Applet.Change, exception: ' + E.Message); + end; end; end; + + finally + fChangingNow := False; end; + LogOK; finally - fChangingNow := FALSE; + Log('<-TKOLApplet.Change'); end; - - LogOK; - FINALLY - Log( '<-TKOLApplet.Change' ); - END; end; procedure TKOLApplet.ChangeDPR; @@ -10520,18 +8982,18 @@ begin DB 'TKOLApplet.ChangeDPR', 0 @@e_signature: end; - Log( '->TKOLApplet.ChangeDPR' ); - TRY + Log('->TKOLApplet.ChangeDPR'); + try - //BuildKOLProject; - if not (csLoading in ComponentState) and - (KOLProject <> nil) and not (KOLProject.FBuilding) then - KOLProject.ConvertVCL2KOL( TRUE, FALSE ); + //BuildKOLProject; + if not (csLoading in ComponentState) and + (KOLProject <> nil) and not (KOLProject.FBuilding) then + KOLProject.ConvertVCL2KOL(True, False); - LogOK; - FINALLY - Log( '<-TKOLApplet.ChangeDPR' ); - END; + LogOK; + finally + Log('<-TKOLApplet.ChangeDPR'); + end; end; constructor TKOLApplet.Create(AOwner: TComponent); @@ -10543,76 +9005,70 @@ begin DB 'TKOLApplet.Create', 0 @@e_signature: end; - Log( '->TKOLApplet.Create' ); + Log('->TKOLApplet.Create'); //WasCreating := Creating_DoNotGenerateCode; //Creating_DoNotGenerateCode := TRUE; - TRY + try - inherited; - Visible := True; - Enabled := True; - if ClassName = 'TKOLApplet' then - begin - if KOLProject <> nil then - begin - if KOLProject.ProjectDest = '' then - Caption := KOLProject.ProjectName + inherited; + Visible := True; + Enabled := True; + if ClassName = 'TKOLApplet' then begin + if KOLProject <> nil then begin + if KOLProject.projectDest = '' then + Caption := KOLProject.projectName + else + Caption := KOLProject.projectDest; + end; + if Applet <> nil then begin + Showmessage('You have already TKOLApplet component defined in your project. ' + + 'It must be a single (and it is necessary in project only in ' + + 'case, when the project contains several forms, or feature of ' + + 'hiding application button on taskbar is desireable.'#13 + + 'It is recommended to place TKOLApplet on main form of your ' + + 'project, together with TKOLProject component.'); + end else - Caption := KOLProject.ProjectDest; - end; - if Applet <> nil then - begin - ShowMessage( 'You have already TKOLApplet component defined in your project. ' + - 'It must be a single (and it is necessary in project only in ' + - 'case, when the project contains several forms, or feature of ' + - 'hiding application button on taskbar is desireable.'#13 + - 'It is recommended to place TKOLApplet on main form of your ' + - 'project, together with TKOLProject component.' ); + Applet := Self; end - else - Applet := Self; - end - else - begin - if (Owner <> nil) and (Owner is TForm) then - if AutoCaption then - Caption := (Owner as TForm).Caption - else - begin - if Caption <> '' then - Caption := ''; - (Owner as TForm).Caption := ''; + else begin + if (Owner <> nil) and (Owner is TForm) then + if AutoCaption then + Caption := (Owner as TForm).Caption + else begin + if Caption <> '' then + Caption := ''; + (Owner as TForm).Caption := ''; + end; end; - end; - FLastWarnTimeAbtMainForm := GetTickCount; + FLastWarnTimeAbtMainForm := GetTickCount; - LogOK; - FINALLY - Log( '<-TKOLApplet.Create' ); + LogOK; + finally + Log('<-TKOLApplet.Create'); //Creating_DoNotGenerateCode := WasCreating; - END; + end; end; -procedure TKOLApplet.DefineFormEvents( - const EventNamesAndDefs: array of String); -var i: Integer; - s: KOLString; - ev_name: String; - StoreDef: PAnsiChar; +procedure TKOLApplet.DefineFormEvents(const EventNamesAndDefs: array of string); +var + I: Integer; + s: KOLString; + ev_name: string; + StoreDef: PAnsiChar; begin - if FEventDefs = nil then - FEventDefs := TStringList.Create; - for i := 0 to High(EventNamesAndDefs) do - begin - s := EventNamesAndDefs[i]; - ev_name := Parse( s, ':' ); - if FEventDefs.IndexOf( ev_name ) >= 0 then - continue; - s := Trim(s); - GetMem( StoreDef, Length( s )+1 ); - Move( s[1], StoreDef^, Length(s)+1 ); - FEventDefs.AddObject( ev_name, Pointer( StoreDef ) ); - end; + if FEventDefs = nil then + FEventDefs := TStringList.Create; + for I := 0 to High(EventNamesAndDefs) do begin + s := EventNamesAndDefs[I]; + ev_name := Parse(s, ':'); + if FEventDefs.IndexOf(ev_name) >= 0 then + Continue; + s := Trim(s); + GetMem(StoreDef, Length(s) + 1); + Move(s[1], StoreDef^, Length(s) + 1); + FEventDefs.AddObject(ev_name, Pointer(StoreDef)); + end; end; destructor TKOLApplet.Destroy; @@ -10623,27 +9079,24 @@ begin DB 'TKOLApplet.Destroy', 0 @@e_signature: end; - Log( '->TKOLApplet.Destroy' ); - TRY + Log('->TKOLApplet.Destroy'); + try - if Applet = Self then - Applet := nil; - inherited; + if Applet = Self then + Applet := nil; + inherited; - LogOK; - FINALLY - Log( '<-TKOLApplet.Destroy' ); - END; + LogOK; + finally + Log('<-TKOLApplet.Destroy'); + end; end; -procedure TKOLApplet.DoAssignEvents(SL: TStringList; const AName: String; +procedure TKOLApplet.DoAssignEvents(SL: TStringList; const AName: string; EventNames: array of PChar; EventHandlers: array of Pointer); -var I, j: Integer; - add_SL: Boolean; - s: KOLString; - ev_setter, ev_handler: String; - N_ev_setter, N_ev_handler: Integer; - FF: TKOLForm; +var + I: Integer; + add_SL: Boolean; begin asm jmp @@e_signature @@ -10652,68 +9105,29 @@ begin @@e_signature: end; //Log( '->TKOLApplet.DoAssignEvents' ); - TRY + try - RptDetailed( 'DoAssignEvents begin', WHITE ); + RptDetailed('DoAssignEvents begin', WHITE); - for I := 0 to High( EventHandlers ) do - begin - if EventHandlers[ I ] <> nil then - begin - add_SL := TRUE; - if (Self is TKOLForm) and (Owner <> nil) and (Owner is TCustomForm) - and (Self as TKOLForm).FormCompact and (FEventDefs <> nil) then - begin - FF := Self as TKOLForm; - j := FEventDefs.IndexOf( EventNames[I] ); - if j >= 0 then - begin - s := PChar( FEventDefs.Objects[j] ); - if s = '' then continue; - if FAssignOnlyWinEvents and (s[1] = '^') then - continue; - if FAssignOnlyUserEvents and (s[1] <> '^') then - continue; - if s[1] = '^' then - Delete( s, 1, 1 ); - ev_setter := Trim( Parse( s, ',' ) ); - ev_handler := 'T' + FF.formName + '.' + - (Owner as TCustomForm).MethodName( EventHandlers[ I ] ); - N_ev_setter := FF.FormAddAlphabet( ev_setter, FALSE, FALSE, ' ' + ev_setter + ':' + EventNames[I] ); - N_ev_handler := FF.FormAddAlphabet( ev_handler, FALSE, FALSE, ' ' + ev_handler + ':' + EventNames[I] ); - s := Trim( s ); - if s = '' then - begin - FF.FormAddCtlCommand( Name, 'FormSetEvent', ' ' + EventNames[I] ); - FF.FormAddNumParameter( N_ev_handler ); - FF.FormAddNumParameter( N_ev_setter ); - end - else - begin - FF.FormAddCtlCommand( Name, 'FormSetIndexedEvent', ' ' + EventNames[I] ); - FF.FormAddNumParameter( N_ev_handler ); - FF.FormAddNumParameter( StrToInt( s ) ); - FF.FormAddNumParameter( N_ev_setter ); - end; - add_SL := FALSE; - end; - end; - if add_SL then - SL.Add( ' ' + AName + '.' + String(EventNames[ I ]) + - ' := Result.' + - (Owner as TForm).MethodName( EventHandlers[ I ] ) + ';' ); - // TODO: KOL_ANSI ??? + for I := 0 to High(EventHandlers) do begin + if EventHandlers[I] <> nil then begin + add_SL := True; + if add_SL then + SL.Add(' ' + AName + '.' + string(EventNames[I]) + + ' := Result.' + + (Owner as TForm).MethodName(EventHandlers[I]) + ';'); + // TODO: KOL_ANSI ??? end; - end; + end; - RptDetailed( 'DoAssignEvents end', WHITE ); - //LogOK; - FINALLY + RptDetailed('DoAssignEvents end', WHITE); + //LogOK; + finally //Log( '<-TKOLApplet.DoAssignEvents' ); - END; + end; end; -procedure TKOLApplet.GenerateRun(SL: TStringList; const AName: String); +procedure TKOLApplet.GenerateRun(SL: TStringList; const AName: string); begin asm jmp @@e_signature @@ -10721,133 +9135,43 @@ begin DB 'TKOLApplet.GenerateRun', 0 @@e_signature: end; - Log( '->TKOLApplet.GenerateRun' ); - TRY - - if Tag <> 0 then - begin - if Tag < 0 then - SL.Add( ' Applet.Tag := DWORD(' + IntToStr( Tag ) + ');' ) - else - SL.Add( ' Applet.Tag := ' + IntToStr( Tag ) + ';' ); - end; - if not(Self is TKOLForm) then - begin - if AllBtnReturnClick then - SL.Add( ' Applet.AllBtnReturnClick;' ); - if Tabulate then - SL.Add( ' Applet.Tabulate;' ) - else - if TabulateEx then - SL.Add( ' Applet.TabulateEx;' ); - end; - SL.Add( ' Run( ' + AName + ' );' ); - - LogOK; - FINALLY - Log( '<-TKOLApplet.GenerateRun' ); - END; -end; - -function TKOLApplet.Pcode_Generate: Boolean; -begin - Result := ClassName = 'TKOLApplet'; -end; - -function TKOLApplet.P_AssignEvents(SL: TStringList; const AName: String; - CheckOnly: Boolean): Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLApplet.P_AssignEvents', 0 - @@e_signature: - end; - Result := TRUE; - Log( '->TKOLApplet.P_AssignEvents' ); - TRY - - if P_DoAssignEvents( SL, AName, - [ 'OnMessage', 'OnDestroy', 'OnClose', 'OnQueryEndSession', 'OnMinimize', 'OnRestore' ], - [ @OnMessage, @ OnDestroy, @ OnClose, @ OnQueryEndSession, @ OnMinimize, @ OnRestore ], - [ FALSE, FALSE, TRUE, TRUE, TRUE, TRUE ], - CheckOnly ) and CheckOnly then Exit; - Result := FALSE; - - LogOK; - FINALLY - if Result and CheckOnly then LogOK; - Log( '<-TKOLApplet.P_AssignEvents' ); - END; -end; - -function TKOLApplet.P_DoAssignEvents(SL: TStringList; const AName: String; - EventNames: array of PAnsiChar; EventHandlers: array of Pointer; - EventAssignProc: array of Boolean; - CheckOnly: Boolean): Boolean; -var I: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLApplet.P_DoAssignEvents', 0 - @@e_signature: - end; - Result := TRUE; - //Log( '->TKOLApplet.P_DoAssignEvents' ); - TRY - - for I := 0 to High( EventHandlers ) do - begin - if EventHandlers[ I ] <> nil then - //SL.Add( ' ' + AName + '.' + EventNames[ I ] + ' := Result.' + - // (Owner as TForm).MethodName( EventHandlers[ I ] ) + ';' ); - begin - if CheckOnly then Exit; - if EventAssignProc[ I ] then - begin - {P}SL.Add( ' LoadSELF Load4 ####T' + (Owner as TForm).Name + '.' + - (Owner as TForm).MethodName( EventHandlers[ I ] ) ); - {P}SL.Add( ' C2 TControl_.Set' + EventNames[ I ] + '<1>' - // похоже, что для всех процедур типа - // SetOnEvent( const event: TMethod ) - // второй параметр передается через стек! - ); - end - else - begin - {P}SL.Add( ' Load4 ####T' + (Owner as TForm).Name + '.' + - (Owner as TForm).MethodName( EventHandlers[ I ] ) ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.f' + EventNames[ I ] ); - {P}SL.Add( ' LoadSELF C1 AddWord_Store ##(4+TControl_.f' + - EventNames[ I ] + ')' ); - end; + Log('->TKOLApplet.GenerateRun'); + try + if Tag <> 0 then begin + if Tag < 0 then + SL.Add(' Applet.Tag := DWORD(' + IntToStr(Tag) + ');') + else + SL.Add(' Applet.Tag := ' + IntToStr(Tag) + ';'); end; - end; - if CheckOnly then - Result := FALSE; + if not (Self is TKOLForm) then begin + if AllBtnReturnClick then + SL.Add(' Applet.AllBtnReturnClick;'); + if Tabulate then + SL.Add(' Applet.Tabulate;') + else if TabulateEx then + SL.Add(' Applet.TabulateEx;'); + end; + SL.Add(' Run( ' + AName + ' );'); - //LogOK; - FINALLY - //if Result and CheckOnly then LogOK; - //Log( '<-TKOLApplet.P_DoAssignEvents' ); - END; + LogOK; + finally + Log('<-TKOLApplet.GenerateRun'); + end; end; procedure TKOLApplet.SetAllBtnReturnClick(const Value: Boolean); begin - Log( '->TKOLApplet.SetAllBtnReturnClick' ); - TRY - FAllBtnReturnClick := Value; - Change( Self ); - LogOK; - FINALLY - Log( '<-TKOLApplet.SetAllBtnReturnClick' ); - END; + Log('->TKOLApplet.SetAllBtnReturnClick'); + try + FAllBtnReturnClick := Value; + Change(Self); + LogOK; + finally + Log('<-TKOLApplet.SetAllBtnReturnClick'); + end; end; - -procedure TKOLApplet.SetCaption(const Value: String); +procedure TKOLApplet.SetCaption(const Value: string); begin asm jmp @@e_signature @@ -10855,17 +9179,16 @@ begin DB 'TKOLApplet.SetCaption', 0 @@e_signature: end; - Log( '->TKOLApplet.SetCaption' ); - TRY - if fCaption <> Value then - begin + Log('->TKOLApplet.SetCaption'); + try + if fCaption <> Value then begin fCaption := Value; - Change( Self ); + Change(Self); end; LogOK; - FINALLY - Log( '<-TKOLApplet.SetCaption' ); - END; + finally + Log('<-TKOLApplet.SetCaption'); + end; end; procedure TKOLApplet.SetEnabled(const Value: Boolean); @@ -10876,34 +9199,31 @@ begin DB 'TKOLApplet.SetEnabled', 0 @@e_signature: end; - Log( '->TKOLApplet.SetEnabled' ); - TRY - if fEnabled <> Value then - begin - fEnabled := Value; - Change( Self ); + Log('->TKOLApplet.SetEnabled'); + try + if fEnabled <> Value then begin + fEnabled := Value; + Change(Self); + end; + LogOK; + finally + Log('<-TKOLApplet.SetEnabled'); end; - LogOK; - FINALLY - Log( '<-TKOLApplet.SetEnabled' ); - END; end; procedure TKOLApplet.SetForceIcon16x16(const Value: Boolean); begin Log('->TKOLApplet.SetForceIcon16x16'); - TRY - - FForceIcon16x16 := Value; - Change( Self ); - - LogOK; - FINALLY - Log( '<-TKOLApplet.SetForceIcon16x16' ); - END; + try + FForceIcon16x16 := Value; + Change(Self); + LogOK; + finally + Log('<-TKOLApplet.SetForceIcon16x16'); + end; end; -procedure TKOLApplet.SetIcon(const Value: String); +procedure TKOLApplet.SetIcon(const Value: string); begin asm jmp @@e_signature @@ -10911,16 +9231,14 @@ begin DB 'TKOLApplet.SetIcon', 0 @@e_signature: end; - Log( '->TKOLApplet.SetIcon' ); - TRY - - FIcon := Value; - Change( Self ); - - LogOK; - FINALLY - Log( '<-TKOLApplet.SetIcon' ); - END; + Log('->TKOLApplet.SetIcon'); + try + FIcon := Value; + Change(Self); + LogOK; + finally + Log('<-TKOLApplet.SetIcon'); + end; end; procedure TKOLApplet.SetOnClose(const Value: TOnEventAccept); @@ -10931,16 +9249,14 @@ begin DB 'TKOLApplet.SetOnClose', 0 @@e_signature: end; - Log( '->TKOLApplet.SetOnClose' ); - TRY - - FOnClose := Value; - Change( Self ); - - LogOK; - FINALLY - Log( '<-TKOLApplet.SetOnClose' ); - END; + Log('->TKOLApplet.SetOnClose'); + try + FOnClose := Value; + Change(Self); + LogOK; + finally + Log('<-TKOLApplet.SetOnClose'); + end; end; procedure TKOLApplet.SetOnDestroy(const Value: TOnEvent); @@ -10951,16 +9267,14 @@ begin DB 'TKOLApplet.SetOnDestroy', 0 @@e_signature: end; - Log( '->TKOLApplet.SetOnDestroy' ); - TRY - - FOnDestroy := Value; - Change( Self ); - - LogOK; - FINALLY - Log( '<-TKOLApplet.SetOnDestroy' ); - END; + Log('->TKOLApplet.SetOnDestroy'); + try + FOnDestroy := Value; + Change(Self); + LogOK; + finally + Log('<-TKOLApplet.SetOnDestroy'); + end; end; procedure TKOLApplet.SetOnMessage(const Value: TOnMessage); @@ -10971,93 +9285,91 @@ begin DB 'TKOLApplet.SetOnMessage', 0 @@e_signature: end; - Log( '->TKOLApplet.SetOnMessage' ); - TRY - - FOnMessage := Value; - Change( Self ); - - LogOK; - FINALLY - Log( '<-TKOLApplet.SetOnMessage' ); - END; + Log('->TKOLApplet.SetOnMessage'); + try + FOnMessage := Value; + Change(Self); + LogOK; + finally + Log('<-TKOLApplet.SetOnMessage'); + end; end; procedure TKOLApplet.SetOnMinimize(const Value: TOnEvent); begin - Log( '->TKOLApplet.SetOnMinimize' ); - TRY + Log('->TKOLApplet.SetOnMinimize'); + try - FOnMinimize := Value; - Change( Self ); + FOnMinimize := Value; + Change(Self); - LogOK; - FINALLY - Log( '<-TKOLApplet.SetOnMinimize' ); - END; + LogOK; + finally + Log('<-TKOLApplet.SetOnMinimize'); + end; end; procedure TKOLApplet.SetOnQueryEndSession(const Value: TOnEventAccept); begin - Log( '->TKOLApplet.SetOnQueryEndSession' ); + Log('->TKOLApplet.SetOnQueryEndSession'); try - FOnQueryEndSession := Value; - Change( Self ); - LogOK; + FOnQueryEndSession := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLApplet.SetOnQueryEndSession' ); + Log('<-TKOLApplet.SetOnQueryEndSession'); end; end; procedure TKOLApplet.SetOnRestore(const Value: TOnEvent); begin - Log( '->TKOLApplet.SetOnRestore' ); + Log('->TKOLApplet.SetOnRestore'); try - FOnRestore := Value; - Change( Self ); - LogOK; + FOnRestore := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLApplet.SetOnRestore' ); + Log('<-TKOLApplet.SetOnRestore'); end; end; procedure TKOLApplet.SetTabulate(const Value: Boolean); begin - Log( '->TKOLApplet.SetTabulate' ); + Log('->TKOLApplet.SetTabulate'); try - FTabulate := Value; - if Value then - FTabulateEx := False; - Change( Self ); - LogOK; + FTabulate := Value; + if Value then + FTabulateEx := False; + Change(Self); + LogOK; finally - Log( '<-TKOLApplet.SetTabulate' ); + Log('<-TKOLApplet.SetTabulate'); end; end; procedure TKOLApplet.SetTabulateEx(const Value: Boolean); begin - Log( '->TKOLApplet.SetTabulateEx' ); + Log('->TKOLApplet.SetTabulateEx'); try - FTabulateEx := Value; - if Value then - FTabulate := False; - Change( Self ); - LogOK; + FTabulateEx := Value; + if Value then + FTabulate := False; + Change(Self); + LogOK; finally - Log( '<-TKOLApplet.SetTabulateEx' ); + Log('<-TKOLApplet.SetTabulateEx'); end; end; procedure TKOLApplet.SetTag(const Value: Integer); begin - Log( '->TKOLApplet.SetTag' ); + Log('->TKOLApplet.SetTag'); try - FTag := Value; - Change( Self ); - LogOK; + FTag := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLApplet.SetTag' ); + Log('<-TKOLApplet.SetTag'); end; end; @@ -11069,22 +9381,21 @@ begin DB 'TKOLApplet.SetVisible', 0 @@e_signature: end; - Log( '->TKOLApplet.SetVisible' ); + Log('->TKOLApplet.SetVisible'); try - if fVisible <> Value then - begin - fVisible := Value; - Change( Self ); - end; - LogOK; + if fVisible <> Value then begin + fVisible := Value; + Change(Self); + end; + LogOK; finally - Log( '<-TKOLApplet.SetVisible' ); + Log('<-TKOLApplet.SetVisible'); end; end; { TKOLForm } -procedure TKOLForm.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLForm.AssignEvents(SL: TStringList; const AName: string); begin asm jmp @@e_signature @@ -11092,83 +9403,82 @@ begin DB 'TKOLForm.AssignEvents', 0 @@e_signature: end; - Log( '->TKOLForm.AssignEvents' ); + Log('->TKOLForm.AssignEvents'); try - if not FLocked then - begin - RptDetailed( 'Enter to TKOLForm.AssignEvents', WHITE ); + if not FLocked then begin + RptDetailed('Enter to TKOLForm.AssignEvents', WHITE); - if (Applet <> nil) and (Applet.Owner = Owner) then - Applet.AssignEvents( SL, 'Applet' ); - //inherited; + if (Applet <> nil) and (Applet.Owner = Owner) then + Applet.AssignEvents(SL, 'Applet'); + //inherited; - DefineFormEvents( - // events marked with '^' can be set immediately following control creation: - // in case of FormCompact = TRUE this gives smaller code since there are less - // calls of FormSetCurCtl. - // --------------------------------------------------------------------------- - [ 'OnMessage: TControl.Set_OnMessage', - 'OnClose:^TControl.SetOnClose,' + IntToStr(idx_fOnMouseDown), - 'OnQueryEndSession:^TControl.SetOnQueryEndSession,' + IntToStr(idx_fOnMouseMove), + DefineFormEvents( + // events marked with '^' can be set immediately following control creation: + // in case of FormCompact = TRUE this gives smaller code since there are less + // calls of FormSetCurCtl. + // --------------------------------------------------------------------------- + ['OnMessage: TControl.Set_OnMessage', + 'OnClose:^TControl.SetOnClose,' + IntToStr(idx_fOnMouseDown), + 'OnQueryEndSession:^TControl.SetOnQueryEndSession,' + IntToStr(idx_fOnMouseMove), - 'OnMinimize:^TControl.SetOnMinMaxRestore,0', - 'OnMaximize:^TControl.SetOnMinMaxRestore,8', - 'OnRestore:^TControl.SetOnMinMaxRestore,16', + 'OnMinimize:^TControl.SetOnMinMaxRestore,0', + 'OnMaximize:^TControl.SetOnMinMaxRestore,8', + 'OnRestore:^TControl.SetOnMinMaxRestore,16', - 'OnFormClick:^TControl.SetFormOnClick', - 'OnMouseDblClk:^TControl.SetOnMouseEvent,' + IntToStr( idx_fOnMouseDblClk ), - 'OnMouseDown:^TControl.SetOnMouseEvent,' + IntToStr( idx_fOnMouseDown ), - 'OnMouseMove:^TControl.SetOnMouseEvent,' + IntToStr( idx_fOnMouseMove ), - 'OnMouseUp:^TControl.SetOnMouseEvent,' + IntToStr( idx_fOnMouseUp ), - 'OnMouseWheel:^TControl.SetOnMouseEvent,' + IntToStr( idx_fOnMouseWheel ), - 'OnMouseEnter:^TControl.SetOnMouseEnter', - 'OnMouseLeave:^TControl.SetOnMouseLeave', + 'OnFormClick:^TControl.SetFormOnClick', + 'OnMouseDblClk:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseDblClk), + 'OnMouseDown:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseDown), + 'OnMouseMove:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseMove), + 'OnMouseUp:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseUp), + 'OnMouseWheel:^TControl.SetOnMouseEvent,' + IntToStr(idx_fOnMouseWheel), + 'OnMouseEnter:^TControl.SetOnMouseEnter', + 'OnMouseLeave:^TControl.SetOnMouseLeave', - 'OnEnter:^TControl.Set_TOnEvent,' + IntToStr( idx_fOnEnter ), - 'OnLeave:^TControl.Set_TOnEvent,' + IntToStr( idx_fOnLeave ), - 'OnKeyDown:^TControl.SetOnKeyDown', - 'OnKeyUp:^TControl.SetOnKeyUp', - 'OnKeyChar:^TControl.SetOnKeyChar', - 'OnResize:^TControl.SetOnResize', - 'OnMove:^TControl.SetOnMove', - 'OnMoving:^TControl.SetOnMoving', - 'OnShow:^TControl.SetOnShow', - 'OnHide:^TControl.SetOnHide', + 'OnEnter:^TControl.Set_TOnEvent,' + IntToStr(idx_fOnEnter), + 'OnLeave:^TControl.Set_TOnEvent,' + IntToStr(idx_fOnLeave), + 'OnKeyDown:^TControl.SetOnKeyDown', + 'OnKeyUp:^TControl.SetOnKeyUp', + 'OnKeyChar:^TControl.SetOnKeyChar', + 'OnResize:^TControl.SetOnResize', + 'OnMove:^TControl.SetOnMove', + 'OnMoving:^TControl.SetOnMoving', + 'OnShow:^TControl.SetOnShow', + 'OnHide:^TControl.SetOnHide', - 'OnPaint:^TControl.SetOnPaint', - 'OnEraseBkgnd:^TControl.SetOnEraseBkgnd', - 'OnDropFiles:^TControl.SetOnDropFiles' - ] ); + 'OnPaint:^TControl.SetOnPaint', + 'OnEraseBkgnd:^TControl.SetOnEraseBkgnd', + 'OnDropFiles:^TControl.SetOnDropFiles' + ]); - DoAssignEvents( SL, AName, [ 'OnMessage', 'OnClose', 'OnQueryEndSession' ], - [ @OnMessage, @ OnClose, @ OnQueryEndSession ] ); - DoAssignEvents( SL, AName, [ 'OnMinimize', 'OnMaximize', 'OnRestore' ], - [ @ OnMinimize, @ OnMaximize, @ OnRestore ] ); - DoAssignEvents( SL, AName, - [ 'OnFormClick', 'OnMouseDblClk', 'OnMouseDown', 'OnMouseMove', 'OnMouseUp', 'OnMouseWheel', 'OnMouseEnter', 'OnMouseLeave' ], - [ @OnClick, @ OnMouseDblClk, @OnMouseDown, @OnMouseMove, @OnMouseUp, @OnMouseWheel, @OnMouseEnter, @OnMouseLeave ] ); - DoAssignEvents( SL, AName, - [ 'OnEnter', 'OnLeave', 'OnKeyDown', 'OnKeyUp', 'OnKeyChar', 'OnResize', 'OnMove', 'OnMoving', 'OnShow', 'OnHide' ], - [ @OnEnter, @OnLeave, @OnKeyDown, @OnKeyUp, @OnKeyChar, @OnResize, @ OnMove, @ OnMoving, @ OnShow, @ OnHide ] ); - DoAssignEvents( SL, AName, - [ 'OnPaint', 'OnEraseBkgnd', 'OnDropFiles' ], - [ @ OnPaint, @ OnEraseBkgnd, @ OnDropFiles ] ); - // This event must be called at last! (and not assigned!) - so do this in SetupLast method. - {DoAssignEvents( SL, AName, - [ 'OnFormCreate' ], - [ @ OnFormCreate ] );} + DoAssignEvents(SL, AName, ['OnMessage', 'OnClose', 'OnQueryEndSession'], + [@OnMessage, @OnClose, @OnQueryEndSession]); + DoAssignEvents(SL, AName, ['OnMinimize', 'OnMaximize', 'OnRestore'], + [@OnMinimize, @OnMaximize, @OnRestore]); + DoAssignEvents(SL, AName, + ['OnFormClick', 'OnMouseDblClk', 'OnMouseDown', 'OnMouseMove', 'OnMouseUp', 'OnMouseWheel', 'OnMouseEnter', 'OnMouseLeave'], + [@OnClick, @OnMouseDblClk, @OnMouseDown, @OnMouseMove, @OnMouseUp, @OnMouseWheel, @OnMouseEnter, @OnMouseLeave]); + DoAssignEvents(SL, AName, + ['OnEnter', 'OnLeave', 'OnKeyDown', 'OnKeyUp', 'OnKeyChar', 'OnResize', 'OnMove', 'OnMoving', 'OnShow', 'OnHide'], + [@OnEnter, @OnLeave, @OnKeyDown, @OnKeyUp, @OnKeyChar, @OnResize, @OnMove, @OnMoving, @OnShow, @OnHide]); + DoAssignEvents(SL, AName, + ['OnPaint', 'OnEraseBkgnd', 'OnDropFiles'], + [@OnPaint, @OnEraseBkgnd, @OnDropFiles]); + // This event must be called at last! (and not assigned!) - so do this in SetupLast method. + {DoAssignEvents( SL, AName, + [ 'OnFormCreate' ], + [ @ OnFormCreate ] );} - DoAssignEvents( SL, AName, - [ 'OnDestroy', 'OnHelp' ], - [ @ OnDestroy, @ OnHelp ] ); - {if Assigned( OnDestroy ) then - SL.Add( ' ' + AName + '.OnDestroy := Result.' + - (Owner as TForm).MethodName( OnFormDestroy ) + ';' );} - RptDetailed( 'Leave TKOLForm.AssignEvents', WHITE ); - end; - LogOK; + DoAssignEvents(SL, AName, + ['OnDestroy', 'OnHelp'], + [@OnDestroy, @OnHelp]); + {if Assigned( OnDestroy ) then + SL.Add( ' ' + AName + '.OnDestroy := Result.' + + (Owner as TForm).MethodName( OnFormDestroy ) + ';' );} + RptDetailed('Leave TKOLForm.AssignEvents', WHITE); + end; + LogOK; finally - Log( '<-TKOLForm.AssignEvents' ); + Log('<-TKOLForm.AssignEvents'); end; end; @@ -11181,42 +9491,44 @@ begin @@e_signature: end; - Log( '->TKOLForm.Change' ); + Log('->TKOLForm.Change'); try if not Assigned(Sender) then - RptDetailed( 'Sender = nil!', YELLOW ) + RptDetailed('Sender = nil!', YELLOW) else - RptDetailed( 'Sender class=' + Sender.ClassName + ' name=' + Sender.Name, YELLOW ); + RptDetailed('Sender class=' + Sender.ClassName + ' name=' + Sender.name, YELLOW); try Rpt_Stack; - except on E: exception do - RptDetailed( 'exception while reporting stack: ' + E.Message, YELLOW ); + except on E: Exception do + RptDetailed('exception while reporting stack: ' + E.Message, YELLOW); end; if not FLocked and not (csLoading in ComponentState) and not FIsDestroying and - (Owner <> nil) and not (csDestroying in Owner.ComponentState) then begin + (Owner <> nil) and not (csDestroying in Owner.ComponentState) then begin //if Creating_DoNotGenerateCode then Exit; if AllowRealign and (FRealigning = 0) and Assigned(FRealignTimer) then begin - FRealignTimer.Enabled := FALSE; - FRealignTimer.Enabled := TRUE; + FRealignTimer.Enabled := False; + FRealignTimer.Enabled := True; end; if Assigned(FChangeTimer) then begin - FChangeTimer.Enabled := FALSE; - FChangeTimer.Enabled := TRUE; - end else if not (csLoading in Sender.ComponentState) then + FChangeTimer.Enabled := False; + FChangeTimer.Enabled := True; + end + else if not (csLoading in Sender.ComponentState) then DoChangeNow; end; LogOK; finally - Log( '<-TKOLForm.Change' ); + Log('<-TKOLForm.Change'); end; end; constructor TKOLForm.Create(AOwner: TComponent); -var I: Integer; - C: TComponent; +var + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -11224,197 +9536,192 @@ begin DB 'TKOLForm.Create', 0 @@e_signature: end; - Log( '->TKOLForm.Create' ); - fCreating := TRUE; + Log('->TKOLForm.Create'); + fCreating := True; try - Log( '?01 TKOLForm.Create' ); + Log('?01 TKOLForm.Create'); - FFontDefault := TRUE; - TRY - FFont := TKOLFont.Create(Self); - EXCEPT - ShowMessage( 'exc create 1' ); - END; - if KOLProject <> nil then - begin - if KOLProject.ProjectDest = '' then - begin - raise Exception.Create( 'You forget to change projectDest property ' + - 'of TKOLProject component!' ); + FFontDefault := True; + try + fFont := TKOLFont.Create(Self); + except + Showmessage('exc create 1'); end; - if KOLProject.DefaultFont <> nil then - TRY - FFont.Assign(KOLProject.DefaultFont); - EXCEPT - ShowMessage( 'exc create 2' ); - END; - end; - - Log( '?02 TKOLForm.Create' ); - inherited; - - Log( '?03 TKOLForm.Create' ); - - //Creating_DoNotGenerateCode := TRUE; - AllowRealign := TRUE; - - Log( '?03.A TKOLForm.Create' ); - - FStatusText := TStringList.Create; - - Log( '?03.B TKOLForm.Create' ); - - FStatusSizeGrip := TRUE; - - Log( '?03.C TKOLForm.Create' ); - - FParentLikeFontControls := TList.Create; - - Log( '?03.D TKOLForm.Create' ); - - FParentLikeColorControls := TList.Create; - //fDefaultPos := True; - //fDefaultSize := True; - - Log( '?03.E TKOLForm.Create' ); - - fCanResize := True; - - Log( '?03.F TKOLForm.Create' ); - - fVisible := True; - - Log( '?03.G TKOLForm.Create' ); - - fAlphaBlend := 255; - - Log( '?03.H TKOLForm.Create' ); - - fEnabled := True; - - Log( '?03.I TKOLForm.Create' ); - - fMinimizeIcon := True; - - Log( '?03.J TKOLForm.Create' ); - - fMaximizeIcon := True; - - Log( '?03.K TKOLForm.Create' ); - - fCloseIcon := True; - - Log( '?03.L TKOLForm.Create' ); - - FborderStyle := fbsSingle; {YS} - - Log( '?03.M TKOLForm.Create' ); - - fHasBorder := True; - - Log( '?03.N TKOLForm.Create' ); - - fHasCaption := True; - - Log( '?03.o TKOLForm.Create' ); - - fCtl3D := True; - - Log( '?03.P TKOLForm.Create' ); - - //AutoCreate := True; - fMargin := 2; - - Log( '?03.Q TKOLForm.Create' ); - - fBounds := TFormBounds.Create; - - Log( '?03.R TKOLForm.Create' ); - - fBounds.Owner := Self; - {fBounds.fL := (Owner as TForm).Left; - fBounds.fT := (Owner as TForm).Top; - fBounds.fW := (Owner as TForm).Width; - fBounds.fH := (Owner as TForm).Height;} - //fBrush := TBrush.Create; - - Log( '?04 TKOLForm.Create' ); - //fFont := TKOLFont.Create( Self ); - fBrush := TKOLBrush.Create( Self ); - - Log( '?05 TKOLForm.Create' ); - - if AOwner <> nil then - begin - Log( '?06 TKOLForm.Create' ); - for I := 0 to AOwner.ComponentCount - 1 do - begin - C := AOwner.Components[ I ]; - if C = Self then Continue; - if IsVCLControl( C ) then - begin - FLocked := TRUE; - ShowMessage( 'The form ' + FormName + ' contains already VCL controls.'#13 + - 'The TKOLForm component is locked now and will not functioning.'#13 + - 'Just delete it and never drop onto forms, beloning to VCL projects.' ); - break; + if KOLProject <> nil then begin + if KOLProject.projectDest = '' then begin + raise Exception.Create('You forget to change projectDest property ' + + 'of TKOLProject component!'); + end; + if KOLProject.DefaultFont <> nil then try + fFont.Assign(KOLProject.DefaultFont); + except + Showmessage('exc create 2'); end; end; - Log( '?07 TKOLForm.Create' ); - if not FLocked then - for I := 0 to AOwner.ComponentCount - 1 do - begin - C := AOwner.Components[ I ]; - if C = Self then Continue; - if C is TKOLForm then - begin - ShowMessage( 'The form ' + FormName + ' contains more then one instance of ' + - 'TKOLForm component. '#13 + - 'This will cause unpredictable results. It is recommended to ' + - 'remove all ambigous instances of TKOLForm component before ' + - 'You launch the project.' ); - break; + + Log('?02 TKOLForm.Create'); + inherited; + + Log('?03 TKOLForm.Create'); + + //Creating_DoNotGenerateCode := TRUE; + AllowRealign := True; + + Log('?03.A TKOLForm.Create'); + + FStatusText := TStringList.Create; + + Log('?03.B TKOLForm.Create'); + + FStatusSizeGrip := True; + + Log('?03.C TKOLForm.Create'); + + FParentLikeFontControls := TList.Create; + + Log('?03.D TKOLForm.Create'); + + FParentLikeColorControls := TList.Create; + //fDefaultPos := True; + //fDefaultSize := True; + + Log('?03.E TKOLForm.Create'); + + fCanResize := True; + + Log('?03.F TKOLForm.Create'); + + fVisible := True; + + Log('?03.G TKOLForm.Create'); + + FAlphaBlend := 255; + + Log('?03.H TKOLForm.Create'); + + fEnabled := True; + + Log('?03.I TKOLForm.Create'); + + FMinimizeIcon := True; + + Log('?03.J TKOLForm.Create'); + + FMaximizeIcon := True; + + Log('?03.K TKOLForm.Create'); + + FCloseIcon := True; + + Log('?03.L TKOLForm.Create'); + + FborderStyle := fbsSingle; {YS} + + Log('?03.M TKOLForm.Create'); + + FHasBorder := True; + + Log('?03.N TKOLForm.Create'); + + FHasCaption := True; + + Log('?03.o TKOLForm.Create'); + + FCtl3D := True; + + Log('?03.P TKOLForm.Create'); + + //AutoCreate := True; + fMargin := 2; + + Log('?03.Q TKOLForm.Create'); + + fBounds := TFormBounds.Create; + + Log('?03.R TKOLForm.Create'); + + fBounds.Owner := Self; + {fBounds.fL := (Owner as TForm).Left; + fBounds.fT := (Owner as TForm).Top; + fBounds.fW := (Owner as TForm).Width; + fBounds.fH := (Owner as TForm).Height;} + //fBrush := TBrush.Create; + + Log('?04 TKOLForm.Create'); + //fFont := TKOLFont.Create( Self ); + fBrush := TKOLBrush.Create(Self); + + Log('?05 TKOLForm.Create'); + + if AOwner <> nil then begin + Log('?06 TKOLForm.Create'); + for I := 0 to AOwner.ComponentCount - 1 do begin + c := AOwner.Components[I]; + if c = Self then + Continue; + if IsVCLControl(c) then begin + FLocked := True; + Showmessage('The form ' + formName + ' contains already VCL controls.'#13 + + 'The TKOLForm component is locked now and will not functioning.'#13 + + 'Just delete it and never drop onto forms, beloning to VCL projects.'); + Break; + end; end; + Log('?07 TKOLForm.Create'); + if not FLocked then + for I := 0 to AOwner.ComponentCount - 1 do begin + c := AOwner.Components[I]; + if c = Self then + Continue; + if c is TKOLForm then begin + Showmessage('The form ' + formName + ' contains more then one instance of ' + + 'TKOLForm component. '#13 + + 'This will cause unpredictable results. It is recommended to ' + + 'remove all ambigous instances of TKOLForm component before ' + + 'You launch the project.'); + Break; + end; + end; + Log('?08 TKOLForm.Create'); end; - Log('?08 TKOLForm.Create'); - end; - if FormsList = nil then - FormsList := TList.Create; - Log( '?09 TKOLForm.Create' ); - FormsList.Add( Self ); - if not (csLoading in ComponentState) then - if Caption = '' then - Caption := FormName; - Log( '?10 TKOLForm.Create' ); - (Owner as TForm).Scaled := FALSE; - (Owner as TForm).HorzScrollBar.Visible := FALSE; - (Owner as TForm).VertScrollBar.Visible := FALSE; - Log( '?11 TKOLForm.Create' ); - FRealignTimer := TTimer.Create( Self ); - FRealignTimer.Interval := 50; - FRealignTimer.OnTimer := RealignTimerTick; - Log( '?12 TKOLForm.Create' ); - FChangeTimer := TTimer.Create( Self ); - FChangeTimer.OnTimer := ChangeTimerTick; - FChangeTimer.Enabled := FALSE; - FChangeTimer.Interval := 100; - Log( '?13 TKOLForm.Create' ); - if not (csLoading in ComponentState) then - FRealignTimer.Enabled := TRUE; - fAssignTextToControls := TRUE; - Log( '?14 TKOLForm.Create' ); - LogOK; + if FormsList = nil then + FormsList := TList.Create; + Log('?09 TKOLForm.Create'); + FormsList.Add(Self); + if not (csLoading in ComponentState) then + if Caption = '' then + Caption := formName; + Log('?10 TKOLForm.Create'); + (Owner as TForm).Scaled := False; + (Owner as TForm).HorzScrollBar.Visible := False; + (Owner as TForm).VertScrollBar.Visible := False; + Log('?11 TKOLForm.Create'); + FRealignTimer := TTimer.Create(Self); + FRealignTimer.Interval := 50; + FRealignTimer.OnTimer := RealignTimerTick; + Log('?12 TKOLForm.Create'); + FChangeTimer := TTimer.Create(Self); + FChangeTimer.OnTimer := ChangeTimerTick; + FChangeTimer.Enabled := False; + FChangeTimer.Interval := 100; + Log('?13 TKOLForm.Create'); + if not (csLoading in ComponentState) then + FRealignTimer.Enabled := True; + fAssignTextToControls := True; + Log('?14 TKOLForm.Create'); + LogOK; finally - Log( '<-TKOLForm.Create' ); - //Creating_DoNotGenerateCode := FALSE; - FChanged := FALSE; - fCreating := FALSE; + Log('<-TKOLForm.Create'); + //Creating_DoNotGenerateCode := FALSE; + FChanged := False; + fCreating := False; end; end; destructor TKOLForm.Destroy; -var I: Integer; +var + I: Integer; begin asm jmp @@e_signature @@ -11422,43 +9729,41 @@ begin DB 'TKOLForm.Destroy', 0 @@e_signature: end; - Log( '->TKOLForm.Destroy' ); - FIsDestroying := TRUE; + Log('->TKOLForm.Destroy'); + FIsDestroying := True; try - if bounds <> nil then - bounds.EnableTimer( FALSE ); - AllowRealign := FALSE; - fBounds.Free; - if FormsList <> nil then - begin - I := FormsList.IndexOf( Self ); - if I >= 0 then - begin - FormsList.Delete( I ); - if FormsList.Count = 0 then - begin - FormsList.Free; - FormsList := nil; + if bounds <> nil then + bounds.EnableTimer(False); + AllowRealign := False; + fBounds.free; + if FormsList <> nil then begin + I := FormsList.IndexOf(Self); + if I >= 0 then begin + FormsList.Delete(I); + if FormsList.Count = 0 then begin + FormsList.free; + FormsList := nil; + end; end; end; - end; - fFont.Free; - FParentLikeFontControls.Free; - FParentLikeColorControls.Free; - FStatusText.Free; - ResStrings.Free; - FreeAndNil( FFormAlphabet ); - FreeAndNil( FFormCtlParams ); - inherited; - LogOK; + fFont.free; + FParentLikeFontControls.free; + FParentLikeColorControls.free; + FStatusText.free; + ResStrings.free; + FreeAndNil(FFormAlphabet); + FreeAndNil(FFormCtlParams); + inherited; + LogOK; finally - Log( '<-TKOLForm.Destroy' ); + Log('<-TKOLForm.Destroy'); end; end; -procedure SwapItems( Data: Pointer; const e1, e2: DWORD ); -var Tmp: Pointer; - L: TList; +procedure SwapItems(Data: Pointer; const e1, e2: DWORD); +var + Tmp: Pointer; + L: TList; begin asm jmp @@e_signature @@ -11467,24 +9772,28 @@ begin @@e_signature: end; L := Data; - Tmp := L.Items[ e1 ]; - L.Items[ e1 ] := L.Items[ e2 ]; - L.Items[ e2 ] := Tmp; + Tmp := L.Items[e1]; + L.Items[e1] := L.Items[e2]; + L.Items[e2] := Tmp; //Rpt( IntToStr( e1 ) + '<-->' + IntToStr( e2 ) ); end; -function CompareControls( Data: Pointer; const e1, e2: DWORD ): Integer; -const Signs: array[ -1..1 ] of AnsiChar = ( '<', '=', '>' ); -var K1, K2: TKOLCustomControl; - L: TList; - function CompareInt( X, Y: Integer ): Integer; - begin - if X < Y then Result := -1 - else - if X > Y then Result := 1 - else +function CompareControls(Data: Pointer; const e1, e2: DWORD): Integer; +const + Signs: array[-1..1] of AnsiChar = ('<', '=', '>'); +var + K1, K2: TKOLCustomControl; + L: TList; + + function CompareInt(X, Y: Integer): Integer; + begin + if X < Y then + Result := -1 + else if X > Y then + Result := 1 + else Result := 0; - end; + end; begin asm jmp @@e_signature @@ -11493,44 +9802,45 @@ begin @@e_signature: end; L := Data; - K1 := L.Items[ e1 ]; - K2 := L.Items[ e2 ]; + K1 := L.Items[e1]; + K2 := L.Items[e2]; Result := 0; if K1.Align = K2.Align then - case K1.Align of - caLeft: Result := CompareInt( K1.Left, K2.Left ); - caTop: Result := CompareInt( K1.Top, K2.Top ); - caRight:Result := CompareInt( K2.Left, K1.Left ); - caBottom: Result := CompareInt( K2.Top, K1.Top ); - caClient: Result := CompareInt( K1.ControlIndex, - K1.ControlIndex ); - end; + case K1.Align of + caLeft: Result := CompareInt(K1.Left, K2.Left); + caTop: Result := CompareInt(K1.Top, K2.Top); + caRight: Result := CompareInt(K2.Left, K1.Left); + caBottom: Result := CompareInt(K2.Top, K1.Top); + caClient: Result := CompareInt(K1.ControlIndex, + K1.ControlIndex); + end; if Result = 0 then - Result := CompareInt( K1.TabOrder, K2.TabOrder ); + Result := CompareInt(K1.TabOrder, K2.TabOrder); if Result = 0 then - Result := AnsiCompareStr( K1.Name, K2.Name ); + Result := AnsiCompareStr(K1.name, K2.name); //Rpt( 'Compare ' + K1.Name + '.' + IntToStr( K1.TabOrder ) + ' ' + Signs[ Result ] + ' ' + // K2.Name + '.' + IntToStr( K2.TabOrder ) ); end; const {$IFDEF VER90} - {$DEFINE offDefined} +{$DEFINE offDefined} offCreate = $24; {$ENDIF} {$IFDEF VER100} - {$DEFINE offDefined} +{$DEFINE offDefined} offCreate = $24; {$ENDIF} {$IFNDEF offDefined} offCreate = $2C; {$ENDIF} -// Данная функция конструирует и возвращает компонент того же класса, что -// и компонент, переданный в качестве параметра. Для конструирования вызывается -// виртуальный коструктор компонента (смещение точки входа в vmt зависит от -// версии Delphi). -function ComponentLike( C: TComponent ): TComponent; + // Данная функция конструирует и возвращает компонент того же класса, что + // и компонент, переданный в качестве параметра. Для конструирования вызывается + // виртуальный коструктор компонента (смещение точки входа в vmt зависит от + // версии Delphi). + +function ComponentLike(c: TComponent): TComponent; asm xor ecx, ecx mov dl,1 @@ -11538,7 +9848,7 @@ asm call dword ptr [eax+offCreate] end; -function Comma2Pt( const S: String ): String; +function Comma2Pt(const s: string): string; begin asm jmp @@e_signature @@ -11546,12 +9856,12 @@ begin DB 'Comma2Pt', 0 @@e_signature: end; - Result := S; - while pos( ',', Result ) > 0 do - Result[ pos( ',', Result ) ] := '.'; + Result := s; + while Pos(',', Result) > 0 do + Result[Pos(',', Result)] := '.'; end; -function Bool2Str( const S: String ): String; +function Bool2Str(const s: string): string; begin asm jmp @@e_signature @@ -11559,33 +9869,37 @@ begin DB 'Bool2Str', 0 @@e_signature: end; - if S = '0' then Result := 'FALSE' - else Result := 'TRUE'; + if s = '0' then + Result := 'FALSE' + else + Result := 'TRUE'; end; // Данная функция возвращает значение публикуемого свойства компонента в виде // строки, которую можно вставить в текст программы в правую часть присваивания // значения этому свойству. -function PropValueAsStr( C: TComponent; const PropName: String; PI: PPropInfo; SL: TStringList ): String; - function StringConstant( const Propname, Value: String ): String; +function PropValueAsStr(c: TComponent; const Propname: string; PI: PPropInfo; SL: TStringList): string; + + function StringConstant(const Propname, Value: string): string; begin - if C is TKOLForm then - Result := (C as TKOLForm).StringConstant( Propname, Value ) - else if C is TKOLObj then - Result := (C as TKOLObj).StringConstant( Propname, Value ) - else if C is TKOLCustomControl then - Result := (C as TKOLCustomControl).StringConstant( Propname, Value ) + if c is TKOLForm then + Result := (c as TKOLForm).StringConstant(Propname, Value) + else if c is TKOLObj then + Result := (c as TKOLObj).StringConstant(Propname, Value) + else if c is TKOLCustomControl then + Result := (c as TKOLCustomControl).StringConstant(Propname, Value) else - Result := String2Pascal( Value, '+' ); + Result := String2Pascal(Value, '+'); end; -var PropValue: String; - V: Variant; - Method: TMethod; - Ch: AnsiChar; - Wc: WChar; - S: String; +var + PropValue: string; + V: Variant; + Method: TMethod; + Ch: AnsiChar; + Wc: WChar; + s: string; begin asm jmp @@e_signature @@ -11596,85 +9910,80 @@ begin PropValue := ''; Result := ''; case PI.PropType^.Kind of - tkVariant: - begin - try - V := //GetPropValue( C, PropName, TRUE ); - GetVariantProp( C, PI ); - case VarType( V ) of - varEmpty: PropValue := 'UnAssigned'; - varNull: PropValue := 'NULL'; - varSmallInt: PropValue := 'VarAsType( ' + VarToStr( V ) + ', varSmallInt )'; - varInteger: PropValue := IntToStr( V.AsInteger ); - varSingle: PropValue := 'VarAsType( ' + Comma2Pt( VarToStr( V ) ) + ', varSingle )'; - varDouble: PropValue := 'VarAsType( ' + Comma2Pt( VarToStr( V ) ) + ', varDouble )'; - varCurrency: PropValue := 'VarAsType( ' + Comma2Pt( VarToStr( V ) ) + ', varCurrency )'; - varDate: PropValue := 'VarAsType( ' + Comma2Pt( VarToStr( VarAsType( V, varDouble ) ) ) + ', varDate )'; - varByte: PropValue := 'VarAsByte( ' + VarToStr( V ) + ' )'; - //varOLEStr: PropValue := 'VarAsType( ' + String2Pascal( VarToStr( V ) ) + ', varOLEStr )'; - varOLEStr: PropValue := 'VarAsType( ' + PCharStringConstant( C, Propname, VarToStr( V ) ) + ', varOLEStr )'; - //varString: PropValue := String2Pascal( VarToStr( V ) ); - varString: PropValue := StringConstant( Propname, VarToStr( V ) ); - varBoolean: PropValue := Bool2Str( VarToStr( V ) ); - else - begin - SL.Add( ' //----!!!---- Can not assign variant property ----!!!----' ); - Exit; - end; + tkVariant: begin + try + V := //GetPropValue( C, PropName, TRUE ); + GetVariantProp(c, PI); + case VarType(V) of + varEmpty: PropValue := 'UnAssigned'; + varNull: PropValue := 'NULL'; + varSmallInt: PropValue := 'VarAsType( ' + VarToStr(V) + ', varSmallInt )'; + varInteger: PropValue := IntToStr(V.AsInteger); + varSingle: PropValue := 'VarAsType( ' + Comma2Pt(VarToStr(V)) + ', varSingle )'; + varDouble: PropValue := 'VarAsType( ' + Comma2Pt(VarToStr(V)) + ', varDouble )'; + varCurrency: PropValue := 'VarAsType( ' + Comma2Pt(VarToStr(V)) + ', varCurrency )'; + varDate: PropValue := 'VarAsType( ' + Comma2Pt(VarToStr(VarAsType(V, varDouble))) + ', varDate )'; + varByte: PropValue := 'VarAsByte( ' + VarToStr(V) + ' )'; + //varOLEStr: PropValue := 'VarAsType( ' + String2Pascal( VarToStr( V ) ) + ', varOLEStr )'; + varOLEStr: PropValue := 'VarAsType( ' + PCharStringConstant(c, Propname, VarToStr(V)) + ', varOLEStr )'; + //varString: PropValue := String2Pascal( VarToStr( V ) ); + varString: PropValue := StringConstant(Propname, VarToStr(V)); + varBoolean: PropValue := Bool2Str(VarToStr(V)); + else begin + SL.Add(' //----!!!---- Can not assign variant property ----!!!----'); + Exit; + end; + end; + except + SL.Add(' //-----^----- Error getting variant value') + end; end; - except - SL.Add( ' //-----^----- Error getting variant value' ) - end; - end; - tkString, tkLString, tkWString: - try - PropValue := StringConstant( Propname, GetStrProp( C, PropName ) ); - except - PropValue := ''; - SL.Add( ' //----^---- Cannot obtain string property ' + PropName + - '. May be, it is write-only.' ); - raise; - end; - tkChar: - begin - Ch := AnsiChar( GetOrdProp( C, PropName ) ); - if Ch in [ ' '..#127 ] then - PropValue := '''' + Ch + '''' - else - PropValue := '#' + IntToStr( Ord( Ch ) ); - end; - tkWChar: - begin - Wc := WChar( GetOrdProp( C, PropName ) ); - if (Wc >= WChar(' ')) and (Wc <= WChar(#127)) then - PropValue := '''' + AnsiChar( Wc ) + '''' - else - PropValue := 'WChar( ' + IntToStr( Ord( Wc ) ) + ' )'; - end; - tkMethod: - begin - Method := GetMethodProp( C, PropName ); - if not Assigned( Method.Code ) then - Exit; - if C.Owner <> nil then - if C.Owner is TForm then - PropValue := 'Result.' + C.Owner.MethodName( Method.Code ); - end; - tkInteger: PropValue := IntToStr( GetOrdProp( C, PropName ) ); - tkEnumeration: PropValue := GetEnumProp( C, PI ); - tkFloat: begin - S := FloatToStr( GetFloatProp( C, PI ) ); - while pos( ',', S ) > 0 do - S[ pos( ',', S ) ] := '.'; - PropValue := S; - end; - tkSet: PropValue := GetSetProp( C, PI, TRUE ); - tkInt64: PropValue := IntToStr( GetInt64Prop( C, PI ) ); + tkString, tkLString, tkWString: try + PropValue := StringConstant(Propname, GetStrProp(c, Propname)); + except + PropValue := ''; + SL.Add(' //----^---- Cannot obtain string property ' + Propname + + '. May be, it is write-only.'); + raise; + end; + tkChar: begin + Ch := AnsiChar(GetOrdProp(c, Propname)); + if Ch in [' '..#127] then + PropValue := '''' + Ch + '''' + else + PropValue := '#' + IntToStr(Ord(Ch)); + end; + tkWChar: begin + Wc := WChar(GetOrdProp(c, Propname)); + if (Wc >= WChar(' ')) and (Wc <= WChar(#127)) then + PropValue := '''' + AnsiChar(Wc) + '''' + else + PropValue := 'WChar( ' + IntToStr(Ord(Wc)) + ' )'; + end; + tkMethod: begin + Method := GetMethodProp(c, Propname); + if not Assigned(Method.Code) then + Exit; + if c.Owner <> nil then + if c.Owner is TForm then + PropValue := 'Result.' + c.Owner.MethodName(Method.Code); + end; + tkInteger: PropValue := IntToStr(GetOrdProp(c, Propname)); + tkEnumeration: PropValue := GetEnumProp(c, PI); + tkFloat: begin + s := FloatToStr(GetFloatProp(c, PI)); + while Pos(',', s) > 0 do + s[Pos(',', s)] := '.'; + PropValue := s; + end; + tkSet: PropValue := GetSetProp(c, PI, True); + tkInt64: PropValue := IntToStr(GetInt64Prop(c, PI)); tkUnknown: begin - SL.Add( ' //-----?----- property type tkUnknown' ); - Exit; - end; - else Exit; + SL.Add(' //-----?----- property type tkUnknown'); + Exit; + end; + else + Exit; end; Result := PropValue; end; @@ -11688,13 +9997,15 @@ end; // настроенный в design-time на форме MCK-проекта. Устанавливаются все публичные // свойства, отличающиеся своим значением от тех, которые назначаются по умолчанию // в конструкторе объекта. -function ConstructComponent( SL: TStringList; C: TComponent ): Boolean; -var Props, PropsD: PPropList; - NProps, NPropsD, I, J: Integer; - PropName, PropValue, PropValueD: String; - PI, DPI: PPropInfo; - D: TComponent; - WasError: Boolean; + +function ConstructComponent(SL: TStringList; c: TComponent): Boolean; +var + Props, PropsD: PPropList; + NProps, NPropsD, I, j: Integer; + Propname, PropValue, PropValueD: string; + PI, DPI: PPropInfo; + D: TComponent; + WasError: Boolean; begin asm jmp @@e_signature @@ -11702,90 +10013,86 @@ begin DB 'ConstructComponent', 0 @@e_signature: end; - Result := FALSE; + Result := False; //SL.Add( ' Result.' + C.Name + ' := ' + C.ClassName + '.Create( nil );' ); - if C is TOleControl then - SL.Add( ' Result.' + C.Name + - '.ParentWindow := Result.Form.GetWindowHandle;' ); + if c is TOleControl then + SL.Add(' Result.' + c.name + + '.ParentWindow := Result.Form.GetWindowHandle;'); D := nil; - GetMem( Props, Sizeof( TPropList ) ); - GetMem( PropsD, Sizeof( TPropList ) ); + GetMem(Props, Sizeof(TPropList)); + GetMem(PropsD, Sizeof(TPropList)); try - try - NProps := GetPropList( C.ClassInfo, tkAny, Props ); - for I := 0 to NProps-1 do - begin - if Props[I].Name = 'NotConstruct_KOLMCK' then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - SL.Add( ' //-- found ' + IntToStr( NProps ) + ' published props' ); - if NProps > 0 then - BEGIN - D := ComponentLike( C ); - NPropsD := GetPropList( C.ClassInfo, tkAny, PropsD ); - for I := 0 to NProps-1 do - begin - PI := Props[ I ]; - PropName := String( PI.Name ); - DPI := nil; - for J := 0 to NPropsD-1 do - begin - DPI := PropsD[ J ]; - if PropName = String( DPI.Name ) then break; - DPI := nil; - end; - - SL.Add( ' // ' + IntToStr( I ) + ': ' + PropName ); - //if not IsStoredProp( C, PropName ) then continue; - PropValueD := ''; - WasError := FALSE; - try - if DPI <> nil then - if DPI.PropType^.Kind = PI.PropType^.Kind then - PropValueD := PropValueAsStr( D, PropName, DPI, SL ); - PropValue := PropValueAsStr( C, PropName, PI, SL ); - if (DPI = nil) or (PropValue <> PropValueD) then - SL.Add( ' Result.' + C.Name + '.' + PropName + ' := ' + - PropValue + ';' ); - except - WasError := TRUE; - end; - if WasError then - try - if DPI <> nil then - if DPI.PropType^.Kind = PI.PropType^.Kind then - begin - PropValueD := PropValueAsStr( D, PropName, DPI, SL ); - SL.Add( ' //Default: ' + PropName + '=' + PropValueD ); - end; - PropValue := PropValueAsStr( C, PropName, PI, SL ); - SL.Add( ' //Actual : ' + PropName + '=' + PropValue ); - if (DPI = nil) or (PropValue <> PropValueD) then - SL.Add( ' Result.' + C.Name + '.' + PropName + ' := ' + - PropValue + ';' ); - except - SL.Add( ' //-----^------Exception while getting propery ' + - PropName + ' of ' + C.Name ); - end; + try + NProps := GetPropList(c.ClassInfo, tkAny, Props); + for I := 0 to NProps - 1 do begin + if Props[I].name = 'NotConstruct_KOLMCK' then + Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} end; - END; - finally - FreeMem( Props ); - FreeMem( PropsD ); - D.Free; - end; + SL.Add(' //-- found ' + IntToStr(NProps) + ' published props'); + if NProps > 0 then begin + D := ComponentLike(c); + NPropsD := GetPropList(c.ClassInfo, tkAny, PropsD); + for I := 0 to NProps - 1 do begin + PI := Props[I]; + Propname := string(PI.name); + DPI := nil; + for j := 0 to NPropsD - 1 do begin + DPI := PropsD[j]; + if Propname = string(DPI.name) then + Break; + DPI := nil; + end; + + SL.Add(' // ' + IntToStr(I) + ': ' + Propname); + //if not IsStoredProp( C, PropName ) then continue; + PropValueD := ''; + WasError := False; + try + if DPI <> nil then + if DPI.PropType^.Kind = PI.PropType^.Kind then + PropValueD := PropValueAsStr(D, Propname, DPI, SL); + PropValue := PropValueAsStr(c, Propname, PI, SL); + if (DPI = nil) or (PropValue <> PropValueD) then + SL.Add(' Result.' + c.name + '.' + Propname + ' := ' + + PropValue + ';'); + except + WasError := True; + end; + if WasError then try + if DPI <> nil then + if DPI.PropType^.Kind = PI.PropType^.Kind then begin + PropValueD := PropValueAsStr(D, Propname, DPI, SL); + SL.Add(' //Default: ' + Propname + '=' + PropValueD); + end; + PropValue := PropValueAsStr(c, Propname, PI, SL); + SL.Add(' //Actual : ' + Propname + '=' + PropValue); + if (DPI = nil) or (PropValue <> PropValueD) then + SL.Add(' Result.' + c.name + '.' + Propname + ' := ' + + PropValue + ';'); + except + SL.Add(' //-----^------Exception while getting propery ' + + Propname + ' of ' + c.name); + end; + end; + end; + finally + FreeMem(Props); + FreeMem(PropsD); + D.free; + end; except - SL.Add( ' //-----^------Exception while getting properties of ' + C.Name ); + SL.Add(' //-----^------Exception while getting properties of ' + c.name); end; - Result := TRUE; + Result := True; end; -procedure TKOLForm.GenerateChildren( SL: TStringList; OfParent: TComponent; const OfParentName: String; const Prefix: String; - var Updated: Boolean ); -var I, J: Integer; - L: TList; - S: String; - KC: TKOLCustomControl; +procedure TKOLForm.GenerateChildren(SL: TStringList; OfParent: TComponent; const OfParentName: string; const Prefix: string; + var Updated: Boolean); +var + I: Integer; + L: TList; + s: string; + KC: TKOLCustomControl; begin asm jmp @@e_signature @@ -11793,177 +10100,63 @@ begin DB 'TKOLForm.GenerateChildren', 0 @@e_signature: end; - Log( '->TKOLForm.GenerateChildren' ); + Log('->TKOLForm.GenerateChildren'); try - L := TList.Create; - try - for I := 0 to Owner.ComponentCount - 1 do - begin - if Owner.Components[ I ] is TKOLCustomControl then - if (Owner.Components[ I ] as TKOLCustomControl).ParentKOLControl = OfParent then - begin - KC := Owner.Components[ I ] as TKOLCustomControl; - L.Add( KC ); - end; - end; - SortData( L, L.Count, @CompareControls, @SwapItems ); - for I := 0 to L.Count - 1 do - begin - KC := L.Items[ I ]; - KC.fUpdated := FALSE; - KC.FNameSetuped := FALSE; - end; - for I := 0 to L.Count - 1 do - begin - KC := L.Items[ I ]; - RptDetailed( 'generating code for ' + KC.Name, WHITE ); - //SL.Add( ' // ' + KC.RefName + '.TabOrder = ' + IntToStr( KC.TabOrder ) ); - // обеспечить правильный родительский контрол, если он изменился - if FormCompact then - begin - if KC.Parent is TCustomForm then - begin - if (FormCurrentParentCtl <> nil) and - ((FormCurrentParentCtl.Parent <> nil) - and not (FormCurrentParentCtl.Parent is TCustomForm)) - or FormFlushedCompact then - begin - FormAddCtlCommand( '', 'FormSetCurCtl', '' ); - FormAddNumParameter( 0 ); - FormAddCtlCommand( '', 'FormLastCreatedChildAsNewCurrentParent', '' ); - FormCurrentParentCtl := nil; - FormCurrentParent := ''; - end else - begin - RptDetailed( 'searching parent form to set as FormCurrentParent', WHITE ); - while FormCurrentParentCtl <> nil do - begin - FormAddCtlCommand( '', 'FormSetUpperParent', '' ); - if (FormCurrentParentCtl.Parent is TCustomForm) then - begin - FormCurrentParentCtl := nil; - FormCurrentParent := ''; - end - else - begin - FormCurrentParentCtl := (FormCurrentParentCtl.Parent as TKOLControl); - FormCurrentParent := FormCurrentParentCtl.Name; - end; - end; - end; - end else - if (KC.Parent is TKOLTabPage) and (KC.Parent.Parent is TKOLTabControl) then - begin - if FormCurrentParent <> KC.Parent.Name then - begin - RptDetailed( 'searching parent tab page to set as FormCurrentParent', WHITE ); - RptDetailed( 'Current parent name: ' + FormCurrentParent + - ', wanted: ' + KC.Parent.Name, WHITE ); - if FormCurrentCtlForTransparentCalls <> KC.Parent.Parent.Name then - begin - RptDetailed( 'setting up ' + KC.Parent.Parent.Name + - ' as current control', WHITE ); - FormAddCtlCommand( '', 'FormSetCurCtl', '' ); - FormAddNumParameter( FormIndexOfControl( KC.Parent.Parent.Name ) ); - FormCurrentCtlForTransparentCalls := KC.Parent.Parent.Name; - RptDetailed( 'successfully set up ' + KC.Parent.Parent.Name + - ' as current control', WHITE ); - end; - FormAddCtlCommand( '', 'FormSetTabpageAsParent', '' ); - J := (KC.Parent.Parent as TKOLTabControl).IndexOfPage( - KC.Parent.Name ); - FormAddNumParameter( J ); - FormCurrentParent := KC.Parent.Name; - FormCurrentParentCtl := KC.Parent as TKOLCustomControl; - end; - end else - if (KC.Parent <> FormCurrentParentCtl) or FormFlushedCompact then - begin - RptDetailed( 'searching parent control to set as FormCurrentParent', WHITE ); - RptDetailed( KC.Parent.Name, WHITE ); - if FormFlushedCompact then - begin - FormAddCtlCommand( '', 'FormSetCurCtl', '' ); - FormAddNumParameter( FormIndexOfControl( KC.Parent.Name ) ); - FormAddCtlCommand( '', 'FormLastCreatedChildAsNewCurrentParent', '' ); - FormCurrentParentCtl := KC.Parent as TKOLCustomControl; - FormCurrentParent := KC.Parent.Name; - end else - while (KC.Parent <> FormCurrentParentCtl) and - (FormCurrentParentCtl <> nil) do - begin - FormAddCtlCommand( '', 'FormSetUpperParent', '' ); - if (FormCurrentParentCtl.Parent is TCustomForm) then - begin - FormCurrentParentCtl := nil; - FormCurrentParent := ''; - end - else - begin - FormCurrentParentCtl := (FormCurrentParentCtl.Parent as TKOLControl); - FormCurrentParent := FormCurrentParentCtl.Name; - end; - end; + L := TList.Create; + try + for I := 0 to Owner.ComponentCount - 1 do begin + if Owner.Components[I] is TKOLCustomControl then + if (Owner.Components[I] as TKOLCustomControl).ParentKOLControl = OfParent then begin + KC := Owner.Components[I] as TKOLCustomControl; + L.Add(KC); end; end; - if OfParent is TKOLCustomControl then + SortData(L, L.Count, @CompareControls, @SwapItems); + for I := 0 to L.Count - 1 do begin + KC := L.Items[I]; + KC.fUpdated := False; + KC.FNameSetuped := False; + end; + for I := 0 to L.Count - 1 do begin + KC := L.Items[I]; + RptDetailed('generating code for ' + KC.name, WHITE); + //SL.Add( ' // ' + KC.RefName + '.TabOrder = ' + IntToStr( KC.TabOrder ) ); + if OfParent is TKOLCustomControl then KC.fCreationOrder := (OfParent as TKOLCustomControl).fOrderChild - else + else KC.fCreationOrder := fOrderControl; - KC.SetupFirst( SL, KC.RefName, OfParentName, Prefix ); - if KC.TabStop then - begin - if OfParent is TKOLCustomControl then - inc( (OfParent as TKOLCustomControl).fOrderChild ) + KC.SetupFirst(SL, KC.RefName, OfParentName, Prefix); + if KC.TabStop then begin + if OfParent is TKOLCustomControl then + Inc((OfParent as TKOLCustomControl).fOrderChild) else - inc( fOrderControl ); - end; - KC.SetupName( SL, KC.RefName, OfParentName, Prefix ); // на случай, если - // SetupFirst переопределена, и SetupName не вызвана - if FormCompact then - begin - KC.FAssignOnlyUserEvents := TRUE; - KC.AssignEvents( SL, KC.RefName ); - KC.FAssignOnlyUserEvents := FALSE; - end; - if FormCompact and KC.SupportsFormCompact then - //--// - else - GenerateAdd2AutoFree( SL, KC.RefName, TRUE, '', KC ); - S := KC.RefName; - if (KC.ControlCount > 0) then - begin - if FormCompact then - begin - if not (KC is TKOLTabPage) - and not (KC is TKOLTabControl) then - begin - FormAddAlphabet( 'FormLastCreatedChildAsNewCurrentParent', FALSE, TRUE, '' ); - FormCurrentParent := KC.Name; - FormCurrentParentCtl := KC; - end; - end; - GenerateChildren( SL, KC, S, Prefix + ' ', Updated ); - RptDetailed( 'children generated for ' + KC.Name, WHITE ); - end; - if KC.fUpdated then - begin - Updated := TRUE; - Rpt( 'updated TKOLForm', WHITE ); + Inc(fOrderControl); + end; + KC.SetupName(SL, KC.RefName, OfParentName, Prefix); // на случай, если SetupFirst переопределена, и SetupName не вызвана + GenerateAdd2AutoFree(SL, KC.RefName, True, '', KC); + s := KC.RefName; + if (KC.ControlCount > 0) then begin + GenerateChildren(SL, KC, s, Prefix + ' ', Updated); + RptDetailed('children generated for ' + KC.name, WHITE); + end; + if KC.fUpdated then begin + Updated := True; + Rpt('updated TKOLForm', WHITE); + end; end; + finally + L.free; end; + LogOK; finally - L.Free; - end; - LogOK; - finally - Log( '<-TKOLForm.GenerateChildren' ); + Log('<-TKOLForm.GenerateChildren'); end; end; function TKOLForm.AppletOnForm: Boolean; -var I: Integer; - F: TForm; +var + I: Integer; + F: TForm; begin asm jmp @@e_signature @@ -11971,31 +10164,30 @@ begin DB 'TKOLForm.AppletOnForm', 0 @@e_signature: end; - Log( '->TKOLForm.AppletOnForm' ); + Log('->TKOLForm.AppletOnForm'); try - Result := FALSE; - if Owner <> nil then - begin - F := Owner as TForm; - for I := 0 to F.ComponentCount - 1 do - if F.Components[ I ].ClassNameIs( 'TKOLApplet' ) then - begin - Result := TRUE; - break; - end; - end; - LogOK; + Result := False; + if Owner <> nil then begin + F := Owner as TForm; + for I := 0 to F.ComponentCount - 1 do + if F.Components[I].ClassNameIs('TKOLApplet') then begin + Result := True; + Break; + end; + end; + LogOK; finally - Log( '<-TKOLForm.AppletOnForm' ); + Log('<-TKOLForm.AppletOnForm'); end; end; -function CompareComponentOrder( const AList : Pointer; const e1, e2 : DWORD ) : Integer; -var OC: TList; - C1, C2: TComponent; - S: String; - B: Boolean; - K1, K2: TKOLCustomControl; +function CompareComponentOrder(const AList: Pointer; const e1, e2: DWORD): Integer; +var + OC: TList; + C1, C2: TComponent; + s: string; + B: Boolean; + K1, K2: TKOLCustomControl; begin asm jmp @@e_signature @@ -12004,53 +10196,49 @@ begin @@e_signature: end; OC := AList; - C1 := OC[ e1 ]; - C2 := OC[ e2 ]; + C1 := OC[e1]; + C2 := OC[e2]; Result := 0; - if (C1 is TKOLObj) and (C2 is TKOLObj) then - begin + if (C1 is TKOLObj) and (C2 is TKOLObj) then begin if (C1 as TKOLObj).CreationPriority <> (C2 as TKOLObj).CreationPriority then - Result := CmpInts( (C1 as TKOLObj).CreationPriority, - (C2 as TKOLObj).CreationPriority ); + Result := CmpInts((C1 as TKOLObj).CreationPriority, + (C2 as TKOLObj).CreationPriority); end; if Result = 0 then - if ((C1 is TKOLObj) or (C1 is TKOLCustomControl)) and - ((C2 is TKOLObj) or (C2 is TKOLCustomControl)) then - begin - if C2 is TKOLObj then - S := (C2 as TKOLObj).TypeName - else - S := (C2 as TKOLCustomControl).TypeName; - if C1 is TKOLObj then - B := (C1 as TKOLObj).CompareFirst( S, C2.Name ) - else - B := (C1 as TKOLCustomControl).CompareFirst( S, C2.Name ); - if B then Result := 1; - end; - if Result = 0 then - begin - if (C1 is TKOLCustomControl) and (C2 is TKOLCustomControl) then - begin + if ((C1 is TKOLObj) or (C1 is TKOLCustomControl)) and + ((C2 is TKOLObj) or (C2 is TKOLCustomControl)) then begin + if C2 is TKOLObj then + s := (C2 as TKOLObj).TypeName + else + s := (C2 as TKOLCustomControl).TypeName; + if C1 is TKOLObj then + B := (C1 as TKOLObj).CompareFirst(s, C2.name) + else + B := (C1 as TKOLCustomControl).CompareFirst(s, C2.name); + if B then + Result := 1; + end; + if Result = 0 then begin + if (C1 is TKOLCustomControl) and (C2 is TKOLCustomControl) then begin K1 := C1 as TKOLCustomControl; K2 := C2 as TKOLCustomControl; - Result := CmpInts( K1.TabOrder, K2.TabOrder ); - if Result = 0 then - begin + Result := CmpInts(K1.TabOrder, K2.TabOrder); + if Result = 0 then begin if (K1.Align in [caLeft, caRight]) and (K2.Align in [caLeft, caRight]) then - Result := CmpInts( K1.Left, K2.Left ) - else - if (K1.Align in [caTop, caBottom]) and (K2.Align in [caTop, caBottom]) then - Result := CmpInts( K1.Top, K2.Top ); + Result := CmpInts(K1.Left, K2.Left) + else if (K1.Align in [caTop, caBottom]) and (K2.Align in [caTop, caBottom]) then + Result := CmpInts(K1.Top, K2.Top); end; if Result = 0 then - Result := AnsiCompareStr( K1.Name, K2.Name ); + Result := AnsiCompareStr(K1.name, K2.name); end; end; end; -procedure SwapComponents( const AList : Pointer; const e1, e2 : DWORD ); -var OC: TList; - Tmp: Pointer; +procedure SwapComponents(const AList: Pointer; const e1, e2: DWORD); +var + OC: TList; + Tmp: Pointer; begin asm jmp @@e_signature @@ -12059,56 +10247,52 @@ begin @@e_signature: end; OC := AList; - Tmp := OC[ e1 ]; - OC[ e1 ] := OC[ e2 ]; - OC[ e2 ] := Tmp; + Tmp := OC[e1]; + OC[e1] := OC[e2]; + OC[e2] := Tmp; end; - // В результирующем проекте: - // Тип TMyForm - содержит обработчики событий формы и ее объектов, - // а так же описания дочерних визуальных и невизуальных объектов. - // (MyForm заменяется настоящим именем формы). Фактически не является - // формой, как это происходит в VCL, где каждая визуально разрабатываемая - // форма становится наследником от TForm. Нам просто удобно здесь - // сделать так, потому, что появляется возможность вписывать код - // прямо в зеркальный VCL-проект, и при этом объекты формы имеют ту же - // область видимости в результирующем KOL-проекте. Более того, нет нужды - // анализировать синтаксис Паскаля - достаточно скопировать исходный - // модуль начиная со слова 'implementation' и добавить к нему только - // пару генерируемых процедур. - // - // Как минимум, в нем содержится указатель на саму форму, имеющий - // имя Form. Здесь мы выставим требование: так как в KOL переменная - // Self будет недоступна (и будет означать указатель вот этого псевдо- - // объекта, который сейчас описывается), то при написании кода - // (в обработчиках событий) требуется явно указывать слово Form. - // При таком подходе код сможет быть скомпилирован в обеих средах - // (хотя это и будет разный код). -function TKOLForm.GenerateINC(const Path: String; var Updated: Boolean): Boolean; - function RemoveExt( const s: String ): String; +// В результирующем проекте: +// Тип TMyForm - содержит обработчики событий формы и ее объектов, +// а так же описания дочерних визуальных и невизуальных объектов. +// (MyForm заменяется настоящим именем формы). Фактически не является +// формой, как это происходит в VCL, где каждая визуально разрабатываемая +// форма становится наследником от TForm. Нам просто удобно здесь +// сделать так, потому, что появляется возможность вписывать код +// прямо в зеркальный VCL-проект, и при этом объекты формы имеют ту же +// область видимости в результирующем KOL-проекте. Более того, нет нужды +// анализировать синтаксис Паскаля - достаточно скопировать исходный +// модуль начиная со слова 'implementation' и добавить к нему только +// пару генерируемых процедур. +// +// Как минимум, в нем содержится указатель на саму форму, имеющий +// имя Form. Здесь мы выставим требование: так как в KOL переменная +// Self будет недоступна (и будет означать указатель вот этого псевдо- +// объекта, который сейчас описывается), то при написании кода +// (в обработчиках событий) требуется явно указывать слово Form. +// При таком подходе код сможет быть скомпилирован в обеих средах +// (хотя это и будет разный код). + +function TKOLForm.GenerateINC(const Path: string; var Updated: Boolean): Boolean; + +function RemoveExt(const s: string): string; begin - result := ExtractFilePath( s ) + ExtractFileNameWOExt( s ); + Result := ExtractFilePath(s) + ExtractFileNameWOExt(s); end; -var SL: TFormStringList; - I, i1, i2: Integer; var - MainMenuPresent: boolean; - PopupMenuPresent: boolean; - KO: TKOLObj; - KC: TKOLCustomControl; - KM: TComponent; - NeedOleInit: Boolean; + SL: TFormStringList; + I, i1, i2: Integer; +var + MainMenuPresent: Boolean; + PopupMenuPresent: Boolean; + KO: TKOLObj; + KC: TKOLCustomControl; + NeedOleInit: Boolean; - //-- by Alexander Shakhaylo - OC: TList; - //-------------------------- - - Generate_Pcode: Boolean; - s: String; - J, K: Integer; - ch: String; - FA: TStringList; + //-- by Alexander Shakhaylo + OC: TList; + //-------------------------- begin asm jmp @@e_signature @@ -12116,572 +10300,301 @@ begin DB 'TKOLForm.GenerateINC', 0 @@e_signature: end; - Log( '->TKOLForm.GenerateINC' ); + Log('->TKOLForm.GenerateINC'); try - Result := FALSE; - Updated := FALSE; - if csLoading in ComponentState then - begin // не будем пытаться генерировать код, пока форма не загрузилась в дизайнер! - LogOK; Exit; - end; - - Rpt( 'Generating INC for ' + Path, WHITE ); //Rpt_Stack; - - ResStrings.Free; - ResStrings := nil; - - if KOLProject <> nil - then Generate_Pcode := KOLProject.GeneratePCode - else Generate_Pcode := FALSE; - - Rpt( 'Start generate INC for ' + Path, WHITE ); - //-- by Alexander Shakhaylo - oc := TList.Create; - TRY - - for i := 0 to Owner.ComponentCount - 1 do - begin - if csLoading in Owner.Components[ i ].ComponentState then - begin - LogOK; Exit; - end; - oc.Add(Owner.Components[ i ]); - end; - Rpt( 'End generating components', WHITE ); - - SortData( oc, oc.Count, @CompareComponentOrder, @SwapComponents ); - //OutSortedListOfComponents( UnitSourcePath + FormName, oc, 2 ); - - if Generate_Pcode then - for i := 0 to oc.Count - 1 do - begin - km := oc[ i ]; - if km is TKOLObj then - Generate_Pcode := (km as TKOLObj).Pcode_Generate - else - if km is TKOLCustomControl then - Generate_Pcode := (km as TKOLCustomControl).Pcode_Generate - else - if km is TKOLApplet then - Generate_Pcode := (km as TKOLApplet).Pcode_Generate - else - if km is TKOLProject then - else - begin - Generate_Pcode := FALSE; - Rpt( 'Found that component ' + km.Name + - ' is not support Pcode, so Pcode will not be generated', YELLOW ); - end; - end; - - //-------------------------- - - SL := TFormStringList.Create; - SL.OnAdd := DoFlushFormCompact; Result := False; - TRY + Updated := False; + if csLoading in ComponentState then begin // не будем пытаться генерировать код, пока форма не загрузилась в дизайнер! + LogOK; + Exit; + end; - if FLocked then - begin - Rpt( 'Form ' + Name + ' is LOCKED.', YELLOW ); - LogOK; Exit; + Rpt('Generating INC for ' + Path, WHITE); //Rpt_Stack; + + ResStrings.free; + ResStrings := nil; + + Rpt('Start generate INC for ' + Path, WHITE); + //-- by Alexander Shakhaylo + OC := TList.Create; + try + + for I := 0 to Owner.ComponentCount - 1 do begin + if csLoading in Owner.Components[I].ComponentState then begin + LogOK; + Exit; + end; + OC.Add(Owner.Components[I]); end; + Rpt('End generating components', WHITE); + SortData(OC, OC.Count, @CompareComponentOrder, @SwapComponents); + //OutSortedListOfComponents( UnitSourcePath + FormName, oc, 2 ); + + SL := TFormStringList.Create; + Result := False; try - // Step 3. Generate , containing constructor of - // form holder object. - // - Rpt( 'add signature', WHITE ); - SL.Add( Signature ); - if Generate_Pcode then - begin - {P}SL.Add( 'const Sizeof_T' + FormName + ' = Sizeof(T' + FormName + ');' ); - {P}SL.Add( 'type TControl_ = object( TControl ) end;' ); - {P}SL.Add( 'type TObj_ = object( TObj ) end;' ); - {P}SL.Add( 'type _TObj_ = object( _TObj ) end;' ); + if FLocked then begin + Rpt('Form ' + name + ' is LOCKED.', YELLOW); + LogOK; + Exit; end; - // Generating constants for menu items, toolbar buttons, list view columns, etc. - for I := 0 to oc.Count - 1 do - begin - if TComponent( oc[ I ] ) is TKOLObj then - TKOLObj( oc[ I ] ).DoGenerateConstants( SL ) - else - if TComponent( oc[ I ] ) is TKOLCustomControl then - TKOLToolbar( oc[ I ] ).DoGenerateConstants( SL ); - end; + try - // Процедура создания объекта, сопоставленного форме. Вызывается - // автоматически для автоматически создаваемых форм (и для главной - // формы в первую очередь): - Rpt( 'add space', WHITE ); - SL.Add( '' ); + // Step 3. Generate , containing constructor of + // form holder object. + // + Rpt('add signature', WHITE); + SL.Add(Signature); - NeedOleInit := FALSE; - for I := 0 to oc.Count-1 do - begin - if TComponent( oc[ I ] ) is TOleControl then - begin - NeedOleInit := TRUE; - break; + // Generating constants for menu items, toolbar buttons, list view columns, etc. + for I := 0 to OC.Count - 1 do begin + if TComponent(OC[I]) is TKOLObj then + TKOLObj(OC[I]).DoGenerateConstants(SL) + else if TComponent(OC[I]) is TKOLCustomControl then + TKOLToolbar(OC[I]).DoGenerateConstants(SL); end; - end; + // Процедура создания объекта, сопоставленного форме. Вызывается + // автоматически для автоматически создаваемых форм (и для главной + // формы в первую очередь): + Rpt('add space', WHITE); + SL.Add(''); - if Generate_Pcode then - BEGIN - RptDetailed( 'start generating P-code', CYAN ); - {P}SL.Add( '{$IFDEF Pcode}' ); - {P}SL.Add( 'procedure New' + FormName + '( var Result: P' + FormName + - '; AParent: PControl );' ); - {P}SL.Add( '{$IFDEF Psource}' ); - {P}SL.Add( ' PROC(2)' ); - //0. Отладочный код - //{P}SL.Add( ' {Debug Line ' + String2Pascal( Path + '_1.inc' ) + ' #0}' ); - //1. Код создания объекта-держателя формы - {P}SL.Add( ' Load4 ####@@formvmt L(0)' ); - {P}SL.Add( ' TObj.Create<2> RESULT' ); //ESP->Result,@Result,AParent - {P}SL.Add( ' SetSELF' ); // SELF = Result - для быстрого доступа - {P}SL.Add( ' DUP C2 Store' ); //ESP->Result,@Result,AParent - {P}P_GenerateCreateForm( SL ); //ESP->Form,Result,@Result,AParent - {P}P_GenerateAdd2AutoFree( SL, 'Result', FALSE, '', nil ); - fP_NameSetuped := FALSE; - {P}P_SetupFirst( SL, Result_Form, 'AParent', ' ' ); - P_SetupName( SL ); // на всякий случай - if NeedOleInit then - begin - {P} SL.Add( ' OleInit' ); - // SL.Add( ' Result.Add2AutoFreeEx( TObjectMethod( ' + - // 'MakeMethod( nil, @OleUninit ) ) );' ); - {P} SL.Add( ' LoadDword_OleUninit' ); - {P} SL.Add( ' L(0) C2 TObj.Add2AutoFreeEx<3>' ); - end; - // Здесь выполняется конструирование дочерних объектов - в первую очередь - // тех, которые не имеют формального родителя, т.е. наследников KOL.TObj - // (в зеркале - TKOLObj). Сначала конструируется главное меню, если оно - // есть на форме. - // Если главное меню отсутствует, но есть хотя бы одно контекстное меню, - // генерируется пустой объект главной формы - с тем, чтобы прочие меню - // автоматом были контекстными. - MainMenuPresent := False; - PopupMenuPresent := False; - for I := 0 to oc.Count - 1 do - begin - if (TComponent( oc[ I ] ) is TKOLMainMenu) and - ((TComponent( oc[ I ] ) as TKOLMainMenu).FItems.Count > 0) then - begin - MainMenuPresent := True; - KO := TComponent( oc[ I ] ) as TKOLObj; - KO.fP_NameSetuped := FALSE; - KO.P_SetupFirst( SL, KO.Name, Result_Form, ' ' ); - KO.P_SetupName( SL ); // на случай, если P_SetupFirst переопределена - // и inherited или P_SetupName не вызвана - P_GenerateAdd2AutoFree( SL, 'Result.' + KO.Name, TRUE, '', KO ); - KO.P_AssignEvents( SL, 'Result.' + KO.Name, FALSE ); - {P}SL.Add( ' DEL //' + KO.Name ); - KO.P_SetupFirstFinalizy( SL ); - end - else - if TComponent( oc[ I ] ) is TKOLPopupMenu then - PopupMenuPresent := True; + NeedOleInit := False; + for I := 0 to OC.Count - 1 do begin + if TComponent(OC[I]) is TOleControl then begin + NeedOleInit := True; + Break; end; + end; - if PopupMenuPresent and not MainMenuPresent and - (ClassNameIs( 'TKOLForm' ) or ClassNameIs( 'TKOLMDIChild' )) then - begin - //SL.Add( ' NewMenu( ' + Result_Form + ', 0, [ '''' ], nil );' ); - {P}SL.Add( ' LoadStr #0 L(0) L(0) LoadStack L(8) xyAdd L(0) xySwap L(0) C6 NewMenu<3>' + - ' DEL' ); - end; + Rpt('start generating code', CYAN); + SL.Add('procedure New' + formName + '( var Result: P' + formName + + '; AParent: PControl );'); + SL.Add('begin'); + SL.Add(''); + SL.Add(' {$IFDEF KOLCLASSES}'); + SL.Add(' Result := P' + formName + '.Create;'); + SL.Add(' {$ELSE OBJECTS}'); + SL.Add(' New( Result, Create );'); + SL.Add(' {$ENDIF KOL CLASSES/OBJECTS}'); + // "Держатель формы" готов. Теперь конструируем саму форму. - for I := 0 to oc.Count - 1 do - begin - if TComponent( oc[ I ] ) is TKOLMainMenu then continue; - if TComponent( oc[ I ] ) is TKOLObj then - begin - KO := TComponent( oc[ I ] ) as TKOLObj; - if not(KO is TKOLMenu) or (KO is TKOLMenu) and ((KO as TKOLMenu).FItems.Count > 0) then - begin - KO.fUpdated := FALSE; - KO.fP_NameSetuped := FALSE; - KO.P_SetupFirst( SL, KO.Name, Result_Form, ' ' ); - if not(KO is TKOLAction) then - KO.P_SetupName( SL ); // - P_GenerateAdd2AutoFree( SL, 'Result.' + KO.Name, FALSE, '', KO ); - {P}SL.Add( ' //P_AssignEvents for ' + KO.Name ); - KO.P_AssignEvents( SL, 'Result.' + KO.Name, FALSE ); - if KO.fUpdated then - Updated := TRUE; - {P}SL.Add( ' DEL //' + KO.Name ); - KO.P_SetupFirstFinalizy( SL ); - end; + Rpt('call GenerateCreateForm', CYAN + LIGHT); + GenerateCreateForm(SL); + Rpt('after call GenerateCreateForm', CYAN + LIGHT); + + Log('after GenerateCreateForm, next: GenerateAdd2AutoFree'); + //-- moved to GenerateCreateForm: GenerateAdd2AutoFree( SL, 'Result', FALSE, '', nil ); + Log('after GenerateAdd2AutoFree, next: SetupFirst'); + //SL.Add( ' Result.Form.Add2AutoFree( Result );' ); + + FNameSetuped := False; + SetupFirst(SL, Result_Form, 'AParent', ' '); + SetupName(SL, Result_Form, 'AParent', ' '); // + RptDetailed('SetupFirst called for a form', CYAN); + + ////////////////////////////////////////////////////// + // SUPPORT ACTIVE-X CONTROLS + {} + {}if NeedOleInit then + {}begin + {}SL.Add(' OleInit;'); + {}SL.Add(' Result.Add2AutoFreeEx( TObjectMethod( ' + + {}'MakeMethod( nil, @OleUninit ) ) );'); + {} + end; + {} + ///////////////////////////////////////////////////////// + + // Конструируем компоненты VCL. Нехорошо использовать в проекта компоненты + // завязанные на VCL, но не все они сильно завязаны с самим VCL. + for I := 0 to OC.Count - 1 do begin + if not ((TComponent(OC[I]) is TKOLObj) or + (TComponent(OC[I]) is TControl) or + (TComponent(OC[I]) is TKOLApplet or + (TComponent(OC[I]) is TKOLProject))) + or (TComponent(OC[I]) is TOleControl) then + if TComponent(OC[I]) is TComponent then {// ай-я-яй!} begin + SL.Add(''); + if ConstructComponent(SL, OC[I]) then + GenerateAdd2AutoFree(SL, 'Result.' + + TComponent(OC[I]).name + '.Free', + False, 'Add2AutoFreeEx', nil); end; - end; - - // Далее выполняется рекурсивный обход по дереву дочерних контролов и - // генерация кода для них: - P_GenerateChildren( SL, Self, Result_Form, ' ', Updated ); - - // По завершении первоначальной генерации выполняется еще один просмотр - // всех контролов и объектов формы, и для них выполняется SetupLast - - // генерация кода, который должен выполниться на последнем этапе - // инициализации (например, свойство CanResize присваивается False только - // на этом этапе. Если это сделать раньше, то могут возникнуть проблемы - // с изменением размеров окна в процессе настройки формы). - for I := 0 to oc.Count - 1 do - begin - if TComponent( oc[ I ] ) is TKOLCustomControl then - begin - KC := TComponent( oc[ I ] ) as TKOLCustomControl; - KC.ControlInStack := FALSE; - KC.P_SetupLast( SL, KC.RefName, Result_Form, ' ' ); - if KC.ControlInStack then - begin - KC.ControlInStack := FALSE; - {P}SL.Add( ' DEL //' + KC.Name ); - end; - end - else - if TComponent( oc[ I ] ) is TKOLObj then - begin - KO := TComponent( oc[ I ] ) as TKOLObj; - KO.ObjInStack := FALSE; - KO.P_SetupLast( SL, 'Result.' + KO.Name, Result_Form, ' ' ); - if KO.ObjInStack then - begin - KO.ObjInStack := FALSE; - {P}SL.Add( ' DEL //' + KO.Name ); - end; - end; - end; - // Не забудем так же вызвать SetupLast для самой формы (можно было бы - // всунуть код прямо сюда, но так будет легче потом сопровождать): - P_SetupLast( SL, Result_Form, 'AParent', ' ' ); - //{P} ESP->Form,Result,@Result,AParent - {P}SL.Add( ' ####Sizeof_T' + FormName ); - {P}SL.Add( ' ####0' ); - {P}SL.Add( '@@formvmt: ####_TObj_.Init' ); - {P}SL.Add( ' ####TObj.Destroy' ); - {P}SL.Add( ' ENDP' ); - {P}SL.Add( '{$ENDIF Psource}' ); - {P}SL.Add( '{$ELSE OldCode}' ); - RptDetailed( 'endof generating P-code', CYAN ); - END; - - Rpt( 'start generating code', CYAN ); - SL.Add( 'procedure New' + FormName + '( var Result: P' + FormName + - '; AParent: PControl );' ); - SL.Add( 'begin' ); - SL.Add( '' ); - SL.Add( ' {$IFDEF KOLCLASSES}' ); - SL.Add( ' Result := P' + FormName + '.Create;' ); - SL.Add( ' {$ELSE OBJECTS}' ); - SL.Add( ' New( Result, Create );' ); - SL.Add( ' {$ENDIF KOL CLASSES/OBJECTS}' ); - // "Держатель формы" готов. Теперь конструируем саму форму. - - Rpt( 'call GenerateCreateForm', CYAN + LIGHT ); - GenerateCreateForm( SL ); - Rpt( 'after call GenerateCreateForm', CYAN + LIGHT ); - - Log( 'after GenerateCreateForm, next: GenerateAdd2AutoFree' ); - //-- moved to GenerateCreateForm: GenerateAdd2AutoFree( SL, 'Result', FALSE, '', nil ); - Log( 'after GenerateAdd2AutoFree, next: SetupFirst' ); - //SL.Add( ' Result.Form.Add2AutoFree( Result );' ); - - if FormCompact then - begin - //-------- move this code to GenerateCreateForm - { - SL.Add( ' //--< place to call FormCreateParameters >--//' ); - FreeAndNil( FFormAlphabet ); - FreeAndNil( FFormCtlParams ); - FFormAlphabet := TStringList.Create; - FFormCtlParams := TStringList.Create; - FFormCommandsAndParams := ''; - FormCurrentParent := ''; - FormCurrentCtlForTransparentCalls := ''; - } - FormFunArrayIdx := 0; - end; - - FNameSetuped := FALSE; - SetupFirst( SL, Result_Form, 'AParent', ' ' ); - SetupName( SL, Result_Form, 'AParent', ' ' ); // - RptDetailed( 'SetupFirst called for a form', CYAN ); - - ////////////////////////////////////////////////////// - // SUPPORT ACTIVE-X CONTROLS - {} - {}if NeedOleInit then - {}begin - {} SL.Add( ' OleInit;' ); - {} SL.Add( ' Result.Add2AutoFreeEx( TObjectMethod( ' + - {} 'MakeMethod( nil, @OleUninit ) ) );' ); - {}end; - {} - ///////////////////////////////////////////////////////// - - - // Конструируем компоненты VCL. Нехорошо использовать в проекта компоненты - // завязанные на VCL, но не все они сильно завязаны с самим VCL. - for I := 0 to oc.Count-1 do - begin - if not( (TComponent( oc[ I ] ) is TKOLObj) or - (TComponent( oc[ I ] ) is TControl) or - (TComponent( oc[ I ] ) is TKOLApplet or - (TComponent( oc[ I ] ) is TKOLProject))) - or (TComponent( oc[ I ] ) is TOlecontrol) then - if TComponent( oc[ I ] ) is TComponent then // ай-я-яй! - begin - SL.Add( '' ); - if ConstructComponent( SL, oc[ I ] ) then - GenerateAdd2AutoFree( SL, 'Result.' + - TComponent( oc[ I ] ).Name + '.Free', - FALSE, 'Add2AutoFreeEx', nil ); end; - end; - // Здесь выполняется конструирование дочерних объектов - в первую очередь тех, - // которые не имеют формального родителя, т.е. наследников KOL.TObj (в зеркале - // - TKOLObj). Сначала конструируется главное меню, если оно есть на форме. - // Если главное меню отсутствует, но есть хотя бы одно контекстное меню, - // генерируется пустой объект главной формы - с тем, чтобы прочие меню автоматом - // были контекстными. - MainMenuPresent := False; - PopupMenuPresent := False; - for I := 0 to oc.Count - 1 do - begin - if TComponent( oc[ I ] ) is TKOLMainMenu then - begin - MainMenuPresent := True; - KO := TComponent( oc[ I ] ) as TKOLObj; - i1 := SL.Count; - SL.Add( '' ); - //----------- - KO.FNameSetuped := FALSE; - KO.SetupFirst( SL, 'Result.' + KO.Name, Result_Form, ' ' ); - if not(KO is TKOLAction) then - KO.SetupName( SL, 'Result.' + KO.Name, Result_Form, ' ' ); - GenerateAdd2AutoFree( SL, 'Result.' + KO.Name, TRUE, '', KO ); - KO.AssignEvents( SL, 'Result.' + KO.Name ); - //----------- - if not FormCompact then - TRY - KO.CacheLines_SetupFirst := TStringList.Create; - for i2 := i1 to SL.Count-1 do - KO.CacheLines_SetupFirst.Add( SL[ i2 ] ); - EXCEPT - FreeAndNil( KO.CacheLines_SetupFirst ); - END; - RptDetailed( 'SetupFirst & AssignEvents called for main menu', CYAN ); - end - else - if TComponent( oc[ I ] ) is TKOLPopupMenu then - PopupMenuPresent := True; - end; - - if PopupMenuPresent and not MainMenuPresent and - (ClassNameIs( 'TKOLForm' ) or ClassNameIs( 'TKOLMDIChild' )) then - begin - SL.Add( ' NewMenu( ' + Result_Form + ', 0, [ '''' ], nil );' ); - end; - - for I := 0 to oc.Count - 1 do - begin - if TComponent( oc[ I ] ) is TKOLMainMenu then continue; - if TComponent( oc[ I ] ) is TKOLObj then - begin - KO := TComponent( oc[ I ] ) as TKOLObj; - KO.fUpdated := FALSE; - KO.FNameSetuped := FALSE; - end; - end; - - for I := 0 to oc.Count - 1 do - begin - if TComponent( oc[ I ] ) is TKOLMainMenu then continue; - if TComponent( oc[ I ] ) is TKOLObj then - begin - KO := TComponent( oc[ I ] ) as TKOLObj; - KO.fUpdated := FALSE; - if (KO.CacheLines_SetupFirst <> nil) - and not ( KO is TKOLMenu ) - and not ( FormCompact ) then - begin - for i2 := 0 to KO.CacheLines_SetupFirst.Count-1 do - SL.Add( KO.CacheLines_SetupFirst[ i2 ] ); - end - else - begin + // Здесь выполняется конструирование дочерних объектов - в первую очередь тех, + // которые не имеют формального родителя, т.е. наследников KOL.TObj (в зеркале + // - TKOLObj). Сначала конструируется главное меню, если оно есть на форме. + // Если главное меню отсутствует, но есть хотя бы одно контекстное меню, + // генерируется пустой объект главной формы - с тем, чтобы прочие меню автоматом + // были контекстными. + MainMenuPresent := False; + PopupMenuPresent := False; + for I := 0 to OC.Count - 1 do begin + if TComponent(OC[I]) is TKOLMainMenu then begin + MainMenuPresent := True; + KO := TComponent(OC[I]) as TKOLObj; i1 := SL.Count; - //--- - SL.Add( '' ); - KO.FNameSetuped := FALSE; - KO.SetupFirst( SL, 'Result.' + KO.Name, Result_Form, ' ' ); - KO.SetupName( SL, 'Result.' + KO.Name, Result_Form, ' ' ); - GenerateAdd2AutoFree( SL, 'Result.' + KO.Name, FALSE, '', KO ); - KO.AssignEvents( SL, 'Result.' + KO.Name ); - //--- - if not FormCompact then - TRY + SL.Add(''); + //----------- + KO.FNameSetuped := False; + KO.SetupFirst(SL, 'Result.' + KO.name, Result_Form, ' '); + if not (KO is TKOLAction) then + KO.SetupName(SL, 'Result.' + KO.name, Result_Form, ' '); + GenerateAdd2AutoFree(SL, 'Result.' + KO.name, True, '', KO); + KO.AssignEvents(SL, 'Result.' + KO.name); + //----------- + try + KO.CacheLines_SetupFirst := TStringList.Create; + for i2 := i1 to SL.Count - 1 do + KO.CacheLines_SetupFirst.Add(SL[i2]); + except + FreeAndNil(KO.CacheLines_SetupFirst); + end; + RptDetailed('SetupFirst & AssignEvents called for main menu', CYAN); + end + else if TComponent(OC[I]) is TKOLPopupMenu then + PopupMenuPresent := True; + end; + + if PopupMenuPresent and not MainMenuPresent and + (ClassNameIs('TKOLForm') or ClassNameIs('TKOLMDIChild')) then begin + SL.Add(' NewMenu( ' + Result_Form + ', 0, [ '''' ], nil );'); + end; + + for I := 0 to OC.Count - 1 do begin + if TComponent(OC[I]) is TKOLMainMenu then + Continue; + if TComponent(OC[I]) is TKOLObj then begin + KO := TComponent(OC[I]) as TKOLObj; + KO.fUpdated := False; + KO.FNameSetuped := False; + end; + end; + + for I := 0 to OC.Count - 1 do begin + if TComponent(OC[I]) is TKOLMainMenu then + Continue; + if TComponent(OC[I]) is TKOLObj then begin + KO := TComponent(OC[I]) as TKOLObj; + KO.fUpdated := False; + if (KO.CacheLines_SetupFirst <> nil) + and not (KO is TKOLMenu) then begin + for i2 := 0 to KO.CacheLines_SetupFirst.Count - 1 do + SL.Add(KO.CacheLines_SetupFirst[i2]); + end else begin + i1 := SL.Count; + //--- + SL.Add(''); + KO.FNameSetuped := False; + KO.SetupFirst(SL, 'Result.' + KO.name, Result_Form, ' '); + KO.SetupName(SL, 'Result.' + KO.name, Result_Form, ' '); + GenerateAdd2AutoFree(SL, 'Result.' + KO.name, False, '', KO); + KO.AssignEvents(SL, 'Result.' + KO.name); + //--- + try KO.CacheLines_SetupFirst := TStringList.Create; - for i2 := i1 to SL.Count-1 do - KO.CacheLines_SetupFirst.Add( SL[ i2 ] ); - EXCEPT - FreeAndNil( KO.CacheLines_SetupFirst ); - END; + for i2 := i1 to SL.Count - 1 do + KO.CacheLines_SetupFirst.Add(SL[i2]); + except + FreeAndNil(KO.CacheLines_SetupFirst); + end; + end; + if KO.fUpdated then + Updated := True; end; - if KO.fUpdated then - Updated := TRUE; end; - end; - RptDetailed( 'SetupFirst & AssignEvents called for all components (' + IntToStr( oc.Count ) + ')', CYAN ); + RptDetailed('SetupFirst & AssignEvents called for all components (' + IntToStr(OC.Count) + ')', CYAN); - // Далее выполняется рекурсивный обход по дереву дочерних контролов и - // генерация кода для них: - RptDetailed( 'start generating children', CYAN ); - GenerateChildren( SL, Self, Result_Form, ' ', Updated ); - RptDetailed( 'endof generating children', CYAN ); - RptDetailed( 'children generated for form', WHITE ); - //FormFlushCompact( SL ); - Rpt( 'form flushed compact', WHITE ); + // Далее выполняется рекурсивный обход по дереву дочерних контролов и + // генерация кода для них: + RptDetailed('start generating children', CYAN); + GenerateChildren(SL, Self, Result_Form, ' ', Updated); + RptDetailed('endof generating children', CYAN); + RptDetailed('children generated for form', WHITE); - // По завершении первоначальной генерации выполняется еще один просмотр - // всех контролов и объектов формы, и для них выполняется SetupLast - - // генерация кода, который должен выполниться на последнем этапе - // инициализации (например, свойство CanResize присваивается False только - // на этом этапе. Если это сделать раньше, то могут возникнуть проблемы - // с изменением размеров окна в процессе настройки формы). - for I := 0 to oc.Count - 1 do - begin - if TComponent( oc[ I ] ) is TKOLCustomControl then - begin - KC := TComponent( oc[ I ] ) as TKOLCustomControl; - KC.SetupLast( SL, KC.RefName, Result_Form, ' ' ); - end - else - if TComponent( oc[ I ] ) is TKOLObj then - begin - KO := TComponent( oc[ I ] ) as TKOLObj; - KO.SetupLast( SL, 'Result.' + KO.Name, Result_Form, ' ' ); - end; - end; - RptDetailed( 'endof generating SetupLast for children', CYAN ); - RptDetailed( 'setuplast generated for form', WHITE ); - // Не забудем так же вызвать SetupLast для самой формы (можно было бы - // всунуть код прямо сюда, но так будет легче потом сопровождать): - SetupLast( SL, Result_Form, 'AParent', ' ' ); - RptDetailed( 'endof generating SetupLast for a form', CYAN ); - - //--- Если имелись контролы, создаваемые и настраиваемые компактным кодом - // то следует в заранее подготовленную позицию вставить вызов - // FormCreateParameters( alphabet, commands¶meters ); - // где: alphabet - массив указателей на использованные функции, - // commands¶meters - строка с командами и параметрами - // для интерпретации в вызовах FormExecuteCommands( ... ) - if FFormAlphabet <> nil then - RptDetailed( 'FormCompact = ' + Int2Str( Integer( FormCompact ) ) + - ' FormAlphabet.Count = ' + Int2Str( FFormAlphabet.Count ), - WHITE or LIGHT ); - if FormCompact and (FFormAlphabet.Count > 0) then - begin - FA := TStringList.Create; - TRY - FA.Add( 'const FormFunctionsAlphabet: array[0..' + - //IntToStr( FFormAlphabet.Count-1 ) + '] of TFormInitFunc = (' ); - IntToStr( FFormAlphabet.Count-1 ) + '] of Pointer = (' ); - for J := 0 to FFormAlphabet.Count-1 do - begin - ch := '.'; - if FFormAlphabet.Objects[J] <> nil then - ch := '#'; - s := ' {' + Int2Hex( J+1, 1 ) + ch + '} @ ' + - FFormAlphabet[J]; - if J = FFormAlphabet.Count-1 then - s := s + ');' - else - s := s + ','; - FA.Add( s ); - end; - for J := SL.Count-1 downto 0 do - begin - if SL[J] = 'begin' then - begin - for K := FA.Count-1 downto 0 do - SL.Insert( J, FA[K] ); - break; - end; - end; - FINALLY - FA.Free; - END; - for I := 0 to SL.Count-1 do - begin - if SL[I] = ' //--< place to call FormCreateParameters >--//' then - begin - s := ' Result.Form.FormCreateParameters( ' + - '@ FormFunctionsAlphabet, ''''' + - FFormCommandsAndParams + ' );'; - //SL.SaveToFile( 'C:\test_SL_before.txt' ); - SL[ I ] := s; - //SL.SaveToFile( 'C:\test_SL.txt' ); - break; - end; + // По завершении первоначальной генерации выполняется еще один просмотр + // всех контролов и объектов формы, и для них выполняется SetupLast - + // генерация кода, который должен выполниться на последнем этапе + // инициализации (например, свойство CanResize присваивается False только + // на этом этапе. Если это сделать раньше, то могут возникнуть проблемы + // с изменением размеров окна в процессе настройки формы). + for I := 0 to OC.Count - 1 do begin + if TComponent(OC[I]) is TKOLCustomControl then begin + KC := TComponent(OC[I]) as TKOLCustomControl; + KC.SetupLast(SL, KC.RefName, Result_Form, ' '); + end + else if TComponent(OC[I]) is TKOLObj then begin + KO := TComponent(OC[I]) as TKOLObj; + KO.SetupLast(SL, 'Result.' + KO.name, Result_Form, ' '); end; + end; + RptDetailed('endof generating SetupLast for children', CYAN); + RptDetailed('setuplast generated for form', WHITE); + // Не забудем так же вызвать SetupLast для самой формы (можно было бы + // всунуть код прямо сюда, но так будет легче потом сопровождать): + SetupLast(SL, Result_Form, 'AParent', ' '); + RptDetailed('endof generating SetupLast for a form', CYAN); + + //--- Если имелись контролы, создаваемые и настраиваемые компактным кодом + // то следует в заранее подготовленную позицию вставить вызов + // FormCreateParameters( alphabet, commands¶meters ); + // где: alphabet - массив указателей на использованные функции, + // commands¶meters - строка с командами и параметрами + // для интерпретации в вызовах FormExecuteCommands( ... ) + if FFormAlphabet <> nil then + RptDetailed(' FormAlphabet.Count = ' + int2str(FFormAlphabet.Count), WHITE or LIGHT); + + SL.Add(''); + SL.Add('end;'); + SL.Add(''); + + if ResStrings <> nil then begin + for I := ResStrings.Count - 1 downto 0 do + SL.Insert(1, ResStrings[I]); + end; + RptDetailed('start saving code', CYAN); + + SaveStrings(SL, RemoveExt(Path) + '_1.inc', Updated); + Result := True; + RptDetailed('saved -- generated code', CYAN) + + except + //++++++++++ { Maxim Pushkar } +++++++++ + on E: Exception do begin + Rpt('EXCEPTION FOUND 10989: ' + E.Message, RED); + Rpt_Stack; + end; + //++++++++++++++++++++++++++++++++++++++ end; - SL.Add( '' ); - SL.Add( 'end;' ); - if Generate_Pcode then - {P}SL.Add( '{$ENDIF OldCode}' ); - SL.Add( '' ); - - FormFlushCompact( SL ); - - if ResStrings <> nil then - begin - for I := ResStrings.Count-1 downto 0 do - SL.Insert( 1, ResStrings[ I ] ); - end; - RptDetailed( 'start saving code', CYAN ); - - SaveStrings( SL, RemoveExt( Path ) + '_1.inc', Updated ); - Result := True; - RptDetailed( 'saved -- generated code', CYAN ) - - except - //++++++++++ { Maxim Pushkar } +++++++++ - on E: Exception do - begin - Rpt( 'EXCEPTION FOUND 10989: ' + E.Message, RED ); - Rpt_Stack; - end; - //++++++++++++++++++++++++++++++++++++++ + finally + SL.free; + //RptDetailed( 'SL.Free executed', CYAN ) end; - FINALLY - SL.Free; - //RptDetailed( 'SL.Free executed', CYAN ) - END; + finally + OC.free; + RptDetailed('END of generating INC for ' + Path, WHITE) + end; - FINALLY - oc.Free; - RptDetailed( 'END of generating INC for ' + Path, WHITE ) - END; - - Sleep( 0 ); //**** THIS IS MUST **** - { added in v0.84 to fix TKOLFrame, when TKOLCustomControl descendant component - is dropped on TKOLFrame. } - LogOK; + Sleep(0); //**** THIS IS MUST **** + { added in v0.84 to fix TKOLFrame, when TKOLCustomControl descendant component + is dropped on TKOLFrame. } + LogOK; finally - Log( '<-TKOLForm.GenerateINC' ); + Log('<-TKOLForm.GenerateINC'); end; end; -function TrimAll( const S: String ): String; -var I: Integer; +function TrimAll(const s: string): string; +var + I: Integer; begin asm jmp @@e_signature @@ -12689,13 +10602,13 @@ begin DB 'TrimAll', 0 @@e_signature: end; - Result := S; - for I := Length( Result ) downto 1 do - if Result[ I ] <= ' ' then - Delete( Result, I, 1 ); + Result := s; + for I := Length(Result) downto 1 do + if Result[I] <= ' ' then + Delete(Result, I, 1); end; -function EqualWithoutSpaces( S1, S2: String ): Boolean; +function EqualWithoutSpaces(S1, S2: string): Boolean; begin asm jmp @@e_signature @@ -12703,83 +10616,79 @@ begin DB 'EqualWithoutSpaces', 0 @@e_signature: end; - S1 := TrimAll( LowerCase( S1 ) ); - S2 := TrimAll( LowerCase( S2 ) ); + S1 := TrimAll(LowerCase(S1)); + S2 := TrimAll(LowerCase(S2)); Result := S1 = S2; end; -function LongStringSeparate( s: String ): String; -var i: Integer; - LineWidth: Integer; +function LongStringSeparate(s: string): string; +var + I: Integer; + LineWidth: Integer; begin Result := ''; LineWidth := 0; - while s <> '' do - begin - i := pos( ',', s ); - if i <= 0 then i := Length( s ); - if i > 0 then - begin - if LineWidth + i > 63 then - begin + while s <> '' do begin + I := Pos(',', s); + if I <= 0 then + I := Length(s); + if I > 0 then begin + if LineWidth + I > 63 then begin Result := Result + #13#10; - LineWidth := i; + LineWidth := I; end; - Result := Result + Copy( s, 1, i ); - Delete( s, 1, i ); + Result := Result + Copy(s, 1, I); + Delete(s, 1, I); end; end; end; -function FirstSpaces( const s: String ): String; -var i: Integer; +function FirstSpaces(const s: string): string; +var + I: Integer; begin Result := ''; - for i := 1 to Length( s ) do - if s[ i ] = ' ' then Result := Result + ' ' - else break; + for I := 1 to Length(s) do + if s[I] = ' ' then + Result := Result + ' ' + else + Break; end; -procedure ReplaceCorresponding( const FromDir, ToDir: String; Src: TStrings; FromLine: Integer ); -var i, Level: Integer; - s: String; +procedure ReplaceCorresponding(const FromDir, ToDir: string; Src: TStrings; FromLine: Integer); +var + I, Level: Integer; + s: string; begin Level := 0; - for i := FromLine to Src.Count-1 do - begin - s := Trim( Src[ i ] ); - if (pos( FromDir, s ) = 1) and (Level = 0) then - begin - Src[i] := FirstSpaces( Src[ i ] ) + ToDir; + for I := FromLine to Src.Count - 1 do begin + s := Trim(Src[I]); + if (Pos(FromDir, s) = 1) and (Level = 0) then begin + Src[I] := FirstSpaces(Src[I]) + ToDir; Exit; end - else - if (pos( '{$IF', s ) = 1) then - inc( Level ) - else - if (pos( '{$ENDIF', s ) = 1) or (pos( '{$IFEND', s ) = 1) then - dec( Level ); + else if (Pos('{$IF', s) = 1) then + Inc(Level) + else if (Pos('{$ENDIF', s) = 1) or (Pos('{$IFEND', s) = 1) then + Dec(Level); end; end; -function TKOLForm.GeneratePAS(const Path: String; var Updated: Boolean): Boolean; -const DefString = '{$DEFINE KOL_MCK}'; - IfNotKolMck: array[ Boolean ] of String = ( - '{$IFNDEF KOL_MCK}', - '{$IF Defined(KOL_MCK)}{$ELSE}' - ); - EndIfKolMck: array[ Boolean ] of String = ( - '{$ENDIF (place your units here->)};', - '{$IFEND (place your units here->)};' - ); -var SL: TStringList; // строки результирующего PAS-файла - Source: TStringList; // исходный файл - I, J, K: Integer; - UsesFound, FormDefFound, ImplementationFound: Boolean; - S: KOLString; - S1, S2, S_FormClass, S_IFDEF_KOL_MCK, S_PROCEDURE_NEW, S_FUNCTION_NEW, S_Upper, - S_1, S_1_Lower, S_FormDef: String; - chg_src: Boolean; +function TKOLForm.GeneratePAS(const Path: string; var Updated: Boolean): Boolean; +const + DefString = '{$DEFINE KOL_MCK}'; + IfNotKolMck = '{$IF Defined(KOL_MCK)}{$ELSE}'; + EndIfKolMck = '{$IFEND (place your units here->)};'; + +var + SL: TStringList; // строки результирующего PAS-файла + Source: TStringList; // исходный файл + I, j, k: Integer; + UsesFound, FormDefFound, ImplementationFound: Boolean; + s: KOLString; + S1, S2, S_FormClass, S_IFDEF_KOL_MCK, S_PROCEDURE_NEW, S_FUNCTION_NEW, S_Upper, + S_FormDef: string; + chg_src: Boolean; begin asm jmp @@e_signature @@ -12787,654 +10696,446 @@ begin DB 'TKOLForm.GeneratePAS', 0 @@e_signature: end; - Log( '->TKOLForm.GeneratePAS' ); + Log('->TKOLForm.GeneratePAS'); try - Rpt( 'Generating PAS for ' + Path, WHITE ); //Rpt_Stack; - Result := False; - // +++ by Alexander Shakhaylo: - if not fileexists(Path + '.pas') or FLocked then - begin - Rpt( 'File not exists: ' + Path + '.pas', YELLOW ); - LogOK; exit; - end; - // --- - SL := TStringList.Create; - Source := TStringList.Create; - - chg_src := FALSE; - try - - if not FileExists( ExtractFilePath( Path ) + 'uses.inc' ) then - begin - SL.Add( Signature ); - SL.Add( '{ uses.inc' ); - SL.Add( ' This file is generated automatically - do not modify it manually.' ); - SL.Add( ' It is included to be recognized by compiler, but replacing word ' ); - SL.Add( ' with compiler directive <$I uses.inc> fakes auto-completion' ); - SL.Add( ' preventing it from automatic references adding to VCL units into' ); - SL.Add( ' uses clause aimed for KOL environment only. }' ); - SL.Add( '' ); - SL.Add( 'uses' ); - {P := True; - if KOLProject <> nil then - P := KOLProject.ProtectFiles;} - SaveStrings( SL, ExtractFilePath( Path ) + 'uses.inc', Updated ); - SL.Clear; - RptDetailed( 'uses.inc prepared', CYAN ); - end; - - RptDetailed( 'Loading source for ' + Path + '.pas', BLUE ); - LoadSource( Source, Path + '.pas' ); - RptDetailed( 'Source loaded for ' + Name, CYAN ); - for I := 0 to Source.Count- 1 do - begin - if RemoveSpaces( Source[ I ] ) = RemoveSpaces( Signature ) then - begin - Result := True; - if (I < Source.Count - 1) and (Source[ I + 1 ] <> DefString) and - (KOLProject <> nil) and KOLProject.IsKOLProject then - begin - chg_src := TRUE; - Source.Insert( I + 1, DefString ); - //SaveStrings( Source, Path + '.pas', Updated ); - end; - break; - end; - end; - {$IFnDEF NOT_CONVERT_TMSG} - Rpt( 'Converting tagmsg', RED ); - for I := 0 to Source.Count- 1 do - begin - //--------------- from KOL/MCK 3.04, convert tagMSG -> TMsg: - S := Source[I]; - if pos( 'tagmsg', LowerCase( S ) ) > 0 then - begin - RptDetailed( 'tagmsg found in line ' + Int2Str(I+1), CYAN ); - for J := Length(S)-5 downto 1 do - begin - if AnsiCompareText( Copy(S, J, 6), 'tagmsg' ) = 0 then - begin - {$IFDEF _D2009orHigher} - if ( (J = 1) or not CharInSet(S[J-1], ['A'..'Z','a'..'z','_']) ) - and ( (J = Length(S)-5) or not CharInSet(S[J+6], - ['0'..'9','A'..'Z','a'..'z','_']) ) then - {$ELSE} - if ( (J = 1) or not(S[J-1] in ['A'..'Z','a'..'z','_']) ) - and ( (J = Length(S)-5) or not(S[J+6] in - ['0'..'9','A'..'Z','a'..'z','_']) ) then - {$ENDIF} - begin - RptDetailed( 'tagmsg replaced with TMsg in line ' + Int2Str(I+1), CYAN ); - S := Copy( S, 1, J-1 ) + 'TMsg' + Copy( S, J+6, MaxInt ); - Source[I] := S; - chg_src := TRUE; - end; - end; - end; - end; - end; - {$ENDIF} - - if Result then - begin - // Test the Source - may be form is renamed... - - for I := 0 to Source.Count-2 do - begin - S := Trim( Source[ I ] ); - if (S <> '') and (S[ 1 ] = '{') and - (AnsiCompareText( S, '{$I MCKfakeClasses.inc}' ) = 0) then - if I < Source.Count - 5 then - begin - chg_src := TRUE; - Source[ I + 1 ] := - ' {$IFDEF KOLCLASSES} {$I T' + FormName + 'class.inc}' + - ' {$ELSE OBJECTS}' + - ' P' + FormName + ' = ^T' + FormName + ';' + - ' {$ENDIF CLASSES/OBJECTS}'; - Source[ I + 2 ] := - ' {$IFDEF KOLCLASSES}{$I T' + FormName + - '.inc}{$ELSE} T' + FormName + - ' = object(TObj) {$ENDIF}'; - S := ExtractFilePath( Path ) + 'T' + FormName + '.inc'; - if not FileExists( S ) then - begin - SaveStringToFile( S, 'T' + FormName + ' = class(TObj)' ); - end; - S := ExtractFilePath( Path ) + 'T' + FormName + 'class.inc'; - if not FileExists( S ) then - begin - SaveStringToFile( S, 'T' + FormName + ' = class; P' + FormName + ' = T' + FormName + ';' ); - end; - - Source[ I + 5 ] := ' T' + FormName + ' = class(TForm)'; - //////////////////////// by Alexander Shakhaylo ////////////////// - /// D[u]fa - /// а вот это я б ваще убрал. по моему не прально генерит код, добавляя - /// лишний ENDIF // VK: ну и уберём, значит. Вернуть всегда можно, если что. - {$IFnDEF _D2005orHigher} // - (*if pos('{$ENDIF', UpperCase( Source[ I + 6 ] ) ) <= 0 then // - begin // - Source.Insert( I + 6, '{$ENDIF}' ); // - end;*) // - {$ENDIF} - ////////////////////////////////////////////////////////////////// - BREAK; - end; - end; - RptDetailed( '{$I MCKFAKECLASSES.inc} handled', CYAN ); - - S_FormClass := UpperCase( 'T' + FormName + ' = class(TForm)' ); - ///Rpt( '~~~~~~~~~~~~~~~~~~~~', RED ); - for I := 0 to Source.Count-2 do - begin - ///Rpt( Source[I], YELLOW ); - if not GlobalNewIF then - begin - //Rpt( 'check src' + IntToStr( I ) + ':' + Source[ I ], YELLOW ); - if (Pos( '{$IFEND KOL_MCK', Trim( Source[ I ] ) ) = 1) then - begin - Source[ I ] := FirstSpaces( Source[ I ] ) + '{$ENDIF KOL_MCK}'; - chg_src := TRUE; - end - else - if Trim( Source[ I ] ) = '{$IF Defined(KOL_MCK)}' then - begin - Source[ I ] := FirstSpaces( Source[ I ] ) + '{$IFDEF KOL_MCK}'; - ReplaceCorresponding( '{$IFEND', '{$ENDIF}', Source, I+1 ); - chg_src := TRUE; - end - else - begin - if pos( '{$IF Defined(KOL_MCK)}{$ELSE}', Source[I] ) > 0 then - begin - S := Source[I]; - //S := StringReplace( S, '{$IF Defined(KOL_MCK)}{$ELSE}', '{$IFNDEF KOL_MCK}', [] ); - KOLStrReplace( S, '{$IF Defined(KOL_MCK)}{$ELSE}', '{$IFNDEF KOL_MCK}' ); - Source[I] := S; - chg_src := TRUE; - end; - if pos( '{$IFEND (place your units here->)}', Source[I] ) > 0 then - begin - S := Source[I]; - //S := StringReplace( S, '{$IFEND (place your units here->)}', - // '{$ENDIF (place your units here->)}', [] ); - KOLStrReplace( S, '{$IFEND (place your units here->)}', - '{$ENDIF (place your units here->)}' ); - Source[I] := S; - chg_src := TRUE; - end; - end; - end; - if GlobalNewIF then - begin - if (Pos( '{$ENDIF KOL_MCK', Source[ I ] ) > 0) then - begin - //Rpt( 'replace to IFEND', RED ); - Source[ I ] := ' {$IFEND KOL_MCK}'; - chg_src := TRUE; - end - else - if (Trim( Source[ i ] ) = '{$IFDEF KOL_MCK}') and - ((Source[ I ][1] = ' ')) then - begin - Source[ I ] := FirstSpaces( Source[I] ) + '{$IF Defined(KOL_MCK)}'; - ReplaceCorresponding( '{$ENDIF', '{$IFEND}', Source, I+1 ); - chg_src := TRUE; - end - else - begin - if pos( '{$IFNDEF KOL_MCK}', Source[I] ) > 0 then - begin - S := Source[I]; - //S := StringReplace( S, '{$IFNDEF KOL_MCK}', '{$IF Defined(KOL_MCK)}{$ELSE}', [ ] ); - KOLStrReplace( S, '{$IFNDEF KOL_MCK}', '{$IF Defined(KOL_MCK)}{$ELSE}' ); - Source[I] := S; - chg_src := TRUE; - end; - if pos( '{$ENDIF (place your units here->)}', Source[I] ) > 0 then - begin - S := Source[I]; - //S := StringReplace( S, '{$ENDIF (place your units here->)}', - // '{$IFEND (place your units here->)}', [] ); - KOLStrReplace( S, '{$ENDIF (place your units here->)}', - '{$IFEND (place your units here->)}' ); - Source[I] := S; - chg_src := TRUE; - end; - end; - end; - S := Trim( Source[ I ] ); - S_Upper := UpperCase( S ); - //////////////////////////////////////////////////////////////////// - //S := UpperCase( 'T' + FormName + ' = class(TForm)' ); // - if pos( S_FormClass, UpperCase( Source[ I ] ) ) > 0 then // - begin // - /// D[u]fa - if (Pos( '{$IFEND', Source[ I + 1 ] ) <= 0) - and - (Pos( '{$ENDIF', Source[ I+1 ] ) <= 0) then - begin - chg_src := TRUE; - /// D[u]fa - if GlobalNewIF then - Source.Insert( I + 1, ' {$IFEND KOL_MCK}' ) - else - Source.Insert( I + 1, ' {$ENDIF KOL_MCK}' ); - end; - break; - end; // - //////////////////////////////////////////////////////////////////// - end; - RptDetailed( 'Check for T' + FormName + ' = class(TForm) done.', CYAN ); - - S_IFDEF_KOL_MCK := ' {$IFDEF KOL_MCK} : '; - S_procedure_new := 'procedure new'; - S_function_new := 'function new'; - S_FormDef := ' ' + FormName + ' {$IFDEF KOL_MCK} : P' + FormName + - ' {$ELSE} : T' + FormName + ' {$ENDIF} ;'; - for I := Source.Count - 2 downto 0 do - begin - S := Trim( Source[ I ] ); - S_Upper := UpperCase( S ); - if GlobalNewIF then - begin - if Trim( S_Upper ) = '{$IFNDEF KOL_MCK}{$R *.DFM}{$ENDIF}' then - begin - Source[I] := '{$IF Defined(KOL_MCK)}{$ELSE}{$R *.DFM}{$IFEND}'; - chg_src := TRUE; - end; - end - else - if not GlobalNewIF then - begin - if Trim( S_Upper ) = '{$IF DEFINED(KOL_MCK)}{$ELSE}{$R *.DFM}{$IFEND}' then - begin - Source[I] := '{$IFNDEF KOL_MCK}{$R *.DFM}{$ENDIF}'; - ////Rpt( '{$IF Defined Rsc Found and replaced!', RED ); - chg_src := TRUE; - end; - end - else - begin - if pos( S_IFDEF_KOL_MCK, UpperCase( Trim( Source[ I ] ) ) ) > 0 then - begin - if Source[ I ] <> S_FormDef then - begin - chg_src := TRUE; - Source[ I ] := S_FormDef; - end; - end; - if (S_Upper = '{$IFDEF KOL_MCK}') then - begin - S_1 := Trim( Source[ I + 1 ] ); - S_1_Lower := LowerCase( S_1 ); - if ( - (Copy( S_1_Lower, 1, Length( S_procedure_new ) ) = S_procedure_new) - or - (Copy( S_1_Lower, 1, Length( S_function_new ) ) = S_function_new) - ) then - begin - chg_src := TRUE; - Source[ I + 1 ] := 'procedure New' + FormName + '( var Result: P' + - FormName + '; AParent: PControl );'; - ///////////////////////////// by Alexander Shakhaylo ///////// - if pos( '{$ENDIF', UpperCase( Source[ I + 2 ] ) ) <= 0 then // - Source.Insert( I + 2, '{$ENDIF}'); // - ////////////////////////////////////////////////////////////// - end; - end; - if S_Upper = '{$IFDEF KOL_MCK}' then - if StrIsStartingFrom( PChar(UpperCase( Trim( Source[ I + 2 ] ) )), - 'PROCEDURE FREEOBJECTS_') then - begin - // remove artefact - chg_src := TRUE; - Source.Delete( I + 2 ); - end; - end; - end; - RptDetailed( 'Loop2 handled', CYAN ); - - // Convert old definitions to the new ones - K := -1; - for I := 0 to Source.Count-3 do - begin - S := Trim( Source[ I ] ); - if S = '{$ELSE not_KOL_MCK}' then - begin - K := I; - break; - end; - end; - RptDetailed( 'Search for {$ELSE not_KOL_MCK} done, K=' + IntToStr( K ), CYAN ); - - if K < 0 then - begin - for I := 0 to Source.Count-3 do - begin - S := UpperCase( Trim( Source[ I ] ) ); - if StrIsStartingFrom( PChar( S ), '{$I MCKFAKECLASSES.INC}' ) then - begin - for J := I+1 to Source.Count-3 do - begin - S := UpperCase( Trim( Source[ J ] ) ); - if Copy( S, 1, 6 ) = '{$ELSE' then - begin - chg_src := TRUE; - Source[ J ] := ' {$ELSE not_KOL_MCK}'; - break; - end; - end; - break; - end; - end; - RptDetailed( '{$ELSE not_KOL_MCK} provided', CYAN ); - end; - - // Make corrections when Delphi inserts declarations not at the good place: - for I := 0 to Source.Count-3 do - begin - S := Trim( Source[ I ] ); - if S = '{$ELSE not_KOL_MCK}' then - begin - S := Trim( Source[ I + 2 ] ); - if GlobalNewIF then - begin - if S = '{$ENDIF KOL_MCK}' then - begin - S := FirstSpaces( Source[ I ] ) + '{$IFEND KOL_MCK}'; - Source[ I+2 ] := S; - end; - end; - if not GlobalNewIF then - begin - if S = '{$IFEND KOL_MCK}' then - begin - S := FirstSpaces( Source[ I ] ) + '{$ENDIF KOL_MCK}'; - Source[ I+2 ] := S; - end; - end; - /// D[u]fa - //if (S <> {$IFDEF NEWIF}'{$IFEND KOL_MCK}'{$ELSE}'{$ENDIF KOL_MCK}'{$ENDIF}) then - if GlobalNewIF and (S <> '{$IFEND KOL_MCK}') or - not GlobalNewIF and (S <> '{$ENDIF KOL_MCK}') then - begin - for J := I+1 to Source.Count-1 do - begin - S := UpperCase( Trim( Source[ J ] ) ); - //if (Copy( S, 1, 7 ) = {$IFDEF NEWIF}'{$IFEND'{$ELSE}'{$ENDIF'{$ENDIF}) then - if GlobalNewIF and (Copy( S, 1, 7 ) = '{$IFEND') or - not GlobalNewIF and (Copy( S, 1, 7 ) = '{$ENDIF') then - begin - chg_src := TRUE; - Source.Delete( J ); - if GlobalNewIF then - Source.Insert( I+2, ' {$IFEND KOL_MCK}') - else - Source.Insert( I+2, ' {$ENDIF KOL_MCK}'); - break; - end; - end; - end; - break; - end; - end; - RptDetailed( 'Corrections done.', CYAN ); - - //Check for changes in 'uses' clause: - I := -1; - while I < Source.Count - 1 do - begin - Inc( I ); - - if AnsiCompareText( Trim( Source[ I ] ), 'implementation' ) = 0 then - break; - - if (pos( 'uses ', LowerCase( Trim( Source[ I ] ) + ' ' ) ) = 1) then - begin - S := ''; - for J := I to Source.Count - 1 do - begin - S := S + Source[ J ]; - if pos( ';', Source[ J ] ) > 0 then - break; - end; - - //S1 := 'uses Windows, Messages, ShellAPI, KOL' + AdditionalUnits; - S1 := 'uses Windows, Messages, KOL' + AdditionalUnits; - S2 := {$IFDEF UNICODE_CTRLS} ParseW {$ELSE} Parse {$ENDIF} - ( S, '{' ); S := '{' + S; - if not EqualWithoutSpaces( S1, S2 ) then - begin - - (* - ShowMessage( 'Not equal:'#13#10 + - TrimAll( S1 ) + #13#10 + - TrimAll( S2 ) ); - *) - - repeat - S1 := Source[ I ]; - Source.Delete( I ); - until pos( ';', S1 ) > 0; - - chg_src := TRUE; - Source.Insert( I, - //'uses Windows, Messages, ShellAPI, KOL' + AdditionalUnits + ' ' + - LongStringSeparate( 'uses Windows, Messages, KOL' + - AdditionalUnits + ' ' + S ) ); - end; - - break; - end; - end; - RptDetailed( 'Checks for changes in USES done.', CYAN ); - - if AfterGeneratePas( Source ) or chg_src then - begin - SaveStrings( Source, Path + '.pas', Updated ); - RptDetailed( 'Strings saved to ' + Path + '.pas', CYAN ); - end - else - RptDetailed( 'Strings not changed', CYAN ); - - SL.Free; - Source.Free; - LogOK; - Exit; - end; - - // Step 1. If unit is not yet prepared for working both - // in KOL and VCL, then prepare it now. - RptDetailed( 'Step 1', CYAN ); - K := 0; - for I := 0 to Source.Count - 1 do - if pos( RemoveSpaces( Signature ), RemoveSpaces( Source[ I ] ) ) > 0 then - begin - Inc( K ); - break; - end; - if K = 0 then - begin - UsesFound := False; - FormDefFound := False; - ImplementationFound := False; - try - SL.Add( Signature ); - for I := 0 to Source.Count - 1 do - begin - if pos( '{$r *.dfm}', LowerCase( Source[ I ] ) ) > 0 then - begin - /// D[u]fa - if GlobalNewIF then - Source[ I ] := '{$IF Defined(KOL_MCK)}{$ELSE}{$R *.DFM}{$IFEND}' //надо именно через else, а не через {$if not}, иначе не работает - else - Source[ I ] := '{$IFNDEF KOL_MCK} {$R *.DFM} {$ENDIF}'; - break; - end; - end; - I := -1; - while I < Source.Count - 1 do - begin - Inc( I ); - if not ImplementationFound then - if not UsesFound and - (pos( 'uses ', LowerCase( Trim( Source[ I ] ) + ' ' ) ) = 1) then - begin - UsesFound := True; - SL.Add( '{$IFDEF KOL_MCK}' ); - //SL.Add( 'uses Windows, Messages, ShellAPI, KOL' + AdditionalUnits + ' ' + - /// D[u]fa - /// в новых версиях можно юзать конструцию: - /// uses - ///{$IF Defined(KOL_MCK)} - /// Windows, Messages, KOL; - ///{$ELSE} // наивный компиляор будет пихать свои VCL мудули сюда - /// Windows, Messages, KOL, mirror, Classes, Controls, mckCtrls; - ///{$IFEND} - /// но для совместимости меняю только директиву - SL.Add( LongStringSeparate( - 'uses Windows, Messages, KOL' + AdditionalUnits + ' ' + - IfNotKolMck[ GlobalNewIF ] - + ', mirror, Classes, Controls, mckCtrls, mckObjs, Graphics ' + - EndIfKolMck[ GlobalNewIF ] ) ); - SL.Add( '{$ELSE}' ); - SL.Add( '{$I uses.inc}' + Copy( Source[ I ], 5, Length( Source[ I ] ) - 4 ) ); - Inc( I ); - if pos( ';', Source[ I - 1 ] ) < 1 then - repeat - SL.Add( Source[ I ] ); - Inc( I ); - until pos( ';', Source[ I - 1 ] ) > 0; - SL.Add( '{$ENDIF}' ); - Dec( I ); - Continue; - end; - if not FormDefFound and - (pos( LowerCase( 'T' + FormName + ' = class(TForm)' ), - LowerCase( Source[ I ] ) ) > 0) then - begin - FormDefFound := True; - /// D[u]fa - if GlobalNewIF then - SL.Add( ' {$IF Defined(KOL_MCK)}' ) - else - SL.Add( ' {$IFDEF KOL_MCK}' ); - S := ' {$I MCKfakeClasses.inc}'; - SL.Add( S ); - SL.Add( ' {$IFDEF KOLCLASSES} T' + FormName + - ' = class; P' + FormName + ' = T' + FormName + ';' + - ' {$ELSE OBJECTS}' + - ' P' + FormName + ' = ^T' + FormName + ';' + - ' {$ENDIF CLASSES/OBJECTS}' ); - SL.Add( ' {$IFDEF KOLCLASSES}{$I T' + FormName + - '.inc}{$ELSE} T' + FormName + - ' = object(TObj) {$ENDIF}' ); - SL.Add( ' Form: ' + FormTypeName + ';' ); - SL.Add( ' {$ELSE not_KOL_MCK}' ); - SL.Add( Source[ I ] ); - /// D[u]fa - if GlobalNewIF then - SL.Add( ' {$IFEND KOL_MCK}' ) - else - SL.Add( ' {$ENDIF KOL_MCK}' ); - Continue; - end; - if not ImplementationFound then - begin - if LowerCase( Trim( Source[ I ] ) ) = - LowerCase( FormName + ': T' + FormName + ';' ) then - begin - SL.Add( ' ' + FormName + ' {$IFDEF KOL_MCK} : P' + FormName + - ' {$ELSE} : T' + FormName + ' {$ENDIF} ;' ); - Continue; - end; - end; - if not ImplementationFound and - (pos( 'implementation', LowerCase( Source[ I ] ) ) > 0 ) then - begin - SL.Add( '{$IFDEF KOL_MCK}' ); - SL.Add( 'procedure New' + FormName + '( var Result: P' + FormName + - '; AParent: PControl );' ); - SL.Add( '{$ENDIF}' ); - SL.Add( '' ); - - ImplementationFound := True; - SL.Add( Source[ I ] ); - while True do - begin - Inc( I ); - if pos( 'uses ', LowerCase( Source[ I ] + ' ' ) ) > 0 then - begin - SL.Add( Source[ I ] ); - if pos( ';', Source[ I ] ) < 1 then - begin - repeat - Inc( I ); - SL.Add( Source[ I ] ); - until pos( ';', Source[ I ] ) > 0; - end; - ImplementationFound := False; - break; - end - else - if (Trim( Source[ I ] ) <> '') and (Trim( Source[ I ] )[ 1 ] <> '{') then - break; - SL.Add( Source[ I ] ); - end; - if not ImplementationFound then - SL.Add( '' ); - SL.Add( '{$IFDEF KOL_MCK}' ); - SL.Add( '{$I ' + FormUnit + '_1.inc}' ); - SL.Add( '{$ENDIF}' ); - if ImplementationFound then - begin - SL.Add( '' ); - SL.Add( Source[ I ] ); - end; - ImplementationFound := True; - Continue; - end; - SL.Add( Source[ I ] ); - end; - except - ImplementationFound := False; - end; - if not UsesFound or not FormDefFound or not ImplementationFound then - begin - SL.Free; - Source.Free; - S := ''; - if not UsesFound then - S := 'Uses not found'#13; - if not FormDefFound then - S := S + 'Form definition not found'#13; - if not ImplementationFound then - S := S + 'Implementation section not found'#13; - ShowMessage( 'Error converting ' + FormUnit + ' unit to KOL:'#13 + S ); + Rpt('Generating PAS for ' + Path, WHITE); //Rpt_Stack; + Result := False; + // +++ by Alexander Shakhaylo: + if not FileExists(Path + '.pas') or FLocked then begin + Rpt('File not exists: ' + Path + '.pas', YELLOW); LogOK; Exit; end; + // --- + SL := TStringList.Create; + Source := TStringList.Create; - AfterGeneratePas( SL ); - SaveStrings( SL, Path + '.pas', Updated ); - end; + chg_src := False; + try - Result := True; - except - Rpt( '**************** Unknown Exception - supressed', RED ); - end; + if not FileExists(ExtractFilePath(Path) + 'uses.inc') then begin + SL.Add(Signature); + SL.Add('{ uses.inc'); + SL.Add(' This file is generated automatically - do not modify it manually.'); + SL.Add(' It is included to be recognized by compiler, but replacing word '); + SL.Add(' with compiler directive <$I uses.inc> fakes auto-completion'); + SL.Add(' preventing it from automatic references adding to VCL units into'); + SL.Add(' uses clause aimed for KOL environment only. }'); + SL.Add(''); + SL.Add('uses'); + {P := True; + if KOLProject <> nil then + P := KOLProject.ProtectFiles;} + SaveStrings(SL, ExtractFilePath(Path) + 'uses.inc', Updated); + SL.Clear; + RptDetailed('uses.inc prepared', CYAN); + end; - SL.Free; - Source.Free; - LogOK; + RptDetailed('Loading source for ' + Path + '.pas', BLUE); + LoadSource(Source, Path + '.pas'); + RptDetailed('Source loaded for ' + name, CYAN); + for I := 0 to Source.Count - 1 do begin + if RemoveSpaces(Source[I]) = RemoveSpaces(Signature) then begin + Result := True; + if (I < Source.Count - 1) and (Source[I + 1] <> DefString) and + (KOLProject <> nil) and KOLProject.isKOLProject then begin + chg_src := True; + Source.Insert(I + 1, DefString); + //SaveStrings( Source, Path + '.pas', Updated ); + end; + Break; + end; + end; +{$IFNDEF NOT_CONVERT_TMSG} + Rpt('Converting tagmsg', RED); + for I := 0 to Source.Count - 1 do begin + //--------------- from KOL/MCK 3.04, convert tagMSG -> TMsg: + s := Source[I]; + if Pos('tagmsg', LowerCase(s)) > 0 then begin + RptDetailed('tagmsg found in line ' + int2str(I + 1), CYAN); + for j := Length(s) - 5 downto 1 do begin + if AnsiCompareText(Copy(s, j, 6), 'tagmsg') = 0 then begin +{$IFDEF _D2009orHigher} + if ((j = 1) or not CharInSet(s[j - 1], ['A'..'Z', 'a'..'z', '_'])) + and ((j = Length(s) - 5) or not CharInSet(s[j + 6], + ['0'..'9', 'A'..'Z', 'a'..'z', '_'])) then +{$ELSE} + if ((j = 1) or not (s[j - 1] in ['A'..'Z', 'a'..'z', '_'])) + and ((j = Length(s) - 5) or not (s[j + 6] in + ['0'..'9', 'A'..'Z', 'a'..'z', '_'])) then +{$ENDIF}begin + RptDetailed('tagmsg replaced with TMsg in line ' + int2str(I + 1), CYAN); + s := Copy(s, 1, j - 1) + 'TMsg' + Copy(s, j + 6, MaxInt); + Source[I] := s; + chg_src := True; + end; + end; + end; + end; + end; +{$ENDIF} + + if Result then begin + // Test the Source - may be form is renamed... + + for I := 0 to Source.Count - 2 do begin + s := Trim(Source[I]); + if (s <> '') and (s[1] = '{') and + (AnsiCompareText(s, '{$I MCKfakeClasses.inc}') = 0) then + if I < Source.Count - 5 then begin + chg_src := True; + Source[I + 1] := + ' {$IFDEF KOLCLASSES} {$I T' + formName + 'class.inc}' + + ' {$ELSE OBJECTS}' + + ' P' + formName + ' = ^T' + formName + ';' + + ' {$ENDIF CLASSES/OBJECTS}'; + Source[I + 2] := + ' {$IFDEF KOLCLASSES}{$I T' + formName + + '.inc}{$ELSE} T' + formName + + ' = object(TObj) {$ENDIF}'; + s := ExtractFilePath(Path) + 'T' + formName + '.inc'; + if not FileExists(s) then begin + SaveStringToFile(s, 'T' + formName + ' = class(TObj)'); + end; + s := ExtractFilePath(Path) + 'T' + formName + 'class.inc'; + if not FileExists(s) then begin + SaveStringToFile(s, 'T' + formName + ' = class; P' + formName + ' = T' + formName + ';'); + end; + + Source[I + 5] := ' T' + formName + ' = class(TForm)'; + Break; + end; + end; + RptDetailed('{$I MCKFAKECLASSES.inc} handled', CYAN); + + S_FormClass := UpperCase('T' + formName + ' = class(TForm)'); + ///Rpt( '~~~~~~~~~~~~~~~~~~~~', RED ); + for I := 0 to Source.Count - 2 do begin + if (Pos('{$ENDIF KOL_MCK', Source[I]) > 0) then begin + //Rpt( 'replace to IFEND', RED ); + Source[I] := ' {$IFEND KOL_MCK}'; + chg_src := True; + end else if (Trim(Source[I]) = '{$IFDEF KOL_MCK}') and ((Source[I][1] = ' ')) then begin + Source[I] := FirstSpaces(Source[I]) + '{$IF Defined(KOL_MCK)}'; + ReplaceCorresponding('{$ENDIF', '{$IFEND}', Source, I + 1); + chg_src := True; + end + else begin + if (Pos('{$IFNDEF KOL_MCK}', Source[I]) > 0) then begin + s := Source[I]; + StrReplace(s, '{$IFNDEF KOL_MCK}', '{$IF Defined(KOL_MCK)}{$ELSE}'); + Source[I] := s; + chg_src := True; + end; + if (Pos('{$ENDIF (place your units here->)}', Source[I]) > 0) then begin + s := Source[I]; + StrReplace(s, '{$ENDIF (place your units here->)}', + '{$IFEND (place your units here->)}'); + Source[I] := s; + chg_src := True; + end; + end; + s := Trim(Source[I]); + S_Upper := UpperCase(s); + //////////////////////////////////////////////////////////////////// + //S := UpperCase( 'T' + FormName + ' = class(TForm)' ); // + if (Pos(S_FormClass, UpperCase(Source[I])) > 0) then begin + if (Pos('{$IFEND', Source[I + 1]) <= 0) then begin // dufa + chg_src := True; + Source.Insert(I + 1, ' {$IFEND KOL_MCK}') + end; + Break; + end; // + //////////////////////////////////////////////////////////////////// + end; + RptDetailed('Check for T' + formName + ' = class(TForm) done.', CYAN); + + S_IFDEF_KOL_MCK := ' {$IFDEF KOL_MCK} : '; + S_PROCEDURE_NEW := 'procedure new'; + S_FUNCTION_NEW := 'function new'; + S_FormDef := ' ' + formName + ' {$IFDEF KOL_MCK} : P' + formName + + ' {$ELSE} : T' + formName + ' {$ENDIF} ;'; + for I := Source.Count - 2 downto 0 do begin + S := Trim(Source[I]); + S_Upper := UpperCase(S); + if (S_Upper = '{$IFNDEF KOL_MCK}{$R *.DFM}{$ENDIF}') then begin + Source[I] := '{$IF Defined(KOL_MCK)}{$ELSE}{$R *.DFM}{$IFEND}'; + chg_src := True; + end; + end; + RptDetailed('Loop2 handled', CYAN); + + // Convert old definitions to the new ones + k := -1; + for I := 0 to Source.Count - 3 do begin + s := Trim(Source[I]); + if s = '{$ELSE not_KOL_MCK}' then begin + k := I; + Break; + end; + end; + RptDetailed('Search for {$ELSE not_KOL_MCK} done, K=' + IntToStr(k), CYAN); + + if k < 0 then begin + for I := 0 to Source.Count - 3 do begin + s := UpperCase(Trim(Source[I])); + if StrIsStartingFrom(PChar(s), '{$I MCKFAKECLASSES.INC}') then begin + for j := I + 1 to Source.Count - 3 do begin + s := UpperCase(Trim(Source[j])); + if Copy(s, 1, 6) = '{$ELSE' then begin + chg_src := True; + Source[j] := ' {$ELSE not_KOL_MCK}'; + Break; + end; + end; + Break; + end; + end; + RptDetailed('{$ELSE not_KOL_MCK} provided', CYAN); + end; + + // Make corrections when Delphi inserts declarations not at the good place: + for I := 0 to Source.Count - 3 do begin + s := Trim(Source[I]); + if (s = '{$ELSE not_KOL_MCK}') then begin + s := Trim(Source[I + 2]); + if (s = '{$ENDIF KOL_MCK}') then begin + s := FirstSpaces(Source[I]) + '{$IFEND KOL_MCK}'; + Source[I + 2] := s; + end; + + if (s <> '{$IFEND KOL_MCK}') then begin + for j := I + 1 to Source.Count - 1 do begin + s := UpperCase(Trim(Source[j])); + if (Copy(s, 1, 7) = '{$IFEND') then begin + chg_src := True; + Source.Delete(j); + Source.Insert(I + 2, ' {$IFEND KOL_MCK}'); + Break; + end; + end; + end; + Break; + end; + end; + RptDetailed('Corrections done.', CYAN); + + //Check for changes in 'uses' clause: + I := -1; + while I < Source.Count - 1 do begin + Inc(I); + + if AnsiCompareText(Trim(Source[I]), 'implementation') = 0 then + Break; + + if (Pos('uses ', LowerCase(Trim(Source[I]) + ' ')) = 1) then begin + s := ''; + for j := I to Source.Count - 1 do begin + s := s + Source[j]; + if Pos(';', Source[j]) > 0 then + Break; + end; + + //S1 := 'uses Windows, Messages, ShellAPI, KOL' + AdditionalUnits; + S1 := 'uses Windows, Messages, KOL' + AdditionalUnits; + S2 := {$IFDEF UNICODE_CTRLS}ParseW{$ELSE}Parse{$ENDIF} + (s, '{'); + s := '{' + s; + if not EqualWithoutSpaces(S1, S2) then begin + + (* + ShowMessage( 'Not equal:'#13#10 + + TrimAll( S1 ) + #13#10 + + TrimAll( S2 ) ); + *) + + repeat + S1 := Source[I]; + Source.Delete(I); + until Pos(';', S1) > 0; + + chg_src := True; + Source.Insert(I, + //'uses Windows, Messages, ShellAPI, KOL' + AdditionalUnits + ' ' + + LongStringSeparate('uses Windows, Messages, KOL' + + AdditionalUnits + ' ' + s)); + end; + + Break; + end; + end; + RptDetailed('Checks for changes in USES done.', CYAN); + + if AfterGeneratePas(Source) or chg_src then begin + SaveStrings(Source, Path + '.pas', Updated); + RptDetailed('Strings saved to ' + Path + '.pas', CYAN); + end + else + RptDetailed('Strings not changed', CYAN); + + SL.free; + Source.free; + LogOK; + Exit; + end; + + // Step 1. If unit is not yet prepared for working both + // in KOL and VCL, then prepare it now. + RptDetailed('Step 1', CYAN); + k := 0; + for I := 0 to Source.Count - 1 do + if Pos(RemoveSpaces(Signature), RemoveSpaces(Source[I])) > 0 then begin + Inc(k); + Break; + end; + if k = 0 then begin + UsesFound := False; + FormDefFound := False; + ImplementationFound := False; + try + SL.Add(Signature); + for I := 0 to Source.Count - 1 do begin + if (Pos('{$r *.dfm}', LowerCase(Source[I])) > 0) then begin + Source[I] := '{$IF Defined(KOL_MCK)}{$ELSE}{$R *.DFM}{$IFEND}'; //надо именно через else, а не через {$if not}, иначе не работает + Break; + end; + end; + I := -1; + while I < Source.Count - 1 do begin + Inc(I); + if not ImplementationFound then + if not UsesFound and + (Pos('uses ', LowerCase(Trim(Source[I]) + ' ')) = 1) then begin + UsesFound := True; + SL.Add('{$IFDEF KOL_MCK}'); + //SL.Add( 'uses Windows, Messages, ShellAPI, KOL' + AdditionalUnits + ' ' + + /// dufa + /// в новых версиях можно юзать конструцию: + /// uses + ///{$IF Defined(KOL_MCK)} + /// Windows, Messages, KOL; + ///{$ELSE} // наивный компиляор будет пихать свои VCL мoдули сюда + /// Windows, Messages, KOL, mirror, Classes, Controls, mckCtrls; + ///{$IFEND} + /// но для совместимости меняю только директиву + SL.Add(LongStringSeparate( + 'uses Windows, Messages, KOL' + AdditionalUnits + ' ' + + IfNotKolMck + + ', mirror, Classes, Controls, mckCtrls, mckObjs, Graphics ' + + EndIfKolMck)); + SL.Add('{$ELSE}'); + SL.Add('{$I uses.inc}' + Copy(Source[I], 5, Length(Source[I]) - 4)); + Inc(I); + if Pos(';', Source[I - 1]) < 1 then + repeat + SL.Add(Source[I]); + Inc(I); + until Pos(';', Source[I - 1]) > 0; + SL.Add('{$ENDIF}'); + Dec(I); + Continue; + end; + if not FormDefFound and + (Pos(LowerCase('T' + formName + ' = class(TForm)'), + LowerCase(Source[I])) > 0) then begin + FormDefFound := True; + SL.Add(' {$IF Defined(KOL_MCK)}'); + SL.Add(' {$I MCKfakeClasses.inc}'); + SL.Add(' {$IFDEF KOLCLASSES} T' + formName +' = class; P' + formName + ' = T' + formName + ';' + + ' {$ELSE OBJECTS}' + ' P' + formName + ' = ^T' + formName + ';' + + ' {$ENDIF CLASSES/OBJECTS}'); + SL.Add(' {$IFDEF KOLCLASSES}{$I T' + formName + '.inc}{$ELSE} T' + formName + ' = object(TObj) {$ENDIF}'); + SL.Add(' Form: ' + FormTypeName + ';'); + SL.Add(' {$ELSE not_KOL_MCK}'); + SL.Add(Source[I]); + SL.Add(' {$IFEND KOL_MCK}'); + Continue; + end; + if not ImplementationFound then begin + if LowerCase(Trim(Source[I])) = + LowerCase(formName + ': T' + formName + ';') then begin + SL.Add(' ' + formName + ' {$IFDEF KOL_MCK} : P' + formName + + ' {$ELSE} : T' + formName + ' {$ENDIF} ;'); + Continue; + end; + end; + if not ImplementationFound and + (Pos('implementation', LowerCase(Source[I])) > 0) then begin + SL.Add('{$IFDEF KOL_MCK}'); + SL.Add('procedure New' + formName + '( var Result: P' + formName + + '; AParent: PControl );'); + SL.Add('{$ENDIF}'); + SL.Add(''); + + ImplementationFound := True; + SL.Add(Source[I]); + while True do begin + Inc(I); + if Pos('uses ', LowerCase(Source[I] + ' ')) > 0 then begin + SL.Add(Source[I]); + if Pos(';', Source[I]) < 1 then begin + repeat + Inc(I); + SL.Add(Source[I]); + until Pos(';', Source[I]) > 0; + end; + ImplementationFound := False; + Break; + end + else if (Trim(Source[I]) <> '') and (Trim(Source[I])[1] <> '{') then + Break; + SL.Add(Source[I]); + end; + if not ImplementationFound then + SL.Add(''); + SL.Add('{$IFDEF KOL_MCK}'); + SL.Add('{$I ' + formUnit + '_1.inc}'); + SL.Add('{$ENDIF}'); + if ImplementationFound then begin + SL.Add(''); + SL.Add(Source[I]); + end; + ImplementationFound := True; + Continue; + end; + SL.Add(Source[I]); + end; + except + ImplementationFound := False; + end; + if not UsesFound or not FormDefFound or not ImplementationFound then begin + SL.free; + Source.free; + s := ''; + if not UsesFound then + s := 'Uses not found'#13; + if not FormDefFound then + s := s + 'Form definition not found'#13; + if not ImplementationFound then + s := s + 'Implementation section not found'#13; + Showmessage('Error converting ' + formUnit + ' unit to KOL:'#13 + s); + LogOK; + Exit; + end; + + AfterGeneratePas(SL); + SaveStrings(SL, Path + '.pas', Updated); + end; + + Result := True; + except + Rpt('**************** Unknown Exception - supressed', RED); + end; + + SL.free; + Source.free; + LogOK; finally - Log( '<-TKOLForm.GeneratePAS' ); + Log('<-TKOLForm.GeneratePAS'); end; end; -function TKOLForm.GenerateTransparentInits: String; +function TKOLForm.GenerateTransparentInits: string; begin asm jmp @@e_signature @@ -13442,102 +11143,97 @@ begin DB 'TKOLForm.GenerateTransparentInits', 0 @@e_signature: end; - Log( '->TKOLForm.GenerateTransparentInits' ); + Log('->TKOLForm.GenerateTransparentInits'); try - Result := ''; - if not FLocked then - begin + Result := ''; + if not FLocked then begin - //Log( '#1 TKOLForm.GenerateTransparentInits' ); + //Log( '#1 TKOLForm.GenerateTransparentInits' ); - if not DefaultPosition then - begin - //Log( '#1.A TKOLForm.GenerateTransparentInits' ); + if not defaultPosition then begin + //Log( '#1.A TKOLForm.GenerateTransparentInits' ); - if not DoNotGenerateSetPosition then - begin - //Log( '#1.B TKOLForm.GenerateTransparentInits' ); - {$IFDEF _D2009orHigher} - Result := '.SetPosition( ' + IntToStr( (Owner as TForm).Left ) + ', ' + - IntToStr( (Owner as TForm).Top ) + ' )'; - {$ELSE} - if FBounds <> nil then - Result := '.SetPosition( ' + IntToStr( Bounds.Left ) + ', ' + - IntToStr( Bounds.Top ) + ' )'; - {$ENDIF} - //Log( '#1.C TKOLForm.GenerateTransparentInits' ); + if not DoNotGenerateSetPosition then begin + //Log( '#1.B TKOLForm.GenerateTransparentInits' ); +{$IFDEF _D2009orHigher} + Result := '.SetPosition( ' + IntToStr((Owner as TForm).Left) + ', ' + + IntToStr((Owner as TForm).Top) + ' )'; +{$ELSE} + if fBounds <> nil then + Result := '.SetPosition( ' + IntToStr(bounds.Left) + ', ' + + IntToStr(bounds.Top) + ' )'; +{$ENDIF} + //Log( '#1.C TKOLForm.GenerateTransparentInits' ); + end; + + //Log( '#1.D TKOLForm.GenerateTransparentInits' ); end; - //Log( '#1.D TKOLForm.GenerateTransparentInits' ); - end; + //Log( '#2 TKOLForm.GenerateTransparentInits' ); - //Log( '#2 TKOLForm.GenerateTransparentInits' ); + if not defaultSize then begin + if {CanResize or}(Owner = nil) or not (Owner is TForm) then + if HasCaption then +{$IFDEF _D2009orHigher} + Result := Result + '.SetSize( ' + IntToStr((Owner as TForm).Width) + ', ' + + IntToStr((Owner as TForm).Height) + ' )' +{$ELSE} + Result := Result + '.SetSize( ' + IntToStr(bounds.Width) + ', ' + + IntToStr(bounds.Height) + ' )' +{$ENDIF} + else +{$IFDEF _D209orHigher} + Result := Result + '.SetSize( ' + IntToStr(Width) + ', ' + + IntToStr(Height - GetSystemMetrics(SM_CYCAPTION)) + ' )'; +{$ELSE} + Result := Result + '.SetSize( ' + IntToStr(bounds.Width) + ', ' + + IntToStr(bounds.Height - GetSystemMetrics(SM_CYCAPTION)) + ' )'; +{$ENDIF} + end; - if not DefaultSize then - begin - if {CanResize or} (Owner = nil) or not(Owner is TForm) then - if HasCaption then - {$IFDEF _D2009orHigher} - Result := Result + '.SetSize( ' + IntToStr( (Owner as TForm).Width ) + ', ' + - IntToStr( (Owner as TForm).Height ) + ' )' - {$ELSE} - Result := Result + '.SetSize( ' + IntToStr( Bounds.Width ) + ', ' + - IntToStr( Bounds.Height ) + ' )' - {$ENDIF} + //Log( '#3 TKOLForm.GenerateTransparentInits' ); + + if Tabulate then + Result := Result + '.Tabulate' + else if TabulateEx then + Result := Result + '.TabulateEx'; + + //Log( '#4 TKOLForm.GenerateTransparentInits' ); + + if AllBtnReturnClick then begin + if formMain and not AppletOnForm then else - {$IFDEF _D209orHigher} - Result := Result + '.SetSize( ' + IntToStr( Width ) + ', ' + - IntToStr( Height-GetSystemMetrics(SM_CYCAPTION) ) + ' )'; - {$ELSE} - Result := Result + '.SetSize( ' + IntToStr( Bounds.Width ) + ', ' + - IntToStr( Bounds.Height-GetSystemMetrics(SM_CYCAPTION) ) + ' )'; - {$ENDIF} + Result := Result + '.AllBtnReturnClick'; + end; + + if PreventResizeFlicks then + Result := Result + '.PreventResizeFlicks'; + + //Log( '#5 TKOLForm.GenerateTransparentInits' ); + + if supportMnemonics then + Result := Result + '.SupportMnemonics'; + + //Log( '#6 TKOLForm.GenerateTransparentInits' ); + + if HelpContext <> 0 then + Result := Result + '.AssignHelpContext( ' + IntToStr(HelpContext) + ' )'; end; - //Log( '#3 TKOLForm.GenerateTransparentInits' ); + //Log( '#7 TKOLForm.GenerateTransparentInits' ); - if Tabulate then - Result := Result + '.Tabulate' - else - if TabulateEx then - Result := Result + '.TabulateEx'; - - //Log( '#4 TKOLForm.GenerateTransparentInits' ); - - if AllBtnReturnClick then - begin - if FormMain and not AppletOnForm then - else - Result := Result + '.AllBtnReturnClick'; - end; - - if PreventResizeFlicks then - Result := Result + '.PreventResizeFlicks'; - - //Log( '#5 TKOLForm.GenerateTransparentInits' ); - - if supportMnemonics then - Result := Result + '.SupportMnemonics'; - - //Log( '#6 TKOLForm.GenerateTransparentInits' ); - - if HelpContext <> 0 then - Result := Result + '.AssignHelpContext( ' + IntToStr( HelpContext ) + ' )'; - end; - - //Log( '#7 TKOLForm.GenerateTransparentInits' ); - - LogOK; + LogOK; finally - Log( '<-TKOLForm.GenerateTransparentInits' ); + Log('<-TKOLForm.GenerateTransparentInits'); end; end; -function TKOLForm.GenerateUnit(const Path: String): Boolean; -var PAS, INC: Boolean; - Updated, PasUpdated, IncUpdated: Boolean; - I: Integer; - C: TComponent; +function TKOLForm.GenerateUnit(const Path: string): Boolean; +var + PAS, Inc: Boolean; + Updated, PasUpdated, IncUpdated: Boolean; + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -13545,72 +11241,65 @@ begin DB 'TKOLForm.GenerateUnit', 0 @@e_signature: end; - Log( '->TKOLForm.GenerateUnit' ); + Log('->TKOLForm.GenerateUnit'); try - Result := False; - Log(Path); - if not FChanged then - begin - LogOK; - Exit; - end; - FChanged := FALSE; - - //Rpt_Stack; - - if not FLocked then - begin - Log('-1'); - for I := 0 to Owner.ComponentCount-1 do - begin - C := Owner.Components[ I ]; - if IsVCLControl( C ) then - begin - FLocked := TRUE; - ShowMessage( 'Form ' + Owner.Name + ' contains VCL controls and can not ' + - 'be converted to KOL form properly. TKOLForm component is locked. ' + - 'Remove VCL controls first, then unlock TKOLForm component.' ); - LogOK; - Exit; - end; - end; - - Log('-2'); - fUniqueID := 5000; - Rpt( '----------- UNIQUE ID = ' + IntToStr( fUniqueID ), WHITE ); - if FormUnit = '' then - begin - Rpt( 'Error: FormUnit = ''''', RED ); + Result := False; + Log(Path); + if not FChanged then begin LogOK; Exit; end; + FChanged := False; - Log('-3'); - PasUpdated := FALSE; - IncUpdated := FALSE; - PAS := GeneratePAS( Path, PasUpdated ); - Log('-4'); - INC := GenerateINC( Path, IncUpdated ); - Log('-5'); - Updated := PasUpdated or IncUpdated; - Result := PAS and INC; - if Result and Updated then - begin - Log('-6'); - // force mark modified here - if PasUpdated then - MarkModified( Path + '.pas' ); - if IncUpdated then - begin - MarkModified( Path + '_1.inc' ); - UpdateUnit( Path + '_1.inc' ); + //Rpt_Stack; + + if not FLocked then begin + Log('-1'); + for I := 0 to Owner.ComponentCount - 1 do begin + c := Owner.Components[I]; + if IsVCLControl(c) then begin + FLocked := True; + Showmessage('Form ' + Owner.name + ' contains VCL controls and can not ' + + 'be converted to KOL form properly. TKOLForm component is locked. ' + + 'Remove VCL controls first, then unlock TKOLForm component.'); + LogOK; + Exit; + end; + end; + + Log('-2'); + fUniqueID := 5000; + Rpt('----------- UNIQUE ID = ' + IntToStr(fUniqueID), WHITE); + if formUnit = '' then begin + Rpt('Error: FormUnit = ''''', RED); + LogOK; + Exit; + end; + + Log('-3'); + PasUpdated := False; + IncUpdated := False; + PAS := GeneratePAS(Path, PasUpdated); + Log('-4'); + Inc := GenerateINC(Path, IncUpdated); + Log('-5'); + Updated := PasUpdated or IncUpdated; + Result := PAS and Inc; + if Result and Updated then begin + Log('-6'); + // force mark modified here + if PasUpdated then + MarkModified(Path + '.pas'); + if IncUpdated then begin + MarkModified(Path + '_1.inc'); + UpdateUnit(Path + '_1.inc'); + end; end; end; - end; - Log('-7'); - LogOK; + Log('-7'); + LogOK; finally - Log( '<-TKOLForm.GenerateUnit' ); + Log('<-TKOLForm.GenerateUnit'); end; end; @@ -13622,14 +11311,14 @@ begin DB 'TKOLForm.GetCaption', 0 @@e_signature: end; - Log( '->TKOLForm.GetCaption' ); + Log('->TKOLForm.GetCaption'); try - Result := FCaption; - if (Owner <> nil) and (Owner is TForm) then - Result := (Owner as TForm).Caption; - LogOK; + Result := fCaption; + if (Owner <> nil) and (Owner is TForm) then + Result := (Owner as TForm).Caption; + LogOK; finally - Log( '<-TKOLForm.GetCaption' ); + Log('<-TKOLForm.GetCaption'); end; end; @@ -13641,14 +11330,14 @@ begin DB 'TKOLForm.GetFormMain', 0 @@e_signature: end; - Log( '->TKOLForm.GetFormMain' ); + Log('->TKOLForm.GetFormMain'); try - Result := fFormMain; - if KOLProject <> nil then - Result := KOLProject.Owner = Owner; - LogOK; + Result := fFormMain; + if KOLProject <> nil then + Result := KOLProject.Owner = Owner; + LogOK; finally - Log( '<-TKOLForm.GetFormMain' ); + Log('<-TKOLForm.GetFormMain'); end; end; @@ -13662,22 +11351,23 @@ begin end; //Log( '->TKOLForm.GetFormName' ); try - Result := ''; - if Owner <> nil then - Result := Owner.Name; - LogOK; + Result := ''; + if Owner <> nil then + Result := Owner.name; + LogOK; finally - //Log( '<-TKOLForm.GetFormName' ); + //Log( '<-TKOLForm.GetFormName' ); end; end; -var LastSrcLocatedWarningTime: Integer; +var + LastSrcLocatedWarningTime: Integer; function TKOLForm.GetFormUnit: KOLString; var - I, J: Integer; - S, S1, S2: KOLString; - Dpr: TStringList; + I, j: Integer; + s, S1, S2: KOLString; + Dpr: TStringList; begin asm jmp @@e_signature @@ -13687,62 +11377,56 @@ begin end; //Log( '->TKOLForm.GetFormUnit' ); try - Result := fFormUnit; - if Result = '' then - if ProjectSourcePath <> '' then - begin - S := ProjectSourcePath; - if S[ Length( S ) ] <> '\' then - S := S + '\'; - S1 := S; - S := S + Get_ProjectName + '.dpr'; - if FileExists( S ) then - begin - Dpr := TStringList.Create; - LoadSource( Dpr, S ); - for I := 0 to Dpr.Count - 1 do - begin - S := Trim( Dpr[ I ] ); - J := pos( '{' + LowerCase( FormName ) + '}', LowerCase( S ) ); - if (J > 0) and (pos( '''', S ) > 0) then - begin - J := pos( '''', S ); - S := Copy( S, J + 1, Length( S ) - J ); - J := pos( '''', S ); - if J > 0 then - begin - S := Copy( S, 1, J - 1 ); - if pos( ':', S ) < 1 then - S := S1 + S; - S2 := ExtractFilePath( S ); - S := ExtractFileName( S ); - if (S2 <> '') and (LowerCase( S2 ) <> LowerCase( S1 )) then - begin - if Abs( Integer( GetTickCount ) - LastSrcLocatedWarningTime ) > 60000 then - begin - LastSrcLocatedWarningTime := GetTickCount; - ShowMessage( 'Source unit ' + S + ' is located not in the same ' + - 'directory as SourcePath of TKOLProject component. ' + - 'This can cause problems with converting project.' ); + Result := fFormUnit; + if Result = '' then + if ProjectSourcePath <> '' then begin + s := ProjectSourcePath; + if s[Length(s)] <> '\' then + s := s + '\'; + S1 := s; + s := s + Get_ProjectName + '.dpr'; + if FileExists(s) then begin + Dpr := TStringList.Create; + LoadSource(Dpr, s); + for I := 0 to Dpr.Count - 1 do begin + s := Trim(Dpr[I]); + j := Pos('{' + LowerCase(formName) + '}', LowerCase(s)); + if (j > 0) and (Pos('''', s) > 0) then begin + j := Pos('''', s); + s := Copy(s, j + 1, Length(s) - j); + j := Pos('''', s); + if j > 0 then begin + s := Copy(s, 1, j - 1); + if Pos(':', s) < 1 then + s := S1 + s; + S2 := ExtractFilePath(s); + s := ExtractFileName(s); + if (S2 <> '') and (LowerCase(S2) <> LowerCase(S1)) then begin + if Abs(Integer(GetTickCount) - LastSrcLocatedWarningTime) > 60000 then begin + LastSrcLocatedWarningTime := GetTickCount; + Showmessage('Source unit ' + s + ' is located not in the same ' + + 'directory as SourcePath of TKOLProject component. ' + + 'This can cause problems with converting project.'); + end; + //LogOK; + Exit; + end; + j := Pos('.', s); + if j > 0 then + s := Copy(s, 1, j - 1); + Result := s; + fFormUnit := s; + //LogOK; + Exit; end; - //LogOK; - Exit; end; - J := pos( '.', S ); - if J > 0 then S := Copy( S, 1, J - 1 ); - Result := S; - fFormUnit := S; - //LogOK; - Exit; end; + Dpr.free; end; end; - Dpr.Free; - end; - end; - //LogOK; + //LogOK; finally - //Log( '<-TKOLForm.GetFormUnit' ); + //Log( '<-TKOLForm.GetFormUnit' ); end; end; @@ -13765,12 +11449,12 @@ begin DB 'TKOLForm.Get_Color', 0 @@e_signature: end; - Log( '->TKOLForm.Get_Color' ); + Log('->TKOLForm.Get_Color'); try - Result := (Owner as TForm).Color; - LogOK; + Result := (Owner as TForm).Color; + LogOK; finally - Log( '<-TKOLForm.Get_Color' ); + Log('<-TKOLForm.Get_Color'); end; end; @@ -13782,20 +11466,22 @@ begin DB 'TKOLForm.SetAlphaBlend', 0 @@e_signature: end; - Log( '->TKOLForm.SetAlphaBlend' ); + Log('->TKOLForm.SetAlphaBlend'); try - if not FLocked then - begin - if not (csLoading in ComponentState) then - if Value = 0 then Value := 256; - if Value < 0 then Value := 255; - if Value > 256 then Value := 256; - FAlphaBlend := Value; - Change( Self ); - end; - LogOK; + if not FLocked then begin + if not (csLoading in ComponentState) then + if Value = 0 then + Value := 256; + if Value < 0 then + Value := 255; + if Value > 256 then + Value := 256; + FAlphaBlend := Value; + Change(Self); + end; + LogOK; finally - Log( '<-TKOLForm.SetAlphaBlend' ); + Log('<-TKOLForm.SetAlphaBlend'); end; end; @@ -13807,20 +11493,19 @@ begin DB 'TKOLForm.SetCanResize', 0 @@e_signature: end; - Log( '->TKOLForm.SetCanResize' ); + Log('->TKOLForm.SetCanResize'); try - if not FLocked then - begin - fCanResize := Value; - {YS} - if (FborderStyle = fbsDialog) and Value then - FborderStyle := fbsSingle; - {YS} - Change( Self ); - end; - LogOK; + if not FLocked then begin + fCanResize := Value; + {YS} + if (FborderStyle = fbsDialog) and Value then + FborderStyle := fbsSingle; + {YS} + Change(Self); + end; + LogOK; finally - Log( '<-TKOLForm.SetCanResize' ); + Log('<-TKOLForm.SetCanResize'); end; end; @@ -13832,16 +11517,15 @@ begin DB 'TKOLForm.SetCenterOnScr', 0 @@e_signature: end; - Log( '->TKOLForm.SetCenterOnScr' ); + Log('->TKOLForm.SetCenterOnScr'); try - if not FLocked then - begin - fCenterOnScr := Value; - Change( Self ); - end; - LogOK; + if not FLocked then begin + fCenterOnScr := Value; + Change(Self); + end; + LogOK; finally - Log( '<-TKOLForm.SetCenterOnScr' ); + Log('<-TKOLForm.SetCenterOnScr'); end; end; @@ -13853,16 +11537,15 @@ begin DB 'TKOLForm.SetCloseIcon', 0 @@e_signature: end; - Log( '->TKOLForm.SetCloseIcon' ); + Log('->TKOLForm.SetCloseIcon'); try - if not FLocked then - begin - FCloseIcon := Value; - Change( Self ); - end; - LogOK; + if not FLocked then begin + FCloseIcon := Value; + Change(Self); + end; + LogOK; finally - Log( '<-TKOLForm.SetCloseIcon' ); + Log('<-TKOLForm.SetCloseIcon'); end; end; @@ -13874,22 +11557,21 @@ begin DB 'TKOLForm.SetCtl3D', 0 @@e_signature: end; - Log( '->TKOLForm.SetCtl3D' ); + Log('->TKOLForm.SetCtl3D'); try - if not FLocked then - begin - FCtl3D := Value; - (Owner as TForm).Ctl3D := Value; - (Owner as TForm).Invalidate; - Change( Self ); - end; - LogOK; + if not FLocked then begin + FCtl3D := Value; + (Owner as TForm).Ctl3D := Value; + (Owner as TForm).Invalidate; + Change(Self); + end; + LogOK; finally - Log( '<-TKOLForm.SetCtl3D' ); + Log('<-TKOLForm.SetCtl3D'); end; end; -procedure TKOLForm.SetCursor(const Value: String); +procedure TKOLForm.SetCursor(const Value: string); begin asm jmp @@e_signature @@ -13897,16 +11579,15 @@ begin DB 'TKOLForm.SetCursor', 0 @@e_signature: end; - Log( '->TKOLForm.SetCursor' ); + Log('->TKOLForm.SetCursor'); try - if not FLocked then - begin - FCursor := UpperCase( Value ); - Change( Self ); - end; - LogOK; + if not FLocked then begin + FCursor := UpperCase(Value); + Change(Self); + end; + LogOK; finally - Log( '<-TKOLForm.SetCursor' ); + Log('<-TKOLForm.SetCursor'); end; end; @@ -13918,16 +11599,15 @@ begin DB 'TKOLForm.SetDefaultPos', 0 @@e_signature: end; - Log( '->TKOLForm.SetDefaultPos' ); + Log('->TKOLForm.SetDefaultPos'); try - if not FLocked then - begin - fDefaultPos := Value; - Change( Self ); - end; - LogOK; + if not FLocked then begin + fDefaultPos := Value; + Change(Self); + end; + LogOK; finally - Log( '<-TKOLForm.SetDefaultPos' ); + Log('<-TKOLForm.SetDefaultPos'); end; end; @@ -13939,16 +11619,15 @@ begin DB 'TKOLForm.SetDefaultSize', 0 @@e_signature: end; - Log( '->TKOLForm.SetDefaultSize' ); + Log('->TKOLForm.SetDefaultSize'); try - if not FLocked then - begin - fDefaultSize := Value; - Change( Self ); - end; - LogOK; + if not FLocked then begin + fDefaultSize := Value; + Change(Self); + end; + LogOK; finally - Log( '<-TKOLForm.SetDefaultSize' ); + Log('<-TKOLForm.SetDefaultSize'); end; end; @@ -13960,17 +11639,16 @@ begin DB 'TKOLForm.SetDoubleBuffered', 0 @@e_signature: end; - Log( '->TKOLForm.SetDoubleBuffered' ); + Log('->TKOLForm.SetDoubleBuffered'); try - if not FLocked then - begin - FDoubleBuffered := Value; - Change( Self ); - end; - LogOK; + if not FLocked then begin + FDoubleBuffered := Value; + Change(Self); + end; + LogOK; finally - Log( '<-TKOLForm.SetDoubleBuffered' ); + Log('<-TKOLForm.SetDoubleBuffered'); end; end; @@ -13982,28 +11660,25 @@ begin DB 'TKOLForm.SetFont', 0 @@e_signature: end; - Log( '->TKOLForm.SetFont' ); + Log('->TKOLForm.SetFont'); try - if not FLocked and not fFont.Equal2( Value ) then - begin - CollectChildrenWithParentFont; - fFont.Assign( Value ); - if KOLProject <> nil then - begin + if not FLocked and not fFont.Equal2(Value) then begin + CollectChildrenWithParentFont; + fFont.Assign(Value); + if KOLProject <> nil then begin FontDefault := fFont.Equal2(KOLProject.DefaultFont); Change(Self); + end; + ApplyFontToChildren; end; - ApplyFontToChildren; - end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetFont' ); + Log('<-TKOLForm.SetFont'); end; end; - procedure TKOLForm.SetFormCaption(const Value: TDelphiString); begin asm @@ -14012,24 +11687,24 @@ begin DB 'TKOLForm.SetFormCaption', 0 @@e_signature: end; - Log( '->TKOLForm.SetFormCaption' ); + Log('->TKOLForm.SetFormCaption'); try - if not FLocked then - begin - inherited Caption := Value; - if (Owner <> nil) and (Owner is TForm) then - (Owner as TForm).Caption := Value; - end; - LogOK; + if not FLocked then begin + inherited Caption := Value; + if (Owner <> nil) and (Owner is TForm) then + (Owner as TForm).Caption := Value; + end; + LogOK; finally - Log( '<-TKOLForm.SetFormCaption' ); + Log('<-TKOLForm.SetFormCaption'); end; end; procedure TKOLForm.SetFormMain(const Value: Boolean); -var I: Integer; - F: TKOLForm; +var + I: Integer; + F: TKOLForm; begin asm jmp @@e_signature @@ -14037,32 +11712,28 @@ begin DB 'TKOLForm.SetFormMain', 0 @@e_signature: end; - Log( '->TKOLForm.SetFormMain' ); + Log('->TKOLForm.SetFormMain'); try - if not FLocked then - begin + if not FLocked then begin - if fFormMain <> Value then - begin - if Value then - begin - for I := 0 to FormsList.Count - 1 do - begin - F := FormsList[ I ]; - if F <> Self then - F.FormMain := False; + if fFormMain <> Value then begin + if Value then begin + for I := 0 to FormsList.Count - 1 do begin + F := FormsList[I]; + if F <> Self then + F.formMain := False; + end; end; + fFormMain := Value; + Change(Self); end; - fFormMain := Value; - Change( Self ); + end; - end; - - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetFormMain' ); + Log('<-TKOLForm.SetFormMain'); end; end; @@ -14074,41 +11745,37 @@ begin DB 'TKOLForm.SetFormName', 0 @@e_signature: end; - Log( '->TKOLForm.SetFormName' ); + Log('->TKOLForm.SetFormName'); try - if not FLocked then - begin + if not FLocked then begin + + if KOLProject = nil then + if (Value <> formName) and (Value <> '') and (formName <> '') then begin + Showmessage('Form name can not be changed properly, if main form (form with ' + + 'TKOLProject component on it) is not opened in designer.'#13 + + 'Operation failed.'); + LogOK; + Exit; + end; + if Owner <> nil then try + Owner.name := Value; + Change(Self); + except + Showmessage('Name "' + Value + '" can not be used as a name for form ' + + 'variable. Use another one, please.'); + LogOK; + Exit; + end; - if KOLProject = nil then - if (Value <> FormName) and (Value <> '') and (FormName <> '') then - begin - ShowMessage( 'Form name can not be changed properly, if main form (form with ' + - 'TKOLProject component on it) is not opened in designer.'#13 + - 'Operation failed.' ); - LogOK; - Exit; - end; - if Owner <> nil then - try - Owner.Name := Value; - Change( Self ); - except - ShowMessage( 'Name "' + Value + '" can not be used as a name for form '+ - 'variable. Use another one, please.' ); - LogOK; - exit; end; - end; - - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetFormName' ); + Log('<-TKOLForm.SetFormName'); end; end; - procedure TKOLForm.SetFormUnit(const Value: KOLString); begin asm @@ -14117,18 +11784,17 @@ begin DB 'TKOLForm.SetFormUnit', 0 @@e_signature: end; - Log( '->TKOLForm.SetFormUnit' ); + Log('->TKOLForm.SetFormUnit'); try - if not FLocked then - begin - fFormUnit := Value; - Change( Self ); - end; + if not FLocked then begin + fFormUnit := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetFormUnit' ); + Log('<-TKOLForm.SetFormUnit'); end; end; @@ -14140,25 +11806,23 @@ begin DB 'TKOLForm.SetHasBorder', 0 @@e_signature: end; - Log( '->TKOLForm.SetHasBorder' ); + Log('->TKOLForm.SetHasBorder'); try - if not FLocked then - begin - FHasBorder := Value; - {YS} - if not Value then - FborderStyle := fbsNone - else - if FborderStyle = fbsNone then + if not FLocked then begin + FHasBorder := Value; + {YS} + if not Value then + FborderStyle := fbsNone + else if FborderStyle = fbsNone then FborderStyle := fbsSingle; - {YS} - Change( Self ); - end; + {YS} + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetHasBorder' ); + Log('<-TKOLForm.SetHasBorder'); end; end; @@ -14170,22 +11834,21 @@ begin DB 'TKOLForm.SetHasCaption', 0 @@e_signature: end; - Log( '->TKOLForm.SetHasCaption' ); + Log('->TKOLForm.SetHasCaption'); try - if not FLocked then - begin - FHasCaption := Value; - Change( Self ); - end; + if not FLocked then begin + FHasCaption := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetHasCaption' ); + Log('<-TKOLForm.SetHasCaption'); end; end; -procedure TKOLForm.SetIcon(const Value: String); +procedure TKOLForm.SetIcon(const Value: string); begin asm jmp @@e_signature @@ -14193,18 +11856,17 @@ begin DB 'TKOLForm.SetIcon', 0 @@e_signature: end; - Log( '->TKOLForm.SetIcon' ); + Log('->TKOLForm.SetIcon'); try - if not FLocked then - begin - FIcon := UpperCase( Value ); - Change( Self ); - end; + if not FLocked then begin + FIcon := UpperCase(Value); + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetIcon' ); + Log('<-TKOLForm.SetIcon'); end; end; @@ -14216,23 +11878,21 @@ begin DB 'TKOLForm.SetMargin', 0 @@e_signature: end; - Log( '->TKOLForm.SetMargin' ); + Log('->TKOLForm.SetMargin'); try - if not FLocked then - begin - if fMargin <> Value then - begin - fMargin := Value; - AlignChildren( nil, FALSE ); - Change( Self ); + if not FLocked then begin + if fMargin <> Value then begin + fMargin := Value; + AlignChildren(nil, False); + Change(Self); + end; + // Invalidate; end; - // Invalidate; - end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetMargin' ); + Log('<-TKOLForm.SetMargin'); end; end; @@ -14244,20 +11904,19 @@ begin DB 'TKOLForm.SetMaximizeIcon', 0 @@e_signature: end; - Log( '->TKOLForm.SetMaximizeIcon' ); + Log('->TKOLForm.SetMaximizeIcon'); try - if not FLocked then - begin - FMaximizeIcon := Value; - if Value then - helpContextIcon := FALSE; - Change( Self ); - end; + if not FLocked then begin + FMaximizeIcon := Value; + if Value then + helpContextIcon := False; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetMaximizeIcon' ); + Log('<-TKOLForm.SetMaximizeIcon'); end; end; @@ -14269,20 +11928,19 @@ begin DB 'TKOLForm.SetMinimizeIcon', 0 @@e_signature: end; - Log( '->TKOLForm.SetMinimizeIcon' ); + Log('->TKOLForm.SetMinimizeIcon'); try - if not FLocked then - begin - FMinimizeIcon := Value; - if Value then - helpContextIcon := FALSE; - Change( Self ); - end; + if not FLocked then begin + FMinimizeIcon := Value; + if Value then + helpContextIcon := False; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetMinimizeIcon' ); + Log('<-TKOLForm.SetMinimizeIcon'); end; end; @@ -14294,15 +11952,15 @@ begin DB 'TKOLForm.SetModalResult', 0 @@e_signature: end; - Log( '->TKOLForm.SetModalResult' ); + Log('->TKOLForm.SetModalResult'); try - if not FLocked then - FModalResult := Value; + if not FLocked then + FModalResult := Value; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetModalResult' ); + Log('<-TKOLForm.SetModalResult'); end; end; @@ -14314,18 +11972,17 @@ begin DB 'TKOLForm.SetOnChar', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnChar' ); + Log('->TKOLForm.SetOnChar'); try - if not FLocked then - begin - FOnChar := Value; - Change( Self ); - end; + if not FLocked then begin + FOnChar := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnChar' ); + Log('<-TKOLForm.SetOnChar'); end; end; @@ -14337,18 +11994,17 @@ begin DB 'TKOLForm.SetOnClick', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnClick' ); + Log('->TKOLForm.SetOnClick'); try - if not FLocked then - begin - fOnClick := Value; - Change( Self ); - end; + if not FLocked then begin + fOnClick := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnClick' ); + Log('<-TKOLForm.SetOnClick'); end; end; @@ -14360,18 +12016,17 @@ begin DB 'TKOLForm.SetOnFormCreate', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnFormCreate' ); + Log('->TKOLForm.SetOnFormCreate'); try - if not FLocked then - begin - FOnFormCreate := Value; - Change( Self ); - end; + if not FLocked then begin + FOnFormCreate := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnFormCreate' ); + Log('<-TKOLForm.SetOnFormCreate'); end; end; @@ -14383,18 +12038,17 @@ begin DB 'TKOLForm.SetOnEnter', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnEnter' ); + Log('->TKOLForm.SetOnEnter'); try - if not FLocked then - begin - FOnEnter := Value; - Change( Self ); - end; + if not FLocked then begin + FOnEnter := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnEnter' ); + Log('<-TKOLForm.SetOnEnter'); end; end; @@ -14406,18 +12060,17 @@ begin DB 'TKOLForm.SetOnKeyDown', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnKeyDown' ); + Log('->TKOLForm.SetOnKeyDown'); try - if not FLocked then - begin - FOnKeyDown := Value; - Change( Self ); - end; + if not FLocked then begin + FOnKeyDown := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnKeyDown' ); + Log('<-TKOLForm.SetOnKeyDown'); end; end; @@ -14429,18 +12082,17 @@ begin DB 'TKOLForm.SetOnKeyUp', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnKeyUp' ); + Log('->TKOLForm.SetOnKeyUp'); try - if not FLocked then - begin - FOnKeyUp := Value; - Change( Self ); - end; + if not FLocked then begin + FOnKeyUp := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnKeyUp' ); + Log('<-TKOLForm.SetOnKeyUp'); end; end; @@ -14452,18 +12104,17 @@ begin DB 'TKOLForm.SetOnLeave', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnLeave' ); + Log('->TKOLForm.SetOnLeave'); try - if not FLocked then - begin - FOnLeave := Value; - Change( Self ); - end; + if not FLocked then begin + FOnLeave := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnLeave' ); + Log('<-TKOLForm.SetOnLeave'); end; end; @@ -14475,18 +12126,17 @@ begin DB 'TKOLForm.SetOnMouseDown', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnMouseDown' ); + Log('->TKOLForm.SetOnMouseDown'); try - if not FLocked then - begin - FOnMouseDown := Value; - Change( Self ); - end; + if not FLocked then begin + FOnMouseDown := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnMouseDown' ); + Log('<-TKOLForm.SetOnMouseDown'); end; end; @@ -14498,18 +12148,17 @@ begin DB 'TKOLForm.SetOnMouseEnter', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnMouseEnter' ); + Log('->TKOLForm.SetOnMouseEnter'); try - if not FLocked then - begin - FOnMouseEnter := Value; - Change( Self ); - end; + if not FLocked then begin + FOnMouseEnter := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnMouseEnter' ); + Log('<-TKOLForm.SetOnMouseEnter'); end; end; @@ -14521,18 +12170,17 @@ begin DB 'TKOLForm.SetOnMouseLeave', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnMouseLeave' ); + Log('->TKOLForm.SetOnMouseLeave'); try - if not FLocked then - begin - FOnMouseLeave := Value; - Change( Self ); - end; + if not FLocked then begin + FOnMouseLeave := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnMouseLeave' ); + Log('<-TKOLForm.SetOnMouseLeave'); end; end; @@ -14544,18 +12192,17 @@ begin DB 'TKOLForm.SetOnMouseMove', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnMouseMove' ); + Log('->TKOLForm.SetOnMouseMove'); try - if not FLocked then - begin - FOnMouseMove := Value; - Change( Self ); - end; + if not FLocked then begin + FOnMouseMove := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnMouseMove' ); + Log('<-TKOLForm.SetOnMouseMove'); end; end; @@ -14567,18 +12214,17 @@ begin DB 'TKOLForm.SetOnMouseUp', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnMouseUp' ); + Log('->TKOLForm.SetOnMouseUp'); try - if not FLocked then - begin - FOnMouseUp := Value; - Change( Self ); - end; + if not FLocked then begin + FOnMouseUp := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnMouseUp' ); + Log('<-TKOLForm.SetOnMouseUp'); end; end; @@ -14590,18 +12236,17 @@ begin DB 'TKOLForm.SetOnMouseWheel', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnMouseWheel' ); + Log('->TKOLForm.SetOnMouseWheel'); try - if not FLocked then - begin - FOnMouseWheel := Value; - Change( Self ); - end; + if not FLocked then begin + FOnMouseWheel := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnMouseWheel' ); + Log('<-TKOLForm.SetOnMouseWheel'); end; end; @@ -14613,18 +12258,17 @@ begin DB 'TKOLForm.SetOnResize', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnResize' ); + Log('->TKOLForm.SetOnResize'); try - if not FLocked then - begin - FOnResize := Value; - Change( Self ); - end; + if not FLocked then begin + FOnResize := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnResize' ); + Log('<-TKOLForm.SetOnResize'); end; end; @@ -14636,18 +12280,17 @@ begin DB 'TKOLForm.SetPreventResizeFlicks', 0 @@e_signature: end; - Log( '->TKOLForm.PreventResizeFlicks' ); + Log('->TKOLForm.PreventResizeFlicks'); try - if not FLocked then - begin - FPreventResizeFlicks := Value; - Change( Self ); - end; + if not FLocked then begin + FPreventResizeFlicks := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.PreventResizeFlicks' ); + Log('<-TKOLForm.PreventResizeFlicks'); end; end; @@ -14659,18 +12302,17 @@ begin DB 'TKOLForm.SetStayOnTop', 0 @@e_signature: end; - Log( '->TKOLForm.SetStayOnTop' ); + Log('->TKOLForm.SetStayOnTop'); try - if not FLocked then - begin - FStayOnTop := Value; - Change( Self ); - end; + if not FLocked then begin + FStayOnTop := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetStayOnTop' ); + Log('<-TKOLForm.SetStayOnTop'); end; end; @@ -14682,35 +12324,38 @@ begin DB 'TKOLForm.SetTransparent', 0 @@e_signature: end; - Log( '->TKOLForm.SetTransparent' ); + Log('->TKOLForm.SetTransparent'); try - if not FLocked then - begin - FTransparent := Value; - Change( Self ); - end; + if not FLocked then begin + FTransparent := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetTransparent' ); + Log('<-TKOLForm.SetTransparent'); end; end; -const BrushStyles: array[ TBrushStyle ] of String = ( 'bsSolid', 'bsClear', - 'bsHorizontal', 'bsVertical', 'bsFDiagonal', 'bsBDiagonal', 'bsCross', - 'bsDiagCross' ); +const + BrushStyles: array[TBrushStyle] of string = ('bsSolid', 'bsClear', + 'bsHorizontal', 'bsVertical', 'bsFDiagonal', 'bsBDiagonal', 'bsCross', + 'bsDiagCross'); + procedure TKOLForm.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -const WindowStates: array[ KOL.TWindowState ] of String = ( 'wsNormal', - 'wsMinimized', 'wsMaximized' ); -var I: Integer; - S: string; {YS} - MainMenuHeight: Integer; - C: String; + AParent, Prefix: string); +const + WindowStates: array[KOL.TWindowState] of string = ('wsNormal', + 'wsMinimized', 'wsMaximized'); +var + I: Integer; + s: string; {YS} + MainMenuHeight: Integer; + c: string; {$IFDEF _D2009orHigher} - C2: WideString; - j : integer; + C2: WideString; + j: Integer; {$ENDIF} begin asm @@ -14719,533 +12364,270 @@ begin DB 'TKOLForm.SetupFirst', 0 @@e_signature: end; - Log( '->TKOLForm.SetupFirst' ); + Log('->TKOLForm.SetupFirst'); try - if FLocked then - begin - Rpt( 'Form ' + Name + ' is LOCKED.', YELLOW ); - LogOK; Exit; - end; + if FLocked then begin + Rpt('Form ' + name + ' is LOCKED.', YELLOW); + LogOK; + Exit; + end; - // Установка каких-либо свойств формы - тех, которые выполняются - // сразу после конструирования объекта формы: - if Unicode then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormSetUnicode', '' ) + // Установка каких-либо свойств формы - тех, которые выполняются + // сразу после конструирования объекта формы: + if Unicode then + SL.Add(' Result.Form.SetUnicode(TRUE);'); + SetupName(SL, AName, AParent, Prefix); + if Tag <> 0 then begin + if Tag < 0 then + SL.Add(Prefix + AName + '.Tag := DWORD(' + IntToStr(Tag) + ');') else - SL.Add( ' Result.Form.SetUnicode(TRUE);' ); - SetupName( SL, AName, AParent, Prefix ); - if Tag <> 0 then - begin - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetTag', '' ); - FormAddNumParameter( Tag ); - end - else - if Tag < 0 then - SL.Add( Prefix + AName + '.Tag := DWORD(' + IntToStr( Tag ) + ');' ) - else - SL.Add( Prefix + AName + '.Tag := ' + IntToStr( Tag ) + ';' ); - end; + SL.Add(Prefix + AName + '.Tag := ' + IntToStr(Tag) + ';'); + end; - //Log( '&2 TKOLForm.SetupFirst' ); + //Log( '&2 TKOLForm.SetupFirst' ); - if not statusSizeGrip then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormSizeGripFalse', '' ) - else - SL.Add( Prefix + AName + '.SizeGrip := FALSE;' ); + if not statusSizeGrip then + SL.Add(Prefix + AName + '.SizeGrip := FALSE;'); - //Log( '&3 TKOLForm.SetupFirst' ); + //Log( '&3 TKOLForm.SetupFirst' ); -{YS} - if FormCompact then - begin - I := 0; + {YS} + s := ''; case FborderStyle of - fbsDialog: I := I or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; - fbsToolWindow: I := I or WS_EX_TOOLWINDOW; - end; - if helpContextIcon then - I := I or WS_EX_CONTEXTHELP; - if I <> 0 then - begin - FormAddCtlCommand( 'Form', 'FormSetExStyle', '' ); - FormAddNumParameter( I ); - end; - end - else - begin - S := ''; - case FborderStyle of - fbsDialog: - S := S + ' or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE'; - fbsToolWindow: - S := S + ' or WS_EX_TOOLWINDOW'; + fbsDialog: + s := s + ' or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE'; + fbsToolWindow: + s := s + ' or WS_EX_TOOLWINDOW'; end; //Log( '&4 TKOLForm.SetupFirst' ); - if helpContextIcon then - S := S + ' or WS_EX_CONTEXTHELP'; - if S <> '' then - SL.Add( Prefix + AName + '.ExStyle := ' + AName + '.ExStyle' + S + ';' ); - end; - //Log( '&5 TKOLForm.SetupFirst' ); + if helpContextIcon then + s := s + ' or WS_EX_CONTEXTHELP'; + if s <> '' then + SL.Add(Prefix + AName + '.ExStyle := ' + AName + '.ExStyle' + s + ';'); + //Log( '&5 TKOLForm.SetupFirst' ); -{YS} - if not Visible then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormSetVisibleFalse', '' ) - else - SL.Add( Prefix + AName + '.Visible := False;' ); + {YS} + if not Visible then + SL.Add(Prefix + AName + '.Visible := False;'); - if not Enabled then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormSetEnabledFalse', '' ) - else - SL.Add( Prefix + AName + '.Enabled := False;' ); + if not Enabled then + SL.Add(Prefix + AName + '.Enabled := False;'); - if DoubleBuffered and not Transparent then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormSetDoubleBufferedTrue', '' ) - else - SL.Add( Prefix + AName + '.DoubleBuffered := True;' ); -{YS} + if DoubleBuffered and not Transparent then + SL.Add(Prefix + AName + '.DoubleBuffered := True;'); + {YS} - //Log( '&6 TKOLForm.SetupFirst' ); + //Log( '&6 TKOLForm.SetupFirst' ); - if FormCompact then - begin - I := 0; - CASE FborderStyle OF - fbsDialog: I := I or WS_MINIMIZEBOX or WS_MAXIMIZEBOX; - fbsToolWindow, fbsNone: ; - else - if not MinimizeIcon and not MaximizeIcon then - I := I or WS_MINIMIZEBOX or WS_MAXIMIZEBOX - else - begin - if not MinimizeIcon then - I := I or WS_MINIMIZEBOX; - if not MaximizeIcon then - I := I or WS_MAXIMIZEBOX; - end; - END; - if I <> 0 then - begin - FormAddCtlCommand( 'Form', 'FormResetStyles', '' ); - FormAddNumParameter( I ); - end; - end - else - begin - S := ''; + s := ''; case FborderStyle of fbsDialog: - S := S + ' and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX)'; + s := s + ' and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX)'; fbsToolWindow, fbsNone: ; - else - begin - if not MinimizeIcon and not MaximizeIcon then - S := S + ' and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX)' - else - begin - if not MinimizeIcon then - S := S + ' and not WS_MINIMIZEBOX'; - if not MaximizeIcon then - S := S + ' and not WS_MAXIMIZEBOX'; - end; + else begin + if not minimizeIcon and not maximizeIcon then + s := s + ' and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX)' + else begin + if not minimizeIcon then + s := s + ' and not WS_MINIMIZEBOX'; + if not maximizeIcon then + s := s + ' and not WS_MAXIMIZEBOX'; end; + end; end; //Log( '&7 TKOLForm.SetupFirst' ); //if not CanResize then // S := S + ' and not WS_THICKFRAME'; - if S <> '' then - SL.Add( Prefix + AName + '.Style := ' + AName + '.Style' + S + ';' ); - end; + if s <> '' then + SL.Add(Prefix + AName + '.Style := ' + AName + '.Style' + s + ';'); - if not DefaultSize then - begin - if HasCaption then - begin - if HasMainMenu then - MainMenuHeight := GetSystemMetrics( SM_CYMENU ) - else - MainMenuHeight := 0; - if HasBorder then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetClientSize', '' ); - FormAddNumParameter( (Owner as TForm).ClientWidth ); - FormAddNumParameter( (Owner as TForm).ClientHeight + MainMenuHeight ); - end - else - SL.Add( Prefix + AName + '.SetClientSize( ' + - IntToStr( (Owner as TForm).ClientWidth ) + - ', ' + IntToStr( (Owner as TForm).ClientHeight + MainMenuHeight ) + ' );' ); - end - //+++++++ UaFM - else - if HasBorder then - if FormCompact then - begin - Form.FormAddCtlCommand( 'Form', 'FormSetClientSize', '' ); - Form.FormAddNumParameter( (Owner as TForm).ClientWidth ); - Form.FormAddNumParameter( (Owner as TForm).ClientHeight-GetSystemMetrics(SM_CYCAPTION) ); - end - else - SL.Add( Prefix + AName + '.SetClientSize( ' + - IntToStr( (Owner as TForm).ClientWidth ) + - ', ' + - IntToStr( (Owner as TForm).ClientHeight-GetSystemMetrics(SM_CYCAPTION) ) - + ');' ); - end; - - //Log( '&8 TKOLForm.SetupFirst' ); - -{YS} - - if Transparent then - if FormCompact then - FormAddCtlCommand( Name, 'TControl.SetTransparent', '' ) // param = 1 - else - SL.Add( Prefix + AName + '.Transparent := True;' ); - - if (AlphaBlend <> 255) and (AlphaBlend > 0) then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetAlphaBlend', '' ); - FormAddNumParameter( AlphaBlend and $FF ); - end + if not defaultSize then begin + if HasCaption then begin + if HasMainMenu then + MainMenuHeight := GetSystemMetrics(SM_CYMENU) else - SL.Add( Prefix + AName + '.AlphaBlend := ' + IntToStr( AlphaBlend and $FF ) + ';' ); - - if not HasBorder then - begin - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetHasBorderFalse', '' ); - FormAddCtlCommand( 'Form', 'FormSetClientSize', '' ); - FormAddNumParameter( (Owner as TForm).ClientWidth ); - FormAddNumParameter( (Owner as TForm).ClientHeight ); + MainMenuHeight := 0; + if HasBorder then + SL.Add(Prefix + AName + '.SetClientSize( ' + + IntToStr((Owner as TForm).ClientWidth) + + ', ' + IntToStr((Owner as TForm).ClientHeight + MainMenuHeight) + ' );'); end - else - begin - SL.Add( Prefix + AName + '.HasBorder := False;' ); - SL.Add( Prefix + AName + '.SetClientSize( ' + - IntToStr( (Owner as TForm).ClientWidth ) + - ', ' + IntToStr( (Owner as TForm).ClientHeight ) - + ');' ); + //+++++++ UaFM + else if HasBorder then + SL.Add(Prefix + AName + '.SetClientSize( ' + + IntToStr((Owner as TForm).ClientWidth) + + ', ' + + IntToStr((Owner as TForm).ClientHeight - GetSystemMetrics(SM_CYCAPTION)) + + ');'); + end; + + //Log( '&8 TKOLForm.SetupFirst' ); + + {YS} + + if Transparent then + SL.Add(Prefix + AName + '.Transparent := True;'); + + if (AlphaBlend <> 255) and (AlphaBlend > 0) then + SL.Add(Prefix + AName + '.AlphaBlend := ' + IntToStr(AlphaBlend and $FF) + ';'); + + if not HasBorder then begin + SL.Add(Prefix + AName + '.HasBorder := False;'); + SL.Add(Prefix + AName + '.SetClientSize( ' + + IntToStr((Owner as TForm).ClientWidth) + + ', ' + IntToStr((Owner as TForm).ClientHeight) + + ');'); + end; + + if not HasCaption and HasBorder then + SL.Add(Prefix + AName + '.HasCaption := False;'); + + if StayOnTop then + SL.Add(Prefix + AName + '.StayOnTop := True;'); + + if not Ctl3D then + SL.Add(Prefix + AName + '.Ctl3D := False;'); + + if Icon <> '' then begin + if Copy(Icon, 1, 1) = '#' then // +Alexander Pravdin + SL.Add(Prefix + AName + '.IconLoad( hInstance, MAKEINTRESOURCE( ' + + Copy(Icon, 2, Length(Icon) - 1) + ' ) );') + else if Copy(Icon, 1, 4) = 'IDC_' then + SL.Add(Prefix + AName + '.IconLoadCursor( 0, MAKEINTRESOURCE(' + Icon + ') );') + else if Copy(Icon, 1, 4) = 'IDI_' then + SL.Add(Prefix + AName + '.IconLoadCursor( 0, MAKEINTRESOURCE(' + Icon + ') );') + else if Icon = '-1' then + SL.Add(Prefix + AName + '.Icon := THandle(-1);') + else + SL.Add(Prefix + AName + '.IconLoad( hInstance, ''' + Icon + ''' );'); + end; + + if WindowState <> KOL.wsNormal then + SL.Add(Prefix + AName + '.WindowState := ' + WindowStates[WindowState] + ';'); + + if Trim(Cursor) <> '' then begin + if Copy(Cursor, 1, 4) = 'IDC_' then + SL.Add(Prefix + AName + '.CursorLoad( 0, ' + Cursor + ' );') + else + SL.Add(Prefix + AName + '.CursorLoad( hInstance, ''' + Trim(Cursor) + ''' );'); + end; + + if Brush <> nil then + Brush.GenerateCode(SL, AName); + + if (Font <> nil) then begin + if FontDefault and (KOLProject <> nil) + and Assigned(KOLProject.DefaultFont) + and not KOLProject.DefaultFont.Equal2(nil) + and not KOLProject.DefaultFont.Equal2(Font) then begin + Rpt('KOLProject font is assigned to form.Font', WHITE); + Font.Assign(KOLProject.DefaultFont); + Rpt('KOLProject font was assigned to form.Font', WHITE); end; - end; + if not Font.Equal2(nil) then begin + Font.GenerateCode(SL, AName, nil); + Rpt('form font code generated', WHITE); + end; + end; - if not HasCaption and HasBorder then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormSetHasCaptionFalse', '' ) - else - SL.Add( Prefix + AName + '.HasCaption := False;' ); + if (Border <> 2) then + SL.Add(Prefix + AName + '.Border := ' + IntToStr(Border) + ';'); - if StayOnTop then - if FormCompact then - FormAddCtlCommand( 'Form', 'TControl.SetStayOnTop', '' ) - else - SL.Add( Prefix + AName + '.StayOnTop := True;' ); + if MarginTop <> 0 then + SL.Add(Prefix + AName + '.MarginTop := ' + IntToStr(MarginTop) + ';'); - if not Ctl3D then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormResetCtl3D', '' ) - else - SL.Add( Prefix + AName + '.Ctl3D := False;' ); + if MarginBottom <> 0 then + SL.Add(Prefix + AName + '.MarginBottom := ' + IntToStr(MarginBottom) + ';'); - if Icon <> '' then - begin - if Copy( Icon, 1, 1 ) = '#' then // +Alexander Pravdin - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormIconLoad_hInstance', '' ); - FormAddNumParameter( StrToInt( Copy( Icon, 2, Length( Icon ) - 1 ) ) ) - end - else - SL.Add( Prefix + AName + '.IconLoad( hInstance, MAKEINTRESOURCE( ' + - Copy( Icon, 2, Length( Icon ) - 1 ) + ' ) );' ) - else - if Copy( Icon, 1, 4 ) = 'IDC_' then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormIconLoadCursor_0', '' ); - FormAddNumParameter( IDC2Number( Icon ) ); - end - else - SL.Add( Prefix + AName + '.IconLoadCursor( 0, MAKEINTRESOURCE(' + Icon + ') );' ) - else - if Copy( Icon, 1, 4 ) = 'IDI_' then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormIconLoadCursor_0', '' ); - FormAddNumParameter( IDI2Number( Icon ) ); - end - else - SL.Add( Prefix + AName + '.IconLoadCursor( 0, MAKEINTRESOURCE(' + Icon + ') );' ) - else - if Icon = '-1' then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormSetIconNeg1', '' ) - else - SL.Add( Prefix + AName + '.Icon := THandle(-1);' ) - else - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormIconLoad_hInstance_str', '' ); - FormAddStrParameter( Icon ) - end - else - SL.Add( Prefix + AName + '.IconLoad( hInstance, ''' + Icon + ''' );' ); - end; + if MarginLeft <> 0 then + SL.Add(Prefix + AName + '.MarginLeft := ' + IntToStr(MarginLeft) + ';'); - if WindowState <> KOL.wsNormal then - if FormCompact then - begin - if Integer( WindowState ) = 1 then - begin - FormAddCtlCommand( 'Form', 'TControl.SetWindowState', '' ); - // param = 1 - end - else - begin - FormAddCtlCommand( 'Form', 'FormSetWindowState', '' ); - FormAddNumParameter( Integer( WindowState ) ); - end; + if MarginRight <> 0 then + SL.Add(Prefix + AName + '.MarginRight := ' + IntToStr(MarginRight) + ';'); + + RptDetailed('margins ready', WHITE); + + if (FStatusText <> nil) and (FStatusText.Text <> '') then begin + if FStatusText.Count = 1 then begin +{$IFDEF _D2009orHigher} + c := FStatusText[0]; + C2 := ''; + for j := 1 to Length(c) do + C2 := C2 + '#' + int2str(Ord(c[j])); + c := C2; +{$ELSE} + c := PCharStringConstant(Self, 'SimpleStatusText', FStatusText[0]); +{$ENDIF} + SL.Add(Prefix + AName + '.SimpleStatusText := ' + c + ';'); end - else - SL.Add( Prefix + AName + '.WindowState := ' + WindowStates[ WindowState ] + - ';' ); - - if Trim( Cursor ) <> '' then - begin - if Copy( Cursor, 1, 4 ) = 'IDC_' then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormCursorLoad_0', '' ); - FormAddNumParameter( IDC2Number( Cursor ) ); - end - else - SL.Add( Prefix + AName + '.CursorLoad( 0, ' + Cursor + ' );' ) - else - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormCursorLoad_hInstance', '' ); - FormAddStrParameter( Trim( Cursor ) ); - end - else - SL.Add( Prefix + AName + '.CursorLoad( hInstance, ''' + Trim( Cursor ) + ''' );' ); - end; - - if Brush <> nil then - Brush.GenerateCode( SL, AName ); - - if (Font <> nil) then - begin - if FontDefault and (KOLProject <> nil) - and Assigned(KOLProject.DefaultFont) - and not KOLProject.DefaultFont.Equal2(nil) - and not KOLProject.DefaultFont.Equal2(Font) then - begin - Rpt( 'KOLProject font is assigned to form.Font', WHITE ); - Font.Assign(KOLProject.DefaultFont); - Rpt( 'KOLProject font was assigned to form.Font', WHITE ); - end; - if not Font.Equal2( nil ) then - begin - Font.GenerateCode( SL, AName, nil ); - Rpt( 'form font code generated', WHITE ); - end; - end; - - if (Border <> 2) then - if FormCompact then - begin - if Border = 1 then - begin - FormAddCtlCommand( 'Form', 'TControl.SetBorder', '' ); - // param = 1 - end - else - begin - FormAddCtlCommand( 'Form', 'FormSetBorder', '' ); - FormAddNumParameter( Border ); - end; - end else - SL.Add( Prefix + AName + '.Border := ' + IntToStr( Border ) + ';' ); - - if MarginTop <> 0 then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetMarginTop', '' ); - FormAddNumParameter( MarginTop ); - end else - SL.Add( Prefix + AName + '.MarginTop := ' + IntToStr( MarginTop ) + ';' ); - - if MarginBottom <> 0 then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetMarginBottom', '' ); - FormAddNumParameter( MarginBottom ); - end else - SL.Add( Prefix + AName + '.MarginBottom := ' + IntToStr( MarginBottom ) + ';' ); - - if MarginLeft <> 0 then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetMarginLeft', '' ); - FormAddNumParameter( MarginLeft ); - end else - SL.Add( Prefix + AName + '.MarginLeft := ' + IntToStr( MarginLeft ) + ';' ); - - if MarginRight <> 0 then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetMarginRight', '' ); - FormAddNumParameter( MarginRight ); - end else - SL.Add( Prefix + AName + '.MarginRight := ' + IntToStr( MarginRight ) + ';' ); - - RptDetailed( 'margins ready', WHITE ); - - if (FStatusText <> nil) and (FStatusText.Text <> '') then - begin - if FStatusText.Count = 1 then - begin - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetSimpleStatusText', '' ); - FormAddStrParameter( FStatusText[ 0 ] ); - end else - begin - {$IFDEF _D2009orHigher} - C := FStatusText[ 0 ]; + else begin + for I := 0 to FStatusText.Count - 1 do begin +{$IFDEF _D2009orHigher} + c := FStatusText[I]; C2 := ''; - for j := 1 to Length(C) do C2 := C2 + '#'+int2str(ord(C[j])); - C := C2; - {$ELSE} - C := PCharStringConstant( Self, 'SimpleStatusText', FStatusText[ 0 ] ); - {$ENDIF} - SL.Add( Prefix + AName + '.SimpleStatusText := ' + C + ';' ); - end; - end - else - begin - for I := 0 to FStatusText.Count-1 do - begin - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetStatusText', '' ); - FormAddNumParameter( I ); - FormAddStrParameter( FStatusText[ I ] ); - end else - begin - {$IFDEF _D2009orHigher} - C := FStatusText[ I ]; - C2 := ''; - for j := 1 to Length(C) do - C2 := C2 + '#'+int2str(ord(C[j])); - C := C2; - {$ELSE} - C := PCharStringConstant( Self, 'StatusText' + IntToStr( I ), FStatusText[ I ] ); - {$ENDIF} - SL.Add( Prefix + AName + '.StatusText[ ' + IntToStr( I ) + ' ] := ' + C + ';' ); - end; + for j := 1 to Length(c) do + C2 := C2 + '#' + int2str(Ord(c[j])); + c := C2; +{$ELSE} + c := PCharStringConstant(Self, 'StatusText' + IntToStr(I), FStatusText[I]); +{$ENDIF} + SL.Add(Prefix + AName + '.StatusText[ ' + IntToStr(I) + ' ] := ' + c + ';'); end; end; - end; + end; - if not CloseIcon then - begin - if FormCompact then - FormAddCtlCommand( 'Form', 'FormRemoveCloseIcon', '' ) - else - SL.Add( Prefix + 'DeleteMenu( GetSystemMenu( Result.Form.GetWindowHandle, ' + - 'False ), SC_CLOSE, MF_BYCOMMAND );' ); - end; + if not closeIcon then begin + SL.Add(Prefix + 'DeleteMenu( GetSystemMenu( Result.Form.GetWindowHandle, ' + + 'False ), SC_CLOSE, MF_BYCOMMAND );'); + end; - if EraseBackground then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormSetEraseBkgndTrue', '' ) - else - SL.Add( Prefix + AName + '.EraseBackground := TRUE;' ); + if EraseBackground then + SL.Add(Prefix + AName + '.EraseBackground := TRUE;'); - if MinWidth > 0 then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetMinWidth', '' ); - FormAddNumParameter( MinWidth ); - end else - SL.Add( Prefix + AName + '.MinWidth := ' + IntToStr( MinWidth ) + ';' ); + if MinWidth > 0 then + SL.Add(Prefix + AName + '.MinWidth := ' + IntToStr(MinWidth) + ';'); - if MinHeight > 0 then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetMinHeight', '' ); - FormAddNumParameter( MinHeight ); - end else - SL.Add( Prefix + AName + '.MinHeight := ' + IntToStr( MinHeight ) + ';' ); + if MinHeight > 0 then + SL.Add(Prefix + AName + '.MinHeight := ' + IntToStr(MinHeight) + ';'); - if MaxWidth > 0 then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetMaxWidth', '' ); - FormAddNumParameter( MaxWidth ); - end else - SL.Add( Prefix + AName + '.MaxWidth := ' + IntToStr( MaxWidth ) + ';' ); + if MaxWidth > 0 then + SL.Add(Prefix + AName + '.MaxWidth := ' + IntToStr(MaxWidth) + ';'); - if MaxHeight > 0 then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetMaxHeight', '' ); - FormAddNumParameter( MaxHeight ); - end else - SL.Add( Prefix + AName + '.MaxHeight := ' + IntToStr( MaxHeight ) + ';' ); + if MaxHeight > 0 then + SL.Add(Prefix + AName + '.MaxHeight := ' + IntToStr(MaxHeight) + ';'); - if KeyPreview then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetKeyPreviewTrue', '' ); - end else - SL.Add( Prefix + AName + '.KeyPreview := TRUE;' ); + if KeyPreview then + SL.Add(Prefix + AName + '.KeyPreview := TRUE;'); - if AllBtnReturnClick then - begin - if FormMain and not AppletOnForm then - begin - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'TControl.AllBtnReturnClick', '' ); - end else - SL.Add( Prefix + AName + '.AllBtnReturnClick;' ); + if AllBtnReturnClick then begin + if formMain and not AppletOnForm then begin + SL.Add(Prefix + AName + '.AllBtnReturnClick;'); end; - end; - RptDetailed( 'Before AssignEvents for form', WHITE ); + end; + RptDetailed('Before AssignEvents for form', WHITE); - FAssignOnlyUserEvents := FALSE; - FAssignOnlyWinEvents := FALSE; - AssignEvents( SL, AName ); + FAssignOnlyUserEvents := False; + FAssignOnlyWinEvents := False; + AssignEvents(SL, AName); - RptDetailed( 'After AssignEvents for form', WHITE ); + RptDetailed('After AssignEvents for form', WHITE); - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetupFirst' ); + Log('<-TKOLForm.SetupFirst'); end; end; procedure TKOLForm.SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); -var S: String; + AParent, Prefix: string); +var + s: string; begin asm jmp @@e_signature @@ -15253,83 +12635,49 @@ begin DB 'TKOLForm.SetupLast', 0 @@e_signature: end; - Log( '->TKOLForm.SetupLast' ); + Log('->TKOLForm.SetupLast'); try - if not FLocked then - begin - S := ''; - if CenterOnCurrentScreen then - begin - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'TControl.CenterOnCurrentScreen', '' ); - end else - S := Prefix + AName + '.CenterOnCurrentScreen'; + if not FLocked then begin + s := ''; + if CenterOnCurrentScreen then begin + s := Prefix + AName + '.CenterOnCurrentScreen'; end - else - if CenterOnScreen then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'TControl.CenterOnParent', '' ); - end else - S := Prefix + AName + '.CenterOnParent'; + else if CenterOnScreen then + s := Prefix + AName + '.CenterOnParent'; - if not CanResize then - begin - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormSetCanResizeFalse', '' ); - end - else - begin - if S = '' then - S := Prefix + AName; - S := S + '.CanResize := False' - end; + if not CanResize then begin + if s = '' then + s := Prefix + AName; + s := s + '.CanResize := False' end; - if (S <> '') and not FormCompact then - SL.Add( S + ';' ); + if (s <> '') then + SL.Add(s + ';'); - if not CanResize or not MinimizeIcon or not MaximizeIcon then - if FormCompact then - begin - FormAddCtlCommand( 'Form', 'FormInitMenu', '' ); - end else - SL.Add( Prefix + AName + '.Perform( WM_INITMENU, 0, 0 );' ); + if not CanResize or not minimizeIcon or not maximizeIcon then + SL.Add(Prefix + AName + '.Perform( WM_INITMENU, 0, 0 );'); - if MinimizeNormalAnimated then - if FormCompact then - FormAddCtlCommand( 'Form', 'TControl.MinimizeNormalAnimated', '' ) - else - SL.Add( Prefix + AName + '.MinimizeNormalAnimated;' ) - else - if RestoreNormalMaximized then - if FormCompact then - FormAddCtlCommand( 'Form', 'TControl.RestoreNormalMaximized', '' ) - else - SL.Add( Prefix + AName + '.RestoreNormalMaximized;' ); + if MinimizeNormalAnimated then + SL.Add(Prefix + AName + '.MinimizeNormalAnimated;') + else if RestoreNormalMaximized then + SL.Add(Prefix + AName + '.RestoreNormalMaximized;'); - if Assigned( FpopupMenu ) then - SL.Add( Prefix + AName + '.SetAutoPopupMenu( Result.' + FpopupMenu.Name + - ' );' ); + if Assigned(FpopupMenu) then + SL.Add(Prefix + AName + '.SetAutoPopupMenu( Result.' + FpopupMenu.name + + ' );'); - if @ OnFormCreate <> nil then - begin - SL.Add( Prefix + 'Result.' + (Owner as TForm).MethodName( @ OnFormCreate ) + '( Result );' ); + if @OnFormCreate <> nil then begin + SL.Add(Prefix + 'Result.' + (Owner as TForm).MethodName(@OnFormCreate) + '( Result );'); end; - {YS} - if FborderStyle = fbsDialog then - if FormCompact then - FormAddCtlCommand( 'Form', 'FormSetIconNeg1', '' ) - else - SL.Add( Prefix + AName + '.Icon := THandle(-1);' ); - {YS} - end; + {YS} + if FborderStyle = fbsDialog then + SL.Add(Prefix + AName + '.Icon := THandle(-1);'); + {YS} + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetupLast' ); + Log('<-TKOLForm.SetupLast'); end; end; @@ -15341,35 +12689,33 @@ begin DB 'TKOLForm.SetWindowState', 0 @@e_signature: end; - Log( '->TKOLForm.SetWindowState' ); + Log('->TKOLForm.SetWindowState'); try - if not FLocked then - begin - FWindowState := Value; - Change( Self ); - end; + if not FLocked then begin + FWindowState := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetWindowState' ); + Log('<-TKOLForm.SetWindowState'); end; end; procedure TKOLForm.Set_Bounds(const Value: TFormBounds); begin - if (fBounds.Left=Value.Left) - and (fBounds.Top =Value.Top ) - and (fBounds.Width = Value.Width) - and (fBounds.Height= Value.Height) then - Exit; + if (fBounds.Left = Value.Left) + and (fBounds.Top = Value.Top) + and (fBounds.Width = Value.Width) + and (fBounds.Height = Value.Height) then + Exit; fBounds := Value; - if Owner is TCustomForm then - begin - (Owner as TCustomForm).Left := Value.Left; - (Owner as TCustomForm).Top := Value.Top; - (Owner as TCustomForm).Width:= Value.Width; - (Owner as TCustomForm).Height := Value.Height; + if Owner is TCustomForm then begin + (Owner as TCustomForm).Left := Value.Left; + (Owner as TCustomForm).Top := Value.Top; + (Owner as TCustomForm).Width := Value.Width; + (Owner as TCustomForm).Height := Value.Height; end; end; @@ -15381,30 +12727,29 @@ begin DB 'TKOLForm.Set_Color', 0 @@e_signature: end; - Log( '->TKOLForm.Set_Color' ); + Log('->TKOLForm.Set_Color'); try - if not FLocked then - begin - if Color <> Value then - begin - CollectChildrenWithParentColor; - (Owner as TForm).Color := Value; - FBrush.FColor := Value; - ApplyColorToChildren; - Change( Self ); + if not FLocked then begin + if Color <> Value then begin + CollectChildrenWithParentColor; + (Owner as TForm).Color := Value; + fBrush.FColor := Value; + ApplyColorToChildren; + Change(Self); + end; end; - end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.Set_Color' ); + Log('<-TKOLForm.Set_Color'); end; end; procedure TKOLForm.ApplyFontToChildren; -var I: Integer; - C: TKOLCustomControl; +var + I: Integer; + c: TKOLCustomControl; begin asm jmp @@e_signature @@ -15412,29 +12757,28 @@ begin DB 'TKOLForm.ApplyFontToChildren', 0 @@e_signature: end; - Log( '->TKOLForm.ApplyFontToChildren' ); + Log('->TKOLForm.ApplyFontToChildren'); try - if not FLocked then - begin - for I := 0 to FParentLikeFontControls.Count - 1 do - begin - C := FParentLikeFontControls[ I ]; - //if C.parentFont then - C.Font.Assign( Font ); - end; - end; + if not FLocked then begin + for I := 0 to FParentLikeFontControls.Count - 1 do begin + c := FParentLikeFontControls[I]; + //if C.parentFont then + c.Font.Assign(Font); + end; + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.ApplyFontToChildren' ); + Log('<-TKOLForm.ApplyFontToChildren'); end; end; procedure TKOLForm.CollectChildrenWithParentFont; -var ParentForm: TForm; - I: Integer; - C: TComponent; +var + ParentForm: TForm; + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -15442,33 +12786,32 @@ begin DB 'TKOLForm.CollectChildrenWithParentFont', 0 @@e_signature: end; - Log( '->TKOLForm.CollectChildrenWithParentFont' ); + Log('->TKOLForm.CollectChildrenWithParentFont'); try - if not (Owner is TForm) then - begin - LogOK; - Exit; - end; - ParentForm := Owner as TForm; - FParentLikeFontControls.Clear; - for I := 0 to ParentForm.ComponentCount - 1 do - begin - C := ParentForm.Components[ I ]; - if (C is TKOLCustomControl) and ((C as TKOLCustomControl).Parent = ParentForm) then - if (C as TKOLCustomControl).parentFont then - FParentLikeFontControls.Add( C ); - end; + if not (Owner is TForm) then begin + LogOK; + Exit; + end; + ParentForm := Owner as TForm; + FParentLikeFontControls.Clear; + for I := 0 to ParentForm.ComponentCount - 1 do begin + c := ParentForm.Components[I]; + if (c is TKOLCustomControl) and ((c as TKOLCustomControl).Parent = ParentForm) then + if (c as TKOLCustomControl).parentFont then + FParentLikeFontControls.Add(c); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.CollectChildrenWithParentFont' ); + Log('<-TKOLForm.CollectChildrenWithParentFont'); end; end; procedure TKOLForm.ApplyColorToChildren; -var I: Integer; - C: TKOLCustomControl; +var + I: Integer; + c: TKOLCustomControl; begin asm jmp @@e_signature @@ -15476,29 +12819,28 @@ begin DB 'TKOLForm.ApplyColorToChildren', 0 @@e_signature: end; - Log( '->TKOLForm.ApplyColorToChildren' ); + Log('->TKOLForm.ApplyColorToChildren'); try - if not FLocked then - begin - for I := 0 to FParentLikeColorControls.Count - 1 do - begin - C := FParentLikeColorControls[ I ]; - if C.parentColor and (C.Color <> Color) then - C.Color := Color; + if not FLocked then begin + for I := 0 to FParentLikeColorControls.Count - 1 do begin + c := FParentLikeColorControls[I]; + if c.parentColor and (c.Color <> Color) then + c.Color := Color; + end; end; - end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.ApplyColorToChildren' ); + Log('<-TKOLForm.ApplyColorToChildren'); end; end; procedure TKOLForm.CollectChildrenWithParentColor; -var ParentForm: TForm; - I: Integer; - C: TComponent; +var + ParentForm: TForm; + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -15506,27 +12848,25 @@ begin DB 'TKOLForm.CollectChildrenWithParentFont', 0 @@e_signature: end; - Log( '->TKOLForm.CollectChildrenWithParentColor' ); + Log('->TKOLForm.CollectChildrenWithParentColor'); try - if not (Owner is TForm) then - begin - LogOK; - Exit; - end; - ParentForm := Owner as TForm; - FParentLikeColorControls.Clear; - for I := 0 to ParentForm.ComponentCount - 1 do - begin - C := ParentForm.Components[ I ]; - if (C is TKOLCustomControl) and ((C as TKOLCustomControl).Parent = ParentForm) then - if (C as TKOLCustomControl).parentColor then - FParentLikeColorControls.Add( C ); - end; + if not (Owner is TForm) then begin + LogOK; + Exit; + end; + ParentForm := Owner as TForm; + FParentLikeColorControls.Clear; + for I := 0 to ParentForm.ComponentCount - 1 do begin + c := ParentForm.Components[I]; + if (c is TKOLCustomControl) and ((c as TKOLCustomControl).Parent = ParentForm) then + if (c as TKOLCustomControl).parentColor then + FParentLikeColorControls.Add(c); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.CollectChildrenWithParentColor' ); + Log('<-TKOLForm.CollectChildrenWithParentColor'); end; end; @@ -15541,12 +12881,12 @@ begin //Log( '->TKOLForm.NextUniqueID' ); try - Result := fUniqueID; - Inc( fUniqueID ); + Result := fUniqueID; + Inc(fUniqueID); - LogOK; + LogOK; finally - //Log( '<-TKOLForm.NextUniqueID' ); + //Log( '<-TKOLForm.NextUniqueID' ); end; end; @@ -15558,23 +12898,23 @@ begin DB 'TKOLForm.SetMinimizeNormalAnimated', 0 @@e_signature: end; - Log( '->TKOLForm.SetMinimizeNormalAnimated' ); + Log('->TKOLForm.SetMinimizeNormalAnimated'); try - if not FLocked then - begin - FMinimizeNormalAnimated := Value; - Change( Self ); - end; + if not FLocked then begin + FMinimizeNormalAnimated := Value; + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetMinimizeNormalAnimated' ); + Log('<-TKOLForm.SetMinimizeNormalAnimated'); end; end; procedure TKOLForm.SetLocked(const Value: Boolean); -var I: Integer; +var + I: Integer; begin asm jmp @@e_signature @@ -15582,39 +12922,36 @@ begin DB 'TKOLForm.SetLocked', 0 @@e_signature: end; - Log( '->TKOLForm.SetLocked' ); + Log('->TKOLForm.SetLocked'); try - if FLocked = Value then - begin - Rpt( 'Form ' + Name + ' made LOCKED.', RED ); - LogOK; Exit; - end; - if not Value then - begin - for I := 0 to Owner.ComponentCount-1 do - if IsVCLControl( Owner.Components[ I ] ) then - begin - ShowMessage( 'Form ' + Owner.Name + ' contains VCL controls. TKOLForm ' + - 'component can not be unlocked.' ); - LogOK; - Exit; - end; - I := MessageBox( 0, 'TKOLForm component was locked because the form had ' + - 'VCL controls placed on it. Are You sure You want to unlock TKOLForm?'#13 + - '(Note: if the form is beloning to VCL-based project, unlocking TKOLForm ' + - 'component can damage the form).', 'CAUTION!', MB_YESNO or MB_SETFOREGROUND ); - if I = ID_NO then - begin + if FLocked = Value then begin + Rpt('Form ' + name + ' made LOCKED.', RED); LogOK; Exit; end; - end; - FLocked := Value; + if not Value then begin + for I := 0 to Owner.ComponentCount - 1 do + if IsVCLControl(Owner.Components[I]) then begin + Showmessage('Form ' + Owner.name + ' contains VCL controls. TKOLForm ' + + 'component can not be unlocked.'); + LogOK; + Exit; + end; + I := MessageBox(0, 'TKOLForm component was locked because the form had ' + + 'VCL controls placed on it. Are You sure You want to unlock TKOLForm?'#13 + + '(Note: if the form is beloning to VCL-based project, unlocking TKOLForm ' + + 'component can damage the form).', 'CAUTION!', MB_YESNO or MB_SETFOREGROUND); + if I = ID_NO then begin + LogOK; + Exit; + end; + end; + FLocked := Value; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetLocked' ); + Log('<-TKOLForm.SetLocked'); end; end; @@ -15626,15 +12963,15 @@ begin DB 'TKOLForm.SetOnShow', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnShow' ); + Log('->TKOLForm.SetOnShow'); try - FOnShow := Value; - Change( Self ); + FOnShow := Value; + Change(Self); - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnShow' ); + Log('<-TKOLForm.SetOnShow'); end; end; @@ -15646,13 +12983,13 @@ begin DB 'TKOLForm.SetOnHide', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnHide' ); + Log('->TKOLForm.SetOnHide'); try - FOnHide := Value; - Change( Self ); - LogOK; + FOnHide := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetOnHide' ); + Log('<-TKOLForm.SetOnHide'); end; end; @@ -15664,13 +13001,13 @@ begin DB 'TKOLForm.SetzOrderChildren', 0 @@e_signature: end; - Log( '->TKOLForm.SetzOrderChildren' ); + Log('->TKOLForm.SetzOrderChildren'); try - FzOrderChildren := Value; - Change( Self ); - LogOK; + FzOrderChildren := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetzOrderChildren' ); + Log('<-TKOLForm.SetzOrderChildren'); end; end; @@ -15682,14 +13019,14 @@ begin DB 'TKOLForm.SetSimpleStatusText', 0 @@e_signature: end; - Log( '->TKOLForm.SetSimpleStatusText' ); + Log('->TKOLForm.SetSimpleStatusText'); try - FSimpleStatusText := Value; - FStatusText.Text := Value; - Change( Self ); - LogOK; + FSimpleStatusText := Value; + FStatusText.Text := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetSimpleStatusText' ); + Log('<-TKOLForm.SetSimpleStatusText'); end; end; @@ -15712,20 +13049,20 @@ begin DB 'TKOLForm.SetStatusText', 0 @@e_signature: end; - Log( '->TKOLForm.SetStatusText' ); + Log('->TKOLForm.SetStatusText'); try - if Value = nil then - FStatusText.Text := '' - else - FStatusText.Text := Value.Text; - if FStatusText.Count = 1 then - FSimpleStatusText := FStatusText.Text - else - FSimpleStatusText := ''; - Change( Self ); - LogOK; + if Value = nil then + FStatusText.Text := '' + else + FStatusText.Text := Value.Text; + if FStatusText.Count = 1 then + FSimpleStatusText := FStatusText.Text + else + FSimpleStatusText := ''; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetStatusText' ); + Log('<-TKOLForm.SetStatusText'); end; end; @@ -15737,24 +13074,24 @@ begin DB 'TKOLForm.SetOnMouseDblClk', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnMouseDblClk' ); + Log('->TKOLForm.SetOnMouseDblClk'); try - fOnMouseDblClk := Value; - Change( Self ); - LogOK; + fOnMouseDblClk := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetOnMouseDblClk' ); + Log('<-TKOLForm.SetOnMouseDblClk'); end; end; procedure TKOLForm.GenerateCreateForm(SL: TStringList); var - C: String; + c: string; {$IFDEF _D2009orHigher} C2: WideString; - i : integer; + I: Integer; {$ENDIF} -S: String; + s: string; begin asm jmp @@e_signature @@ -15762,68 +13099,47 @@ begin DB 'TKOLForm.GenerateCreateForm', 0 @@e_signature: end; - Log( '->TKOLForm.GenerateCreateForm' ); + Log('->TKOLForm.GenerateCreateForm'); try - Rpt( 'GenerateCreateForm ' + FormName, CYAN + LIGHT ); + Rpt('GenerateCreateForm ' + formName, CYAN + LIGHT); {$IFDEF _D2009orHigher} - if AssignTextToControls then - C := StringConstant( 'Caption', Caption ) - else - C := ''''''; - if C <> '''''' then - begin - C2 := ''; - for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; - end; -{$ELSE} - if AssignTextToControls then - C := StringConstant( 'Caption', Caption ) - else - C := ''''''; -{$ENDIF} - S := ''; - if FormCompact then - begin - SL.Add( ' Result.Form := NewForm( AParent, ' + C + - ' )' + S + ';' ); - // Если форма главная, и Applet не используется, инициализировать здесь - // переменную Applet: - if FormMain and not AppletOnForm then - SL.Add( ' Applet := Result.Form;' ); - SL.Add( ' Result.Form.DF.FormAddress := @ Result.Form;' ); - SL.Add( ' Result.Form.DF.FormObj := Result;' ); - GenerateAdd2AutoFree( SL, 'Result', FALSE, '', nil ); - - if FormMain and AppletOnForm and (Applet <> nil) then - Applet.AssignEvents( SL, 'Applet' ); - - ClearBeforeGenerateForm( SL ); - end + if AssignTextToControls then + c := StringConstant('Caption', Caption) else - begin - S := GenerateTransparentInits; - SL.Add( ' Result.Form := NewForm( AParent, ' + C + - ' )' + S + ';' ); + c := ''''''; + if c <> '''''' then begin + C2 := ''; + for I := 2 to Length(c) - 1 do + C2 := C2 + '#' + int2str(Ord(c[I])); + c := C2; + end; +{$ELSE} + if AssignTextToControls then + c := StringConstant('Caption', Caption) + else + c := ''''''; +{$ENDIF} + s := ''; + s := GenerateTransparentInits; + SL.Add(' Result.Form := NewForm( AParent, ' + c + + ' )' + s + ';'); // Если форма главная, и Applet не используется, инициализировать здесь // переменную Applet: - if FormMain and not AppletOnForm then - SL.Add( ' Applet := Result.Form;' ); - GenerateAdd2AutoFree( SL, 'Result', FALSE, '', nil ); - end; + if formMain and not AppletOnForm then + SL.Add(' Applet := Result.Form;'); + GenerateAdd2AutoFree(SL, 'Result', False, '', nil); - if @ OnBeforeCreateWindow <> nil then - SL.Add( ' Result.' + - (Owner as TForm).MethodName( @ OnBeforeCreateWindow ) + '( Result );' ); - LogOK; + if @OnBeforeCreateWindow <> nil then + SL.Add(' Result.' + (Owner as TForm).MethodName(@OnBeforeCreateWindow) + '( Result );'); + LogOK; finally - Log( '<-TKOLForm.GenerateCreateForm' ); + Log('<-TKOLForm.GenerateCreateForm'); end; end; -function TKOLForm.Result_Form: String; +function TKOLForm.Result_Form: string; begin asm jmp @@e_signature @@ -15853,21 +13169,20 @@ begin DB 'TKOLForm.SetMarginBottom', 0 @@e_signature: end; - Log( '->TKOLForm.SetMarginBottom' ); + Log('->TKOLForm.SetMarginBottom'); try - if FMarginBottom = Value then - begin - LogOK; - Exit; - end; - FMarginBottom := Value; - AlignChildren( nil, FALSE ); - Change( Self ); + if FMarginBottom = Value then begin + LogOK; + Exit; + end; + FMarginBottom := Value; + AlignChildren(nil, False); + Change(Self); - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetMarginBottom' ); + Log('<-TKOLForm.SetMarginBottom'); end; end; @@ -15879,21 +13194,20 @@ begin DB 'TKOLForm.SetMarginLeft', 0 @@e_signature: end; - Log( '->TKOLForm.SetMarginLeft' ); + Log('->TKOLForm.SetMarginLeft'); try - if FMarginLeft = Value then - begin - LogOK; - Exit; - end; - FMarginLeft := Value; - AlignChildren( nil, FALSE ); - Change( Self ); + if FMarginLeft = Value then begin + LogOK; + Exit; + end; + FMarginLeft := Value; + AlignChildren(nil, False); + Change(Self); - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetMarginLeft' ); + Log('<-TKOLForm.SetMarginLeft'); end; end; @@ -15905,21 +13219,20 @@ begin DB 'TKOLForm.SetMarginRight', 0 @@e_signature: end; - Log( '->TKOLForm.SetMarginRight' ); + Log('->TKOLForm.SetMarginRight'); try - if FMarginRight = Value then - begin - LogOK; - Exit; - end; - FMarginRight := Value; - AlignChildren( nil, FALSE ); - Change( Self ); + if FMarginRight = Value then begin + LogOK; + Exit; + end; + FMarginRight := Value; + AlignChildren(nil, False); + Change(Self); - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetMarginRight' ); + Log('<-TKOLForm.SetMarginRight'); end; end; @@ -15931,21 +13244,20 @@ begin DB 'TKOLForm.SetMarginTop', 0 @@e_signature: end; - Log( '->TKOLForm.SetMarginTop' ); + Log('->TKOLForm.SetMarginTop'); try - if FMarginTop = Value then - begin - LogOK; - Exit; - end; - FMarginTop := Value; - AlignChildren( nil, FALSE ); - Change( Self ); + if FMarginTop = Value then begin + LogOK; + Exit; + end; + FMarginTop := Value; + AlignChildren(nil, False); + Change(Self); - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetMarginTop' ); + Log('<-TKOLForm.SetMarginTop'); end; end; @@ -15957,15 +13269,15 @@ begin DB 'TKOLForm.SetOnEraseBkgnd', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnEraseBkgnd' ); + Log('->TKOLForm.SetOnEraseBkgnd'); try - FOnEraseBkgnd := Value; - Change( Self ); + FOnEraseBkgnd := Value; + Change(Self); - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetOnEraseBkgnd' ); + Log('<-TKOLForm.SetOnEraseBkgnd'); end; end; @@ -15977,13 +13289,13 @@ begin DB 'TKOLForm.SetOnPaint', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnPaint' ); + Log('->TKOLForm.SetOnPaint'); try - FOnPaint := Value; - Change( Self ); - LogOK; + FOnPaint := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetOnPaint' ); + Log('<-TKOLForm.SetOnPaint'); end; end; @@ -15995,18 +13307,18 @@ begin DB 'TKOLForm.SetEraseBackground', 0 @@e_signature: end; - Log( '->TKOLForm.SetEraseBackground' ); + Log('->TKOLForm.SetEraseBackground'); try - FEraseBackground := Value; - Change( Self ); - LogOK; + FEraseBackground := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetEraseBackground' ); + Log('<-TKOLForm.SetEraseBackground'); end; end; procedure TKOLForm.GenerateAdd2AutoFree(SL: TStringList; - const AName: String; AControl: Boolean; Add2AutoFreeProc: String; Obj: TObject); + const AName: string; AControl: Boolean; Add2AutoFreeProc: string; Obj: TObject); begin asm jmp @@e_signature @@ -16014,31 +13326,31 @@ begin DB 'TKOLForm.GenerateAdd2AutoFree', 0 @@e_signature: end; - Log( '->TKOLForm.GenerateAdd2AutoFree' ); + Log('->TKOLForm.GenerateAdd2AutoFree'); try - if Obj <> nil then - if Obj is TKOLObj then - if (Obj as TKOLObj).NotAutoFree then - begin - LogOK; - Exit; - end; - if Add2AutoFreeProc = '' then + if Obj <> nil then + if Obj is TKOLObj then + if (Obj as TKOLObj).NotAutoFree then begin + LogOK; + Exit; + end; + if Add2AutoFreeProc = '' then Add2AutoFreeProc := 'Add2AutoFree'; - if not AControl then - SL.Add( ' Result.Form.' + Add2AutoFreeProc + '( ' + AName + ' );' ); + if not AControl then + SL.Add(' Result.Form.' + Add2AutoFreeProc + '( ' + AName + ' );'); - LogOK; + LogOK; finally - Log( '<-TKOLForm.GenerateAdd2AutoFree' ); + Log('<-TKOLForm.GenerateAdd2AutoFree'); end; end; -function TKOLForm.AdditionalUnits: String; -var I: Integer; - C: TComponent; - S: String; +function TKOLForm.AdditionalUnits: string; +var + I: Integer; + c: TComponent; + s: string; begin asm jmp @@e_signature @@ -16046,35 +13358,32 @@ begin DB 'TKOLForm.AdditionalUnits', 0 @@e_signature: end; - Log( '->TKOLForm.AdditionalUnits' ); + Log('->TKOLForm.AdditionalUnits'); try - Result := ''; - for I := 0 to (Owner as TForm).ComponentCount-1 do - begin - C := (Owner as TForm).Components[ I ]; - S := ''; - if C is TKOLCustomControl then - S := (C as TKOLCustomControl).AdditionalUnits - else - if C is TKOLObj then - S := (C as TKOLObj).AdditionalUnits; - if S <> '' then - if pos(S, Result) = 0 then - begin - {if Result <> '' then - Result := Result + ', ';} - Result := Result + S; - end; - end; + Result := ''; + for I := 0 to (Owner as TForm).ComponentCount - 1 do begin + c := (Owner as TForm).Components[I]; + s := ''; + if c is TKOLCustomControl then + s := (c as TKOLCustomControl).AdditionalUnits + else if c is TKOLObj then + s := (c as TKOLObj).AdditionalUnits; + if s <> '' then + if Pos(s, Result) = 0 then begin + {if Result <> '' then + Result := Result + ', ';} + Result := Result + s; + end; + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.AdditionalUnits' ); + Log('<-TKOLForm.AdditionalUnits'); end; end; -function TKOLForm.FormTypeName: String; +function TKOLForm.FormTypeName: string; begin asm jmp @@e_signature @@ -16086,10 +13395,11 @@ begin end; function TKOLForm.AfterGeneratePas(SL: TStringList): Boolean; -var s0, s: String; - NomPrivate, NomC: Integer; - I: Integer; - C: TComponent; +var + s0, s: string; + NomPrivate, NomC: Integer; + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -16097,55 +13407,54 @@ begin DB 'TKOLForm.AfterGeneratePas', 0 @@e_signature: end; - Log( '->TKOLForm.AfterGeneratePas' ); - Result := FALSE; + Log('->TKOLForm.AfterGeneratePas'); + Result := False; try - // to change generated Pas after GeneratePas procedure - in descendants. - //-------------------- added by Alexander Rabotyagov: - s0:='private{$ENDIF} {<-- It is a VCL control}'; - s:=''; - repeat - NomPrivate:=SL.IndexOf(s+s0); - s:=s+' '; - until not((NomPrivate<0)and(length(s)<15)); - if NomPrivate>=0 then SL[NomPrivate]:=' private'; + // to change generated Pas after GeneratePas procedure - in descendants. + //-------------------- added by Alexander Rabotyagov: + s0 := 'private{$ENDIF} {<-- It is a VCL control}'; + s := ''; + repeat + NomPrivate := SL.IndexOf(s + s0); + s := s + ' '; + until not ((NomPrivate < 0) and (Length(s) < 15)); + if NomPrivate >= 0 then + SL[NomPrivate] := ' private'; - if not FLocked then - for I := 0 to Owner.ComponentCount - 1 do - begin - C := Owner.Components[ I ]; - if C = Self then Continue; - if (C is controls.TControl)and(not((C is TKOLApplet) or (C is TKOLCustomControl) or (C is TOleControl)))and(c.tag=cKolTag) - then begin + if not FLocked then + for I := 0 to Owner.ComponentCount - 1 do begin + c := Owner.Components[I]; + if c = Self then + Continue; + if (c is Controls.TControl) and (not ((c is TKOLApplet) or (c is TKOLCustomControl) or (c is TOleControl))) and (c.Tag = cKOLTag) then begin - s0:=c.Name+': '+c.ClassName+';'; - s:=''; - repeat - NomC:=SL.IndexOf(s+s0); - s:=s+' '; - until not((NomC<0)and(length(s)<15)); + s0 := c.name + ': ' + c.ClassName + ';'; + s := ''; + repeat + NomC := SL.IndexOf(s + s0); + s := s + ' '; + until not ((NomC < 0) and (Length(s) < 15)); - s0:='private'; - s:=''; - repeat - NomPrivate:=SL.IndexOf(s+s0); - s:=s+' '; - until not((NomPrivate<0)and(length(s)<15)); + s0 := 'private'; + s := ''; + repeat + NomPrivate := SL.IndexOf(s + s0); + s := s + ' '; + until not ((NomPrivate < 0) and (Length(s) < 15)); - if (NomC>=0)and(NomPrivate>=0) - then begin - Result := TRUE; - SL.Insert(NomPrivate+1,' {$IFNDEF KOL_MCK}'+c.Name+': '+c.ClassName+';{$ENDIF} {<-- It is a VCL control}'); - SL.Delete(NomC); - end; + if (NomC >= 0) and (NomPrivate >= 0) then begin + Result := True; + SL.Insert(NomPrivate + 1, ' {$IFNDEF KOL_MCK}' + c.name + ': ' + c.ClassName + ';{$ENDIF} {<-- It is a VCL control}'); + SL.Delete(NomC); + end; - end; - end;//i + end; + end; //i - LogOK; + LogOK; finally - Log( '<-TKOLForm.AfterGeneratePas' ); + Log('<-TKOLForm.AfterGeneratePas'); end; end; @@ -16157,13 +13466,13 @@ begin DB 'TKOLForm.SetOnMove', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnMove' ); + Log('->TKOLForm.SetOnMove'); try - FOnMove := Value; - Change( Self ); - LogOK; + FOnMove := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetOnMove' ); + Log('<-TKOLForm.SetOnMove'); end; end; @@ -16175,13 +13484,13 @@ begin DB 'TKOLForm.SetSupportMnemonics', 0 @@e_signature: end; - Log( '->TKOLForm.SetSupportAnsiMnemonics' ); + Log('->TKOLForm.SetSupportAnsiMnemonics'); try - FSupportMnemonics := Value; - Change( Self ); - LogOK; + FSupportMnemonics := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetSupportAnsiMnemonics' ); + Log('<-TKOLForm.SetSupportAnsiMnemonics'); end; end; @@ -16193,13 +13502,13 @@ begin DB 'TKOLForm.SetStatusSizeGrip', 0 @@e_signature: end; - Log( '->TKOLForm.SetStatusSizeGrip' ); + Log('->TKOLForm.SetStatusSizeGrip'); try - FStatusSizeGrip := Value; - Change( Self ); - LogOK; + FStatusSizeGrip := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetStatusSizeGrip' ); + Log('<-TKOLForm.SetStatusSizeGrip'); end; end; @@ -16211,24 +13520,24 @@ begin DB 'TKOLForm.SetPaintType', 0 @@e_signature: end; - Log( '->TKOLForm.SetPaintType' ); + Log('->TKOLForm.SetPaintType'); try - if FPaintType = Value then - begin + if FPaintType = Value then begin + LogOK; + Exit; + end; + FPaintType := Value; + InvalidateControls; LogOK; - Exit; - end; - FPaintType := Value; - InvalidateControls; - LogOK; finally - Log( '<-TKOLForm.SetPaintType' ); + Log('<-TKOLForm.SetPaintType'); end; end; procedure TKOLForm.InvalidateControls; -var I: Integer; - C: TComponent; +var + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -16236,38 +13545,35 @@ begin DB 'TKOLForm.InvalidateControls', 0 @@e_signature: end; - Log( '->TKOLForm.InvalidateControls' ); + Log('->TKOLForm.InvalidateControls'); try - if Owner = nil then - begin - LogOK; - Exit; - end; - if not( Owner is TForm ) then - begin - LogOK; - Exit; - end; - for I := 0 to (Owner as TForm).ComponentCount - 1 do - begin - C := (Owner as TForm).Components[ I ]; - if C is TKOLCustomControl then -{YS} - with C as TKOLCustomControl do begin - {$IFDEF _KOLCtrlWrapper_} - AllowSelfPaint := PaintType in [ptWYSIWIG, ptWYSIWIGFrames]; - AllowCustomPaint := PaintType <> ptWYSIWIG; {<<<<<<<} - {$ENDIF} - Invalidate; - end; -{YS} - end; - (Owner as TForm).Invalidate; + if Owner = nil then begin + LogOK; + Exit; + end; + if not (Owner is TForm) then begin + LogOK; + Exit; + end; + for I := 0 to (Owner as TForm).ComponentCount - 1 do begin + c := (Owner as TForm).Components[I]; + if c is TKOLCustomControl then + {YS} + with c as TKOLCustomControl do begin +{$IFDEF _KOLCtrlWrapper_} + AllowSelfPaint := PaintType in [ptWYSIWIG, ptWYSIWIGFrames]; + AllowCustomPaint := PaintType <> ptWYSIWIG; {<<<<<<<} +{$ENDIF} + Invalidate; + end; + {YS} + end; + (Owner as TForm).Invalidate; - LogOK; + LogOK; finally - Log( '<-TKOLForm.InvalidateControls' ); + Log('<-TKOLForm.InvalidateControls'); end; end; @@ -16279,27 +13585,28 @@ begin DB 'TKOLForm.Loaded', 0 @@e_signature: end; - Log( '->TKOLForm.Loaded' ); + Log('->TKOLForm.Loaded'); try - inherited; - GetPaintTypeFromProjectOrOtherForms; - Font.Change; - FChangeTimer.Enabled := FALSE; - FChangeTimer.Enabled := TRUE; - bounds.EnableTimer( TRUE ); + inherited; + GetPaintTypeFromProjectOrOtherForms; + Font.Change; + FChangeTimer.Enabled := False; + FChangeTimer.Enabled := True; + bounds.EnableTimer(True); - LogOK; + LogOK; finally - Log( '<-TKOLForm.Loaded' ); + Log('<-TKOLForm.Loaded'); end; end; procedure TKOLForm.GetPaintTypeFromProjectOrOtherForms; -var I, J: Integer; - F: TForm; - C: TComponent; - NewPaintType: TPaintType; +var + I, j: Integer; + F: TForm; + c: TComponent; + NewPaintType: TPaintType; begin asm jmp @@e_signature @@ -16307,41 +13614,38 @@ begin DB 'TKOLForm.GetPaintTypeFromProjectOrOtherForms', 0 @@e_signature: end; - Log( '->TKOLForm.GetPaintTypeFromProjectOrOtherForms' ); + Log('->TKOLForm.GetPaintTypeFromProjectOrOtherForms'); try - NewPaintType := PaintType; - if Screen = nil then - begin - LogOK; - Exit; - end; - for I := 0 to Screen.FormCount-1 do - begin - F := Screen.Forms[ I ]; - for J := 0 to F.ComponentCount-1 do - begin - C := F.Components[ J ]; - if C is TKOLProject then - begin - NewPaintType := (C as TKOLProject).PaintType; - break; - end; - if C is TKOLForm then - if C <> Self then - NewPaintType := (C as TKOLForm).PaintType; + NewPaintType := PaintType; + if Screen = nil then begin + LogOK; + Exit; end; - end; - PaintType := NewPaintType; + for I := 0 to Screen.FormCount - 1 do begin + F := Screen.Forms[I]; + for j := 0 to F.ComponentCount - 1 do begin + c := F.Components[j]; + if c is TKOLProject then begin + NewPaintType := (c as TKOLProject).PaintType; + Break; + end; + if c is TKOLForm then + if c <> Self then + NewPaintType := (c as TKOLForm).PaintType; + end; + end; + PaintType := NewPaintType; - LogOK; + LogOK; finally - Log( '<-TKOLForm.GetPaintTypeFromProjectOrOtherForms' ); + Log('<-TKOLForm.GetPaintTypeFromProjectOrOtherForms'); end; end; -function SortControls( Item1, Item2: Pointer ): Integer; -var K1, K2: TKOLCustomControl; +function SortControls(Item1, Item2: Pointer): Integer; +var + K1, K2: TKOLCustomControl; begin asm jmp @@e_signature @@ -16351,14 +13655,13 @@ begin end; K1 := Item1; K2 := Item2; - Result := CmpInts( K1.TabOrder, K2.TabOrder ); - if (Result = 0) and (K1.Align = K2.Align) then - begin + Result := CmpInts(K1.TabOrder, K2.TabOrder); + if (Result = 0) and (K1.Align = K2.Align) then begin case K1.Align of - caTop: Result := CmpInts( K1.Top, K2.Top ); - caBottom: Result := CmpInts( K2.Top, K1.Top ); - caLeft: Result := CmpInts( K1.Left, K2.Left ); - caRight: Result := CmpInts( K2.Left, K1.Left ); + caTop: Result := CmpInts(K1.Top, K2.Top); + caBottom: Result := CmpInts(K2.Top, K1.Top); + caLeft: Result := CmpInts(K1.Left, K2.Left); + caRight: Result := CmpInts(K2.Left, K1.Left); else Result := 0; end; @@ -16368,79 +13671,76 @@ end; procedure TKOLForm.AlignChildren(PrntCtrl: TKOLCustomControl; Recursive: Boolean); type TAligns = set of TKOLAlign; -var Controls: TList; +var + Controls: TList; + I: Integer; + P: TComponent; + CR, CM: TRect; + PrntBorder: Integer; + //NewW, NewH: Integer; + + procedure DoAlign(Allowed: TAligns); + var I: Integer; - P: TComponent; - CR, CM: TRect; - PrntBorder: Integer; - //NewW, NewH: Integer; - procedure DoAlign( Allowed: TAligns ); - var I: Integer; - C: TKOLCustomControl; - R, R1: TRect; - W, H: Integer; - ChgPos, ChgSiz: Boolean; + c: TKOLCustomControl; + R, R1: TRect; + W, H: Integer; + ChgPos, ChgSiz: Boolean; begin - asm + asm jmp @@e_signature DB '#$signature$#', 0 DB 'TKOLForm.AlignChildren.DoAlign', 0 @@e_signature: - end; - for I := 0 to Controls.Count - 1 do - begin - C := Controls[ I ]; + end; + for I := 0 to Controls.Count - 1 do begin + c := Controls[I]; //if not C.ToBeVisible then continue; // important: not fVisible, and even not Visible, but ToBeVisible! //if C.UseAlign then continue; - if C.Align in Allowed then - begin - R := C.BoundsRect; + if c.Align in Allowed then begin + R := c.BoundsRect; R1 := R; W := R.Right - R.Left; H := R.Bottom - R.Top; - case C.Align of - caTop: - begin - OffsetRect( R, 0, -R.Top + CR.Top + PrntBorder ); - Inc( CR.Top, H + PrntBorder ); - R.Left := CR.Left + PrntBorder; - R.Right := CR.Right - PrntBorder; - end; - caBottom: - begin - OffsetRect( R, 0, -R.Bottom + CR.Bottom - PrntBorder ); - Dec( CR.Bottom, H + PrntBorder ); - R.Left := CR.Left + PrntBorder; - R.Right := CR.Right - PrntBorder; - end; - caLeft: - begin - OffsetRect( R, -R.Left + CR.Left + PrntBorder, 0 ); - Inc( CR.Left, W + PrntBorder ); - R.Top := CR.Top + PrntBorder; - R.Bottom := CR.Bottom - PrntBorder; - end; - caRight: - begin - OffsetRect( R, -R.Right + CR.Right - PrntBorder, 0 ); - Dec( CR.Right, W + PrntBorder ); - R.Top := CR.Top + PrntBorder; - R.Bottom := CR.Bottom - PrntBorder; - end; - caClient: - begin - R := CR; - InflateRect( R, -PrntBorder, -PrntBorder ); - end; + case c.Align of + caTop: begin + OffsetRect(R, 0, -R.Top + CR.Top + PrntBorder); + Inc(CR.Top, H + PrntBorder); + R.Left := CR.Left + PrntBorder; + R.Right := CR.Right - PrntBorder; + end; + caBottom: begin + OffsetRect(R, 0, -R.Bottom + CR.Bottom - PrntBorder); + Dec(CR.Bottom, H + PrntBorder); + R.Left := CR.Left + PrntBorder; + R.Right := CR.Right - PrntBorder; + end; + caLeft: begin + OffsetRect(R, -R.Left + CR.Left + PrntBorder, 0); + Inc(CR.Left, W + PrntBorder); + R.Top := CR.Top + PrntBorder; + R.Bottom := CR.Bottom - PrntBorder; + end; + caRight: begin + OffsetRect(R, -R.Right + CR.Right - PrntBorder, 0); + Dec(CR.Right, W + PrntBorder); + R.Top := CR.Top + PrntBorder; + R.Bottom := CR.Bottom - PrntBorder; + end; + caClient: begin + R := CR; + InflateRect(R, -PrntBorder, -PrntBorder); + end; end; - if R.Right < R.Left then R.Right := R.Left; - if R.Bottom < R.Top then R.Bottom := R.Top; + if R.Right < R.Left then + R.Right := R.Left; + if R.Bottom < R.Top then + R.Bottom := R.Top; ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top); ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H); - if ChgPos or ChgSiz then - begin - C.BoundsRect := R; + if ChgPos or ChgSiz then begin + c.BoundsRect := R; {if ChgSiz then AlignChildrenProc( C );} end; @@ -16454,106 +13754,99 @@ begin DB 'TKOLForm.AlignChildren', 0 @@e_signature: end; - Log( '->TKOLForm.AlignChildren' ); + Log('->TKOLForm.AlignChildren'); try - if csLoading in ComponentState then - begin - LogOK; - Exit; - end; - if not AllowRealign then - begin - LogOK; - Exit; - end; - Controls := TList.Create; - if PrntCtrl = nil then - AllowRealign := FALSE; - Inc( FRealigning ); - {NewW := 0; - NewH := 0; - if PrntCtrl <> nil then - begin - NewW := PrntCtrl.ClientWidth; - NewH := PrntCtrl.ClientHeight; - end;} - TRY - //-- collect controls, which are children of PrntCtrl - for I := 0 to (Owner as TForm).ComponentCount-1 do + if csLoading in ComponentState then begin + LogOK; + Exit; + end; + if not AllowRealign then begin + LogOK; + Exit; + end; + Controls := TList.Create; + if PrntCtrl = nil then + AllowRealign := False; + Inc(FRealigning); + {NewW := 0; + NewH := 0; + if PrntCtrl <> nil then begin - if (Owner as TForm).Components[ I ] is TKOLCustomControl then - begin - P := ((Owner as TForm).Components[ I ] as TKOLCustomControl).Parent; - if (P = PrntCtrl) or (PrntCtrl = nil) and (P is TForm) then - begin - Controls.Add( (Owner as TForm).Components[ I ] ); - {if (PrntCtrl <> nil) and - (PrntCtrl.fOldWidth <> 0) and - (PrntCtrl.fOldHeight <> 0) then - begin - if ((Owner as TForm).Components[ I ] as TKOLCustomControl).AnchorRight then + NewW := PrntCtrl.ClientWidth; + NewH := PrntCtrl.ClientHeight; + end;} + try + //-- collect controls, which are children of PrntCtrl + for I := 0 to (Owner as TForm).ComponentCount - 1 do begin + if (Owner as TForm).Components[I] is TKOLCustomControl then begin + P := ((Owner as TForm).Components[I] as TKOLCustomControl).Parent; + if (P = PrntCtrl) or (PrntCtrl = nil) and (P is TForm) then begin + Controls.Add((Owner as TForm).Components[I]); + {if (PrntCtrl <> nil) and + (PrntCtrl.fOldWidth <> 0) and + (PrntCtrl.fOldHeight <> 0) then begin - ((Owner as TForm).Components[ I ] as TKOLCustomControl).Left := - ((Owner as TForm).Components[ I ] as TKOLCustomControl).Left + - NewW - PrntCtrl.fOldWidth; - end; - if ((Owner as TForm).Components[ I ] as TKOLCustomControl).AnchorBottom then - begin - ((Owner as TForm).Components[ I ] as TKOLCustomControl).Top := - ((Owner as TForm).Components[ I ] as TKOLCustomControl).Top + - NewW - PrntCtrl.fOldHeight; - end; - end;} + if ((Owner as TForm).Components[ I ] as TKOLCustomControl).AnchorRight then + begin + ((Owner as TForm).Components[ I ] as TKOLCustomControl).Left := + ((Owner as TForm).Components[ I ] as TKOLCustomControl).Left + + NewW - PrntCtrl.fOldWidth; + end; + if ((Owner as TForm).Components[ I ] as TKOLCustomControl).AnchorBottom then + begin + ((Owner as TForm).Components[ I ] as TKOLCustomControl).Top := + ((Owner as TForm).Components[ I ] as TKOLCustomControl).Top + + NewW - PrntCtrl.fOldHeight; + end; + end;} + end; end; end; + //-- order controls by TabOrder + Controls.Sort(SortControls); + //-- initialize client rectangle + if PrntCtrl = nil then begin + CR := //Rect( 0, 0, bounds.Width, bounds.Height ); + (Owner as TForm).ClientRect; + CR.Left := CR.Left + MarginLeft; + CR.Top := CR.Top + MarginTop; + CR.Right := CR.Right - MarginRight; + CR.Bottom := CR.Bottom - MarginBottom; + PrntBorder := Border; + end + else begin + CR := PrntCtrl.ClientRect; + CM := PrntCtrl.ClientMargins; + CR.Left := CR.Left + PrntCtrl.MarginLeft + CM.Left; + CR.Top := CR.Top + PrntCtrl.MarginTop + CM.Top; + CR.Right := CR.Right - PrntCtrl.MarginRight - CM.Right; + CR.Bottom := CR.Bottom - PrntCtrl.MarginBottom - CM.Bottom; + PrntBorder := PrntCtrl.Border; + end; + DoAlign([caTop, caBottom]); + DoAlign([caLeft, caRight]); + DoAlign([caClient]); + if PrntCtrl = nil then + AllowRealign := True; + if Recursive then + for I := 0 to Controls.Count - 1 do + AlignChildren(TKOLCustomControl(Controls[I]), True); + finally + Controls.free; + if PrntCtrl = nil then + AllowRealign := True; + Dec(FRealigning); + {if PrntCtrl <> nil then + begin + PrntCtrl.fOldWidth := NewW; + PrntCtrl.fOldHeight := NewH; + end;} end; - //-- order controls by TabOrder - Controls.Sort( SortControls ); - //-- initialize client rectangle - if PrntCtrl = nil then - begin - CR := //Rect( 0, 0, bounds.Width, bounds.Height ); - (Owner as TForm).ClientRect; - CR.Left := CR.Left + MarginLeft; - CR.Top := CR.Top + MarginTop; - CR.Right := CR.Right - MarginRight; - CR.Bottom := CR.Bottom - MarginBottom; - PrntBorder := Border; - end - else - begin - CR := PrntCtrl.ClientRect; - CM := PrntCtrl.ClientMargins; - CR.Left := CR.Left + PrntCtrl.MarginLeft + CM.Left; - CR.Top := CR.Top + PrntCtrl.MarginTop + CM.Top; - CR.Right := CR.Right - PrntCtrl.MarginRight - CM.Right; - CR.Bottom := CR.Bottom - PrntCtrl.MarginBottom - CM.Bottom; - PrntBorder := PrntCtrl.Border; - end; - DoAlign( [ caTop, caBottom ] ); - DoAlign( [ caLeft, caRight ] ); - DoAlign( [ caClient ] ); - if PrntCtrl = nil then - AllowRealign := TRUE; - if Recursive then - for I := 0 to Controls.Count-1 do - AlignChildren( TKOLCustomControl( Controls[ I ] ), TRUE ); - FINALLY - Controls.Free; - if PrntCtrl = nil then - AllowRealign := TRUE; - Dec( FRealigning ); - {if PrntCtrl <> nil then - begin - PrntCtrl.fOldWidth := NewW; - PrntCtrl.fOldHeight := NewH; - end;} - END; - LogOK; + LogOK; finally - Log( '<-TKOLForm.AlignChildren' ); + Log('<-TKOLForm.AlignChildren'); end; end; @@ -16565,210 +13858,205 @@ begin DB 'TKOLForm.DoNotGenerateSetPosition', 0 @@e_signature: end; - Result := FALSE; + Result := False; end; procedure TKOLForm.RealignTimerTick(Sender: TObject); begin - FRealignTimer.Enabled := FALSE; + FRealignTimer.Enabled := False; asm jmp @@e_signature DB '#$signature$#', 0 DB 'TKOLFileFilter.RealignTimerTick', 0 @@e_signature: end; - Log( '->TKOLForm.RealignTimerTick' ); + Log('->TKOLForm.RealignTimerTick'); try - if not AllowRealign then - begin - LogOK; - Exit; - end; - if FRealigning > 0 then - begin - LogOK; - Exit; - end; - FRealignTimer.Enabled := FALSE; - Rpt( 'RealignTimerTick', WHITE ); - AlignChildren( nil, TRUE ); + if not AllowRealign then begin + LogOK; + Exit; + end; + if FRealigning > 0 then begin + LogOK; + Exit; + end; + FRealignTimer.Enabled := False; + Rpt('RealignTimerTick', WHITE); + AlignChildren(nil, True); - LogOK; + LogOK; finally - Log( '<-TKOLForm.RealignTimerTick' ); - FRealignTimer.Enabled := FALSE; + Log('<-TKOLForm.RealignTimerTick'); + FRealignTimer.Enabled := False; end; end; procedure TKOLForm.SetMaxHeight(const Value: Integer); begin - Log( '->TKOLForm.SetMaxHeight' ); + Log('->TKOLForm.SetMaxHeight'); try - FMaxHeight := Value; - Change( Self ); - LogOK; + FMaxHeight := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetMaxHeight' ); + Log('<-TKOLForm.SetMaxHeight'); end; end; procedure TKOLForm.SetMaxWidth(const Value: Integer); begin - Log( '->TKOLForm.SetMaxWidth' ); + Log('->TKOLForm.SetMaxWidth'); try - FMaxWidth := Value; - Change( Self ); - LogOK; + FMaxWidth := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetMaxWidth' ); + Log('<-TKOLForm.SetMaxWidth'); end; end; procedure TKOLForm.SetMinHeight(const Value: Integer); begin - Log( '->TKOLForm.SetMinHeight' ); + Log('->TKOLForm.SetMinHeight'); try - FMinHeight := Value; - Change( Self ); - LogOK; + FMinHeight := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetMinHeight' ); + Log('<-TKOLForm.SetMinHeight'); end; end; procedure TKOLForm.SetMinWidth(const Value: Integer); begin - Log( '->TKOLForm.SetMinWidth' ); + Log('->TKOLForm.SetMinWidth'); try - FMinWidth := Value; - Change( Self ); - LogOK; + FMinWidth := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetMinWidth' ); + Log('<-TKOLForm.SetMinWidth'); end; end; procedure TKOLForm.SetOnDropFiles(const Value: TOnDropFiles); begin - Log( '->SetOnDropFiles' ); + Log('->SetOnDropFiles'); try - FOnDropFiles := Value; - Change( Self ); - LogOK; + FOnDropFiles := Value; + Change(Self); + LogOK; finally - Log( '<-SetOnDropFiles' ); + Log('<-SetOnDropFiles'); end; end; procedure TKOLForm.SetpopupMenu(const Value: TKOLPopupMenu); begin - Log( '->TKOLForm.SetpopupMenu' ); + Log('->TKOLForm.SetpopupMenu'); try - FpopupMenu := Value; - Change( Self ); - LogOK; + FpopupMenu := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetpopupMenu' ); + Log('<-TKOLForm.SetpopupMenu'); end; end; procedure TKOLForm.SetOnMaximize(const Value: TOnEvent); begin - Log( '->TKOLForm.SetOnMaximize' ); + Log('->TKOLForm.SetOnMaximize'); try - FOnMaximize := Value; - Change( Self ); - LogOK; + FOnMaximize := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetOnMaximize' ); + Log('<-TKOLForm.SetOnMaximize'); end; end; procedure TKOLForm.SetLocalizy(const Value: Boolean); begin - Log( '->TKOLForm.SetLocalizy' ); + Log('->TKOLForm.SetLocalizy'); try - FLocalizy := Value; - Change( Self ); - LogOK; + FLocalizy := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetLocalizy' ); + Log('<-TKOLForm.SetLocalizy'); end; end; procedure TKOLForm.MakeResourceString(const ResourceConstName, - Value: String); + Value: string); begin - Log( '->TKOLForm.MakeResourceString' ); + Log('->TKOLForm.MakeResourceString'); try - if ResStrings = nil then - ResStrings := TStringList.Create; - ResStrings.Add( 'resourcestring ' + ResourceConstName + ' = ' + - String2Pascal( Value, '+' ) + ';' ); - LogOK; + if ResStrings = nil then + ResStrings := TStringList.Create; + ResStrings.Add('resourcestring ' + ResourceConstName + ' = ' + + String2Pascal(Value, '+') + ';'); + LogOK; finally - Log( '<-TKOLForm.MakeResourceString' ); + Log('<-TKOLForm.MakeResourceString'); end; end; -function TKOLForm.StringConstant(const Propname, Value: String): String; +function TKOLForm.StringConstant(const Propname, Value: string): string; begin - Log( '->TKOLForm.StringConstant' ); + Log('->TKOLForm.StringConstant'); try - if Localizy and (Value <> '') then - begin - Result := Name + '_' + Propname; - MakeResourceString( Result, Value ); - end - else - begin - Result := String2Pascal( Value, '+' ); - end; - LogOK; + if Localizy and (Value <> '') then begin + Result := name + '_' + Propname; + MakeResourceString(Result, Value); + end + else begin + Result := String2Pascal(Value, '+'); + end; + LogOK; finally - Log( '<-TKOLForm.StringConstant' ); + Log('<-TKOLForm.StringConstant'); end; end; procedure TKOLForm.SetHelpContext(const Value: Integer); begin - Log( '->TKOLForm.SetHelpContext' ); + Log('->TKOLForm.SetHelpContext'); try - FHelpContext := Value; - Change( Self ); - LogOK; + FHelpContext := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetHelpContext' ); + Log('<-TKOLForm.SetHelpContext'); end; end; procedure TKOLForm.SethelpContextIcon(const Value: Boolean); begin - Log( '->TKOLForm.SethelpContextIcon' ); + Log('->TKOLForm.SethelpContextIcon'); try - FhelpContextIcon := Value; - if Value then - begin - maximizeIcon := FALSE; - minimizeIcon := FALSE; - end; - Change( Self ); - LogOK; + FhelpContextIcon := Value; + if Value then begin + maximizeIcon := False; + minimizeIcon := False; + end; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SethelpContextIcon' ); + Log('<-TKOLForm.SethelpContextIcon'); end; end; procedure TKOLForm.SetOnHelp(const Value: TOnHelp); begin - Log( '->TKOLForm.SetOnHelp' ); + Log('->TKOLForm.SetOnHelp'); try - FOnHelp := Value; - Change( Self ); - LogOK; + FOnHelp := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetOnHelp' ); + Log('<-TKOLForm.SetOnHelp'); end; end; @@ -16780,25 +14068,26 @@ begin DB 'TKOLForm.SetFont', 0 @@e_signature: end; - Log( '->TKOLForm.SetBrush' ); + Log('->TKOLForm.SetBrush'); try - if not FLocked then - begin - FBrush.Assign( Value ); - Change( Self ); - end; + if not FLocked then begin + fBrush.Assign(Value); + Change(Self); + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetBrush' ); + Log('<-TKOLForm.SetBrush'); end; end; {YS} + procedure TKOLForm.SetborderStyle(const Value: TKOLFormBorderStyle); -const BorderStyleNames: array[ TKOLFormBorderStyle ] of String = - ( 'fbsNone', 'fbsSingle', 'fbsDialog', 'fbsToolWindow' ); +const + BorderStyleNames: array[TKOLFormBorderStyle] of string = + ('fbsNone', 'fbsSingle', 'fbsDialog', 'fbsToolWindow'); begin asm jmp @@e_signature @@ -16806,97 +14095,94 @@ begin DB 'TKOLForm.SetborderStyle', 0 @@e_signature: end; - Log( '->TKOLForm.SetborderStyle' ); + Log('->TKOLForm.SetborderStyle'); try - if FborderStyle <> Value then - begin - RptDetailed( 'SetBorderStyle:' + BorderStyleNames[ Value ], YELLOW ); + if FborderStyle <> Value then begin + RptDetailed('SetBorderStyle:' + BorderStyleNames[Value], YELLOW); - if not FLocked then - begin - FborderStyle := Value; - if not( csLoading in ComponentState ) then //+VK - begin //+VK - FHasBorder := Value <> fbsNone; - fCanResize := Value <> fbsDialog; - end; //+VK - Change( Self ); + if not FLocked then begin + FborderStyle := Value; + if not (csLoading in ComponentState) then {//+VK} begin //+VK + FHasBorder := Value <> fbsNone; + fCanResize := Value <> fbsDialog; + end; //+VK + Change(Self); + end; end; - end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetborderStyle' ); + Log('<-TKOLForm.SetborderStyle'); end; end; {YS} -function TKOLForm.BestEventName: String; +function TKOLForm.BestEventName: string; begin Result := 'OnFormCreate'; end; procedure TKOLForm.SetShowHint(const Value: Boolean); begin - Log( '->TKOLForm.SetShowHint' ); + Log('->TKOLForm.SetShowHint'); try - FGetShowHint := Value; - Change( Self ); - LogOK; + FGetShowHint := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetShowHint' ); + Log('<-TKOLForm.SetShowHint'); end; end; function TKOLForm.GetShowHint: Boolean; begin - Log( '->TKOLForm.GetShowHint' ); + Log('->TKOLForm.GetShowHint'); try - if KOLProject <> nil then - FGetShowHint := KOLProject.ShowHint; - Result := FGetShowHint; - LogOK; + if KOLProject <> nil then + FGetShowHint := KOLProject.ShowHint; + Result := FGetShowHint; + LogOK; finally - Log( '<-TKOLForm.GetShowHint' ); + Log('<-TKOLForm.GetShowHint'); end; end; procedure TKOLForm.SetOnBeforeCreateWindow(const Value: TOnEvent); begin - Log( '->TKOLForm.SetOnBeforeCreateWindow' ); + Log('->TKOLForm.SetOnBeforeCreateWindow'); try - FOnBeforeCreateWindow := Value; - Change( Self ); - LogOK; + FOnBeforeCreateWindow := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetOnBeforeCreateWindow' ); + Log('<-TKOLForm.SetOnBeforeCreateWindow'); end; end; procedure TKOLForm.ChangeTimerTick(Sender: TObject); begin - FChangeTimer.Enabled := FALSE; - Log( '->TKOLForm.ChangeTimerTick' ); + FChangeTimer.Enabled := False; + Log('->TKOLForm.ChangeTimerTick'); try - FChangeTimer.Enabled := FALSE; - DoChangeNow; - FChangeTimer.Enabled := FALSE; - LogOK; + FChangeTimer.Enabled := False; + DoChangeNow; + FChangeTimer.Enabled := False; + LogOK; finally - Log( '<-TKOLForm.ChangeTimerTick' ); + Log('<-TKOLForm.ChangeTimerTick'); end; end; procedure TKOLForm.DoChangeNow; -var I: Integer; - Success: Boolean; - S: String; - MM: TComponent; +var + I: Integer; + Success: Boolean; + s: string; + MM: TComponent; begin - Log( '->TKOLForm.DoChangeNow' ); + Log('->TKOLForm.DoChangeNow'); try - if Name='' then - begin - LogOk; + if name = '' then begin + LogOK; Exit; end; //dufa @@ -16907,943 +14193,102 @@ begin end; //dufa - Success := false; + Success := False; - RptDetailed( 'DoChangeNow called for ' + Name, LIGHT + CYAN ); + RptDetailed('DoChangeNow called for ' + name, LIGHT + CYAN); try - Success := FALSE; - if not Assigned( KOLProject ) then - begin - RptDetailed( 'KOLProject=nil', YELLOW ); - if ToolServices=nil then - begin - RptDetailed( 'ToolServices = nil, will create', YELLOW ); + Success := False; + if not Assigned(KOLProject) then begin + RptDetailed('KOLProject=nil', YELLOW); + if ToolServices = nil then begin + RptDetailed('ToolServices = nil, will create', YELLOW); //ToolServices := TIToolServices.Create; end; - if ToolServices <> nil then - begin - RptDetailed( 'ToolServices <> nil', YELLOW ); - for I := 0 to ToolServices.GetUnitCount - 1 do - begin - S := ToolServices.GetUnitName( I ); - if LowerCase( ExtractFileName( S ) ) = LowerCase( FormUnit + '.pas' ) then - begin - S := Copy( ExtractFileName( S ), 1, Length( S ) - 4 ); + if ToolServices <> nil then begin + RptDetailed('ToolServices <> nil', YELLOW); + for I := 0 to ToolServices.GetUnitCount - 1 do begin + s := ToolServices.GetUnitName(I); + if LowerCase(ExtractFileName(s)) = LowerCase(formUnit + '.pas') then begin + s := Copy(ExtractFileName(s), 1, Length(s) - 4); if fSourcePath <> '' then - S := IncludeTrailingPathDelimiter( fSourcePath ) + S; + s := IncludeTrailingPathDelimiter(fSourcePath) + s; //ShowMessage( 'Generating w/o KOLProject: ' + S {+#13#10 + // 'csLoading:' + IntToStr( Integer( csLoading in ComponentState ) )} ); - RptDetailed( 'BeforeGenerateUnit1' + S, YELLOW ); - Success := GenerateUnit( S ); - RptDetailed( 'AfterGenerateUnit1' + S, YELLOW ); + RptDetailed('BeforeGenerateUnit1' + s, YELLOW); + Success := GenerateUnit(s); + RptDetailed('AfterGenerateUnit1' + s, YELLOW); end; - if Success then break; + if Success then + Break; end; - if not Success then - begin - S := ToolServices.GetCurrentFile; - if S <> '' then - begin - RptDetailed( 'DoChangeNow: S=' + S, YELLOW ); - if LowerCase( ExtractFileName( S ) ) = LowerCase( FormUnit + '.pas' ) then - begin - S := Copy( ExtractFileName( S ), 1, Length( S ) - 4 ); + if not Success then begin + s := ToolServices.GetCurrentFile; + if s <> '' then begin + RptDetailed('DoChangeNow: S=' + s, YELLOW); + if LowerCase(ExtractFileName(s)) = LowerCase(formUnit + '.pas') then begin + s := Copy(ExtractFileName(s), 1, Length(s) - 4); if fSourcePath <> '' then - S := IncludeTrailingPathDelimiter( fSourcePath ) + S; - RptDetailed( 'BeforeGenerateUnit2' + S, YELLOW ); + s := IncludeTrailingPathDelimiter(fSourcePath) + s; + RptDetailed('BeforeGenerateUnit2' + s, YELLOW); //ShowMessage( 'Generating w/o KOLProject: ' + S ); - Success := GenerateUnit( S ); - RptDetailed( 'AfterGenerateUnit2' + S, YELLOW ); + Success := GenerateUnit(s); + RptDetailed('AfterGenerateUnit2' + s, YELLOW); end; end; end; end; end; - except on E: Exception do - begin - RptDetailed( 'Exception ' + E.Message, RED ); - end; + except on E: Exception do begin + RptDetailed('Exception ' + E.Message, RED); + end; end; if not Success then - inherited Change( Self ); + inherited Change(Self); LogOK; finally - Log( '<-TKOLForm.DoChangeNow' ); + Log('<-TKOLForm.DoChangeNow'); end; end; -procedure TKOLForm.P_GenerateCreateForm(SL: TStringList); -var S: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLForm.P_GenerateCreateForm', 0 - @@e_signature: - end; - Log( '->TKOLForm.P_GenerateCreateForm' ); - try - //{P} ESP->Result,@Result,AParent - - S := P_GenerateTransparentInits; - - //SL.Add( ' Result.Form := NewForm( AParent, ' + StringConstant( 'Caption', Caption ) + - // ' )' + S + ';' ); - {P}SL.Add( P_StringConstant( 'Caption', Caption ) ); - //{P} ESP->Caption,Result,@Result,AParent - {P}SL.Add( ' C4 ' ); - //{P} ESP->AParent,Caption,Result,@Result,AParent - {P}SL.Add( ' NewForm<2> RESULT' ); - //{P} ESP->form,Result,@Result,AParent - {P}SL.Add( ' DUP C3 AddByte_Store #T' + FormName + '.Form' ); - {P}SL.Add( S ); - //{P} ESP->Result,@Result,AParent - //if @ OnBeforeCreateWindow <> nil then - // SL.Add( ' Result.' + - // (Owner as TForm).MethodName( @ OnBeforeCreateWindow ) + '( Result );' ); - if @ OnBeforeCreateWindow <> nil then - begin - {P}SL.Add( ' DUP LoadSELF' ); - {P}SL.Add( ' T' + FormName + '.' + - (Owner as TForm).MethodName( @ OnBeforeCreateWindow ) + '<2>' ); - end; - - // Если форма главная, и Applet не используется, инициализировать здесь - // переменную Applet: - if FormMain and not AppletOnForm then - //SL.Add( ' Applet := Result.Form;' ); - begin - {P}SL.Add( ' DUP StoreVar ####Applet' ); - end; - - LogOK; - finally - Log( '<-TKOLForm.GenerateCreateForm' ); - end; -end; - -function TKOLForm.P_GenerateTransparentInits: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLForm.P_GenerateTransparentInits', 0 - @@e_signature: - end; - Log( '->TKOLForm.P_GenerateTransparentInits' ); - try - Result := ''; - if not FLocked then - begin - //{P} ESP->Result.Form,... ( Result = New(...) ) - - //Log( '#1 TKOLForm.GenerateTransparentInits' ); - - if not DefaultPosition then - begin - //Log( '#1.A TKOLForm.GenerateTransparentInits' ); - - if not DoNotGenerateSetPosition then - begin - //Log( '#1.B TKOLForm.GenerateTransparentInits' ); - if FBounds <> nil then - //Result := '.SetPosition( ' + IntToStr( Bounds.Left ) + ', ' + - // IntToStr( Bounds.Top ) + ' )'; - begin - {P}Result := Result + ' L(' + IntToStr( Bounds.Top ) + ')'; - {P}Result := Result + ' L(' + IntToStr( Bounds.Left ) + ')'; - {P}Result := Result + ' C2 TControl.SetPosition<3>'; - end; - //Log( '#1.C TKOLForm.GenerateTransparentInits' ); - end; - - //Log( '#1.D TKOLForm.GenerateTransparentInits' ); - end; - - //Log( '#2 TKOLForm.GenerateTransparentInits' ); - - if not DefaultSize then - begin - if (Owner = nil) or not(Owner is TForm) then - if HasCaption then - //Result := Result + '.SetSize( ' + IntToStr( Bounds.Width ) + ', ' + - // IntToStr( Bounds.Height ) + ' )' - begin - {P}Result := Result + ' L(' + IntToStr( Bounds.Height ) + ')'; - {P}Result := Result + ' L(' + IntToStr( Bounds.Width ) + ')'; - {P}Result := Result + ' C2 TControl.SetSize<3>'; - end - else - //Result := Result + '.SetSize( ' + IntToStr( Bounds.Width ) + ', ' + - // IntToStr( Bounds.Height-GetSystemMetrics(SM_CYCAPTION) ) + ' )' - begin - {P}Result := Result + ' L(' + IntToStr( Bounds.Height-GetSystemMetrics(SM_CYCAPTION) ) + ')'; - {P}Result := Result + ' L(' + IntToStr( Bounds.Width ) + ')'; - {P}Result := Result + ' C2 TControl.SetSize<3>'; - end - else - if HasCaption then - //Result := Result + '.SetClientSize( ' + IntToStr( (Owner as TForm).ClientWidth ) + - // ', ' + IntToStr( (Owner as TForm).ClientHeight ) + ' )' - begin - {P}Result := Result + ' L(' + IntToStr( (Owner as TForm).ClientHeight ) + ')'; - {P}Result := Result + ' L(' + IntToStr( (Owner as TForm).ClientWidth ) + ')'; - {P}Result := Result + ' C2 TControl.SetClientSize<3>'; - end - //+++++++ UaFM - else - //Result := Result + '.SetClientSize( ' + IntToStr( (Owner as TForm).ClientWidth ) + - // ', ' + IntToStr( (Owner as TForm).ClientHeight-GetSystemMetrics(SM_CYCAPTION) ) - // + ')' - if HasBorder then - begin - {P}Result := Result + ' L(' + IntToStr( (Owner as TForm).ClientHeight-GetSystemMetrics(SM_CYCAPTION) ) + ')'; - {P}Result := Result + ' L(' + IntToStr( (Owner as TForm).ClientWidth ) + ')'; - {P}Result := Result + ' C2 TControl.SetClientSize<3>'; - end; - end; - - //Log( '#3 TKOLForm.GenerateTransparentInits' ); - - if Tabulate then - //Result := Result + '.Tabulate' - {P}Result := Result + ' DUP TControl.Tabulate<1>' - else - if TabulateEx then - //Result := Result + '.TabulateEx'; - {P}Result := Result + ' DUP TControl.TabulateEx<1>'; - - //Log( '#4 TKOLForm.GenerateTransparentInits' ); - - if PreventResizeFlicks then - //Result := Result + '.PreventResizeFlicks'; - {P}Result := Result + ' DUP TControl.PreventResizeFlicks<1>'; - - //Log( '#5 TKOLForm.GenerateTransparentInits' ); - - if supportMnemonics then - //Result := Result + '.SupportMnemonics'; - {P}Result := Result + ' DUP TControl.SupportMnemonics<1>'; - - //Log( '#6 TKOLForm.GenerateTransparentInits' ); - - if HelpContext <> 0 then - //Result := Result + '.AssignHelpContext( ' + IntToStr( HelpContext ) + ' )'; - begin - {P}Result := Result + ' L(' + IntToStr( HelpContext ) + ')'; - {P}Result := Result + ' C1 TControl.AssignHelpContext<2>'; - end; - end; - - //Log( '#7 TKOLForm.GenerateTransparentInits' ); - - LogOK; - finally - Log( '<-TKOLForm.GenerateTransparentInits' ); - end; -end; - -function TKOLForm.P_StringConstant(const Propname, Value: String): String; -begin - Log( '->TKOLForm.P_StringConstant' ); - try - if Localizy and (Value <> '') then - begin - //Result := Name + '_' + Propname; - {P}Result := ' ResourceString ####' + Name + '_' + PropName; - //todo: implement ResourceString in P-machine! - MakeResourceString( Result, Value ); - end - else - begin - //Result := String2Pascal( Value ); - {P}Result := ' LoadAnsiStr ' + P_String2Pascal( Value ); - end; - LogOK; - finally - Log( '<-TKOLForm.P_StringConstant' ); - end; -end; - -procedure TKOLForm.P_GenerateAdd2AutoFree(SL: TStringList; - const AName: String; AControl: Boolean; Add2AutoFreeProc: String; - Obj: TObject); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLForm.P_GenerateAdd2AutoFree', 0 - @@e_signature: - end; - Log( '->TKOLForm.P_GenerateAdd2AutoFree' ); - try - - if Obj <> nil then - if Obj is TKOLObj then - if (Obj as TKOLObj).NotAutoFree then - begin - LogOK; - Exit; - end; - if Add2AutoFreeProc = '' then - Add2AutoFreeProc := 'Add2AutoFree'; - if not AControl then - //SL.Add( ' Result.Form.' + Add2AutoFreeProc + '( ' + AName + ' );' ); - begin - //{P} ESP -> Result,@Result - {P}SL.Add( ' LoadSELF C1 ' - //+ 'AddByte_LoadRef #T' + FormName + '.Form' - ); - {P}SL.Add( ' TControl.' + Add2AutoFreeProc + '<2>' ); - ////?{P}SL.Add( ' xySwap DEL' ); - end; - - LogOK; - finally - Log( '<-TKOLForm.P_GenerateAdd2AutoFree' ); - end; -end; - -procedure TKOLForm.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -const WindowStates: array[ KOL.TWindowState ] of String = ( 'wsNormal', - 'wsMinimized', 'wsMaximized' ); -var I: Integer; - S: string; {YS} - FormInStack: Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLForm.P_SetupFirst', 0 - @@e_signature: - end; - Log( '->TKOLForm.P_SetupFirst' ); - try - - if FLocked then - begin - Rpt( 'Form ' + Name + ' LOCKED', RED ); - LogOK; Exit; - end; - - FormInStack := FALSE; - - // Установка каких-либо свойств формы - тех, которые выполняются - // сразу после конструирования объекта формы: - SL.Add( 'IFDEF(UNICODE_CTRLS)' ); - SL.Add( ' L(1) C1 TControl.SetUnicode<2> DEL' ); - SL.Add( 'ENDIF' ); - P_SetupName( SL ); - if Tag <> 0 then - begin - {if Tag < 0 then - SL.Add( Prefix + AName + '.Tag := DWORD(' + IntToStr( Tag ) + ');' ) - else - SL.Add( Prefix + AName + '.Tag := ' + IntToStr( Tag ) + ';' );} - {P}SL.Add( ' L(' + IntToStr( Tag ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fTag' ); - end; - - //Log( '&2 TKOLForm.SetupFirst' ); - - if not statusSizeGrip then - //if (StatusText.Count > 0) or (SimpleStatusText <> '') then - //SL.Add( Prefix + AName + '.SizeGrip := FALSE;' ); - begin - {P}SL.Add( ' L(0) C1 AddWord_StoreB ##TControl_.fSizeGrip' ) - end; - - //Log( '&3 TKOLForm.SetupFirst' ); - -{YS} - S := ''; - case FborderStyle of - fbsDialog: - S := S + ' or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE'; - fbsToolWindow: - S := S + ' or WS_EX_TOOLWINDOW'; - end; - - //Log( '&4 TKOLForm.SetupFirst' ); - - if helpContextIcon then - S := S + ' or WS_EX_CONTEXTHELP'; - if S <> '' then - //SL.Add( Prefix + AName + '.ExStyle := ' + AName + '.ExStyle' + S + ';' ); - begin - Delete( S, 1, 4 ); // remove ' or ' prefix - {P}SL.Add( ' LoadWord ##(' + S + ')' ); - {P}SL.Add( ' C1 AddWord_LoadRef ##TControl_.fExStyle' ); - {P}SL.Add( ' | C1 TControl_.SetExStyle<2>' ); - end; - - //Log( '&5 TKOLForm.SetupFirst' ); - -{YS} - if not Visible then - //SL.Add( Prefix + AName + '.Visible := False;' ); - begin - {P}SL.Add( ' L(0) C1 TControl_.SetVisible<2>' ); - end; - if not Enabled then - //SL.Add( Prefix + AName + '.Enabled := False;' ); - begin - {P}SL.Add( ' L(0) C1 TControl_.SetEnabled<2>' ); - end; - if DoubleBuffered and not Transparent then - //SL.Add( Prefix + AName + '.DoubleBuffered := True;' ); - begin - {P}SL.Add( 'L(1) C1 TControl_.SetDoubleBuffered<2>' ) - end; -{YS} - - //Log( '&6 TKOLForm.SetupFirst' ); - - I := 0; - case FborderStyle of - fbsDialog: - I := I or WS_MINIMIZEBOX or WS_MAXIMIZEBOX; - fbsToolWindow, fbsNone: - ; - else - begin - if not MinimizeIcon and not MaximizeIcon then - I := I or WS_MINIMIZEBOX or WS_MAXIMIZEBOX - else - begin - if not MinimizeIcon then - I := I or WS_MINIMIZEBOX; - if not MaximizeIcon then - I := I or WS_MAXIMIZEBOX; - end; - end; - end; - - //Log( '&7 TKOLForm.SetupFirst' ); - - if I <> 0 then - //SL.Add( Prefix + AName + '.Style := ' + AName + '.Style' + S + ';' ); - begin - Delete( S, 1, 4 ); - {P}SL.Add( ' L(' + IntToStr( I shr 16 ) + ') L(16) <<' ); - {P}SL.Add( ' ~ C1 AddWord_LoadRef ##TControl_.fStyle & ' ); - {P}SL.Add( ' C1 TControl_.SetStyle<2>' ); - end; - - //Log( '&8 TKOLForm.SetupFirst' ); - -{YS} - - if Transparent then - //SL.Add( Prefix + AName + '.Transparent := True;' ); - begin - {P}SL.Add( ' L(1) C1 TControl_.SetTransparent<2>' ); - end; - - if (AlphaBlend <> 255) and (AlphaBlend > 0) then - //SL.Add( Prefix + AName + '.AlphaBlend := ' + IntToStr( AlphaBlend and $FF ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( AlphaBlend ) + ')' ); - {P}SL.Add( ' C1 TControl_.SetAlphaBlend<2>' ); - end; - - if not HasBorder then - //SL.Add( Prefix + AName + '.HasBorder := False;' ); - begin - {P}SL.Add( ' L(0) C1 TControl_.SetHasBorder<2>' ); - {P}SL.Add( ' L(' + IntToStr( (Owner as TForm).ClientHeight ) + ')' ); - {P}SL.Add( ' L(' + IntToStr( (Owner as TForm).ClientWidth ) + ')' ); - {P}SL.Add( ' C2 TControl.SetClientSize<3>' ); - end; - - if not HasCaption and HasBorder then - //SL.Add( Prefix + AName + '.HasCaption := False;' ); - begin - {P}SL.Add( ' L(0) C1 TControl.SetHasCaption<2>' ); - end; - - if StayOnTop then - //SL.Add( Prefix + AName + '.StayOnTop := True;' ); - begin - {P}SL.Add( ' L(1) C1 TControl_.SetStayOnTop<2>' ); - end; - - if not Ctl3D then - //SL.Add( Prefix + AName + '.Ctl3D := False;' ); - begin - {P}SL.Add( ' L(0) C1 TControl_.SetCtl3D<2>' ); - end; - - if Icon <> '' then - begin - if Copy( Icon, 1, 1 ) = '#' then // +Alexander Pravdin - //SL.Add( Prefix + AName + '.IconLoad( hInstance, MAKEINTRESOURCE( ' + - // Copy( Icon, 2, Length( Icon ) - 1 ) + ' ) );' ) - begin - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( CopyEnd( Icon, 2 ) ) ); - {P}SL.Add( ' Load_hInstance' ); - {P}SL.Add( ' C3 TControl.IconLoad<3>' ); - {P}SL.Add( ' DelAnsiStr' ); - end - else - if Copy( Icon, 1, 4 ) = 'IDI_' then - //SL.Add( Prefix + AName + '.IconLoad( 0, ' + Icon + ' );' ) - begin - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( Icon ) ); - {P}SL.Add( ' L(0) C3 TControl.IconLoad<3>' ); - {P}SL.Add( ' DelAnsiStr' ); - end - else - if Copy( Icon, 1, 4 ) = 'IDC_' then - //SL.Add( Prefix + AName + '.IconLoadCursor( 0, ' + Icon + ' );' ) - begin - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( Icon ) ); - {P}SL.Add( ' L(0) C3 TControl.IconLoad<3>' ); - {P}SL.Add( ' DelAnsiStr' ); - end - else - if Icon = '-1' then - //SL.Add( Prefix + AName + '.Icon := THandle(-1);' ) - begin - {P}SL.Add( ' L(-1) C1 TControl_.SetIcon<2>' ); - end - else - //SL.Add( Prefix + AName + '.IconLoad( hInstance, ''' + Icon + ''' );' ); - begin - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( Icon ) ); - {P}SL.Add( ' Load_hInstance' ); - {P}SL.Add( ' C3 TControl.IconLoad<3>' ); - {P}SL.Add( ' DelAnsiStr' ); - end; - end; - - if WindowState <> KOL.wsNormal then - //SL.Add( Prefix + AName + '.WindowState := ' + WindowStates[ WindowState ] + - // ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( Integer( WindowState ) ) + ')' ); - {P}SL.Add( ' C1 TControl_.SetWindowState<2>' ); - end; - - if Trim( Cursor ) <> '' then - begin - if Copy( Cursor, 1, 4 ) = 'IDC_' then - //SL.Add( Prefix + AName + '.CursorLoad( 0, ' + Cursor + ' );' ) - begin - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( Cursor ) ); - {P}SL.Add( ' L(0) C3 TControl.CursorLoad<3>' ); - {P}SL.Add( ' DelAnsiStr' ); - end - else - //SL.Add( Prefix + AName + '.CursorLoad( hInstance, ''' + Trim( Cursor ) + ''' );' ); - begin - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( Cursor ) ); - {P}SL.Add( ' Load_hInstance C3 TControl.CursorLoad<3>' ); - {P}SL.Add( ' DelAnsiStr' ); - end; - end; - - if Brush <> nil then - //Brush.GenerateCode( SL, AName ); - begin - {P}Brush.P_GenerateCode( SL, AName ); - end; - - if (Font <> nil) AND not FontDefault and not Font.Equal2( nil ) then - //Font.GenerateCode( SL, AName, nil ); - begin - {P}Font.P_GenerateCode( SL, AName, nil ); - end; - - if Border <> 2 then - //SL.Add( Prefix + AName + '.Border := ' + IntToStr( Border ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( Border ) + ')' ); - {P}SL.Add( ' C1 TControl.SetBorder<2>' ); - end; - - if MarginTop <> 0 then - //SL.Add( Prefix + AName + '.MarginTop := ' + IntToStr( MarginTop ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MarginTop ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fClientTop' ); - end; - - if MarginBottom <> 0 then - //SL.Add( Prefix + AName + '.MarginBottom := ' + IntToStr( MarginBottom ) + ';' ); - begin - {P}SL.Add( 'L(' + IntToStr( MarginBottom ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fClientBottom' ); - end; - - if MarginLeft <> 0 then - //SL.Add( Prefix + AName + '.MarginLeft := ' + IntToStr( MarginLeft ) + ';' ); - begin - {P}SL.Add( 'L(' + IntToStr( MarginLeft ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fClientLeft' ); - end; - - if MarginRight <> 0 then - //SL.Add( Prefix + AName + '.MarginRight := ' + IntToStr( MarginRight ) + ';' ); - begin - {P}SL.Add( 'L(' + IntToStr( MarginRight ) + ')' ); - {P}SL.Add( ' C1 AddWord_Store ##TControl_.fClientRight' ); - end; - - if (FStatusText <> nil) and (FStatusText.Text <> '') then - begin - if FStatusText.Count = 1 then - //SL.Add( Prefix + AName + '.SimpleStatusText := ' + PCharStringConstant( Self, 'SimpleStatusText', FStatusText[ 0 ] ) + ';' ) - begin - {P}SL.Add( P_StringConstant( 'SimpleStatusText', FStatusText[ 0 ] ) ); - {P}SL.Add( ' L(255) C3 TControl_.SetStatusText<3> DelAnsiStr' ); - end - else - begin - for I := 0 to FStatusText.Count-1 do - //SL.Add( Prefix + AName + '.StatusText[ ' + IntToStr( I ) + ' ] := ' + - // PCharStringConstant( Self, 'StatusText' + IntToStr( I ), FStatusText[ I ] ) + ';' ); - begin - {P}SL.Add( P_StringConstant( 'StatusText' + IntToStr( I ), FStatusText[ I ] ) ); - {P}SL.Add( ' L(' + IntToStr( I ) + ') C3 TControl_.SetStatusText<3> DelAnsiStr' ); - end; - end; - end; - - if not CloseIcon then - begin - //SL.Add( Prefix + 'DeleteMenu( GetSystemMenu( Result.Form.GetWindowHandle, ' + - // 'False ), SC_CLOSE, MF_BYCOMMAND );' ); - {P}SL.Add( ' L(0) LoadWord ##SC_CLOSE ' ); - {P}SL.Add( ' L(0) C3 TControl.GetWindowHandle<1> RESULT' ); - {P}SL.Add( ' GetSystemMenu RESULT' ); - {P}SL.Add( ' DeleteMenu' ); - end; - - //AssignEvents( SL, AName ); - {P}P_AssignEvents( SL, AName, FALSE ); - - if EraseBackground then - //SL.Add( Prefix + AName + '.EraseBackground := TRUE;' ); - begin - {P}SL.Add( ' L(1) C1 AddWord_StoreB ##TControl_.fEraseUpdRgn' ); - end; - - if MinWidth > 0 then - //SL.Add( Prefix + AName + '.MinWidth := ' + IntToStr( MinWidth ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MinWidth ) + ') L(0)' ); - {P}SL.Add( ' C2 TControl_.SetConstraint<3>' ); - end; - - if MinHeight > 0 then - //SL.Add( Prefix + AName + '.MinHeight := ' + IntToStr( MinHeight ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MinHeight ) + ') L(1)' ); - {P}SL.Add( ' C2 TControl_.SetConstraint<3>' ); - end; - - if MaxWidth > 0 then - //SL.Add( Prefix + AName + '.MaxWidth := ' + IntToStr( MaxWidth ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MaxWidth ) + ') L(2)' ); - {P}SL.Add( ' C2 TControl_.SetsContraint<3>' ); - end; - - if MaxHeight > 0 then - //SL.Add( Prefix + AName + '.MaxHeight := ' + IntToStr( MaxHeight ) + ';' ); - begin - {P}SL.Add( ' L(' + IntToStr( MaxHeight ) + ') L(3)' ); - {P}SL.Add( ' C2 TControl_.SetConstraint<3>' ); - end; - - if KeyPreview then - begin - {P}SL.Add( ' DUP L(1) AddWord_StoreB ##TControl_.FKeyPreview' ); - end; - - if FormInStack then - SL.Add( ' DEL // Form ' ); - - LogOK; - finally - Log( '<-TKOLForm.P_SetupFirst' ); - end; -end; - -function TKOLForm.P_AssignEvents(SL: TStringList; const AName: String; CheckOnly: Boolean): Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLForm.P_AssignEvents', 0 - @@e_signature: - end; - Log( '->TKOLForm.P_AssignEvents' ); - Result := TRUE; - try - if not FLocked then - begin - if (Applet <> nil) and (Applet.Owner = Owner) and not CheckOnly then - begin - if Applet.P_AssignEvents( SL, 'Applet', TRUE ) then - begin - SL.Add( ' Load_Applet ' ); - Applet.P_AssignEvents( SL, 'Applet', FALSE ); - SL.Add( ' DEL // Applet' ); - end; - end; - if P_DoAssignEvents( SL, AName, [ 'OnMessage', 'OnClose', 'OnQueryEndSession' ], - [ @OnMessage, @ OnClose, @ OnQueryEndSession ], - [ FALSE, TRUE, TRUE ], - CheckOnly ) and CheckOnly then - begin - LogOK; Exit; - end; - if P_DoAssignEvents( SL, AName, [ 'OnMinimize', 'OnMaximize', 'OnRestore' ], - [ @ OnMinimize, @ OnMaximize, @ OnRestore ], - [ TRUE, TRUE, TRUE ], - CheckOnly ) and CheckOnly then - begin - LogOK; Exit; - end; - if P_DoAssignEvents( SL, AName, - [ 'OnClick', 'OnMouseDblClk', 'OnMouseDown', 'OnMouseMove', 'OnMouseUp', 'OnMouseWheel', 'OnMouseEnter', 'OnMouseLeave' ], - [ @OnClick, @ OnMouseDblClk, @OnMouseDown, @OnMouseMove, @OnMouseUp, @OnMouseWheel, @OnMouseEnter, @OnMouseLeave ], - [ FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ], - CheckOnly ) and CheckOnly then - begin - LogOK; Exit; - end; - - if P_DoAssignEvents( SL, AName, - [ 'OnEnter', 'OnLeave', 'OnKeyDown', 'OnKeyUp', 'OnKeyChar', 'OnResize', 'OnMove', 'OnMoving', 'OnShow', 'OnHide' ], - [ @OnEnter, @OnLeave, @OnKeyDown, @OnKeyUp, @OnKeyChar, @OnResize, @OnMove, @ OnMoving, @ OnShow, @ OnHide ], - [ FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ], - CheckOnly ) and CheckOnly then - begin - LogOK; Exit; - end; - - if P_DoAssignEvents( SL, AName, - [ 'OnPaint', 'OnEraseBkgnd', 'OnDropFiles' ], - [ @ OnPaint, @ OnEraseBkgnd, @ OnDropFiles ], - [ TRUE, TRUE, TRUE ], - CheckOnly ) - and CheckOnly then - begin - LogOK; Exit; - end; - - if P_DoAssignEvents( SL, AName, - [ 'OnDestroy', 'OnHelp' ], - [ @ OnDestroy, @ OnHelp ], - [ FALSE, FALSE ], - CheckOnly ) and CheckOnly then - begin - LogOK; Exit; - end; - end; - LogOK; - Result := FALSE; - finally - if Result and CheckOnly then LogOK; - Log( '<-TKOLForm.P_AssignEvents' ); - end; -end; - -procedure TKOLForm.P_GenerateChildren(SL: TStringList; - OfParent: TComponent; const OfParentName, Prefix: String; - var Updated: Boolean); -var I: Integer; - L: TList; - S: String; - KC: TKOLCustomControl; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLForm.P_GenerateChildren', 0 - @@e_signature: - end; - Log( '->TKOLForm.P_GenerateChildren' ); - try - L := TList.Create; - try - for I := 0 to Owner.ComponentCount - 1 do - begin - if Owner.Components[ I ] is TKOLCustomControl then - if (Owner.Components[ I ] as TKOLCustomControl).ParentKOLControl = OfParent then - begin - //Rpt( 'Look for ' + OfParent.Name + ': ' + Owner.Components[ I ].Name ); - //Rpt( '.ParentKOLControl = ' + (Owner.Components[ I ] as TKOLCustomControl).ParentKOLControl.Name ); - KC := Owner.Components[ I ] as TKOLCustomControl; - L.Add( KC ); - end; - end; - SortData( L, L.Count, @CompareControls, @SwapItems ); - //OutSortedListOfComponents( UnitSourcePath + FormName + '_' + OfParent.Name, L, 3 ); - for I := 0 to L.Count - 1 do - begin - KC := L.Items[ I ]; - KC.fUpdated := FALSE; - //SL.Add( ' // ' + KC.RefName + '.TabOrder = ' + IntToStr( KC.TabOrder ) ); - KC.fP_NameSetuped := FALSE; - KC.P_SetupFirst( SL, KC.Name, OfParentName, Prefix ); - KC.P_SetupName( SL ); // на случай, если P_SetupFirst переопределена - // и P_SetupName не вызвана - P_GenerateAdd2AutoFree( SL, KC.RefName, TRUE, '', KC ); - S := KC.RefName; - P_GenerateChildren( SL, KC, S, Prefix + ' ', Updated ); - if KC.fUpdated then - Updated := TRUE; - {P}SL.Add( ' DEL //' + KC.Name ); - end; - finally - L.Free; - end; - LogOK; - finally - Log( '<-TKOLForm.P_GenerateChildren' ); - end; -end; - -procedure TKOLForm.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var S: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLForm.P_SetupLast', 0 - @@e_signature: - end; - Log( '->TKOLForm.P_SetupLast' ); - try - - if not FLocked then - begin - S := ''; - if CenterOnScreen then - //S := Prefix + AName + '.CenterOnParent'; - begin - {P}S := S + ' DUP TControl.CenterOnParent<1>'; - end; - if not CanResize then - begin - {if S = '' then - S := Prefix + AName; - S := S + '.CanResize := False';} - {P}S := S + ' L(0) C1 TControl_.SetCanResize<2>'; - end; - if S <> '' then - //SL.Add( S + ';' ); - {P}SL.Add( S ); - if MinimizeNormalAnimated then - //SL.Add( Prefix + AName + '.MinimizeNormalAnimated;' ); - begin - {P}SL.Add( ' DUP TControl.MinimizeNormalAnimated<1>' ) - end - else if RestoreNormalMaximized then - begin - SL.Add( ' DUP TControl.RestoreNormalMaximized<1>') - end; - if Assigned( FpopupMenu ) then - //SL.Add( Prefix + AName + '.SetAutoPopupMenu( Result.' + FpopupMenu.Name + - // ' );' ); - begin - {P}SL.Add( ' LoadSELF AddWord_LoadRef ##T' + FormName + '.' + FpopupMenu.Name ); - {P}SL.Add( ' C1 TControl.SetAutoPopupMenu<2>' ); - end; - if @ OnFormCreate <> nil then - begin - //SL.Add( Prefix + 'Result.' + (Owner as TForm).MethodName( @ OnFormCreate ) + '( Result );' ); - {P}SL.Add( ' LoadSELF DUP T' + FormName + '.' + - (Owner as TForm).MethodName( @ OnFormCreate ) + '<2>' ); - end; - {YS} - if FborderStyle = fbsDialog then - //SL.Add( Prefix + AName + '.Icon := THandle(-1);' ); - {P}SL.Add( ' L(-1) C1 TControl_.SetIcon<2>' ); - {YS} - - {P}SL.Add( ' DEL DelAnsiStr DEL(3) EXIT' ); - end; - - LogOK; - finally - Log( '<-TKOLForm.P_SetupLast' ); - end; -end; - -function TKOLForm.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - function TKOLForm.HasMainMenu: Boolean; -var i: Integer; - C: TComponent; +var + I: Integer; + c: TComponent; begin - Result := FALSE; - if (Owner = nil) or not(Owner is TForm) then Exit; - for i := 0 to (Owner as TForm).ComponentCount-1 do - begin - C := (Owner as TForm).Components[ i ]; - if C is TKOLMainMenu then - begin - Result := TRUE; + Result := False; + if (Owner = nil) or not (Owner is TForm) then + Exit; + for I := 0 to (Owner as TForm).ComponentCount - 1 do begin + c := (Owner as TForm).Components[I]; + if c is TKOLMainMenu then begin + Result := True; Exit; end; end; end; -procedure TKOLForm.P_SetupName(SL: TStringList); -begin - if fP_NameSetuped then Exit; - if Name <> '' then - begin - //SL.Add( ' {$IFDEF USE_NAMES}' ); - //SL.Add( Prefix + AName + '.Name := ''' + Owner.Name + ''';' ); - //SL.Add( ' {$ENDIF}' ); - {P}SL.Add( ' IFDEF(USE_NAMES)' ); // Pcode not yet correctly implemented for DataModule! - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( Owner.Name ) ); - {P}SL.Add( ' LoadSELF' ); - {P}SL.Add( ' C3 TObj.SetName<3>' ); - {P}SL.Add( ' DelAnsiStr' ); - {P}SL.Add( ' ENDIF' ); - fP_NameSetuped := TRUE; - end; -end; - procedure TKOLForm.SetupName(SL: TStringList; const AName, AParent, - Prefix: String); + Prefix: string); begin - if FNameSetuped then Exit; - if (Name <> '') and GenerateCtlNames then - begin - if FormCompact and (AName <> 'nil') then - begin - FormAddCtlCommand( 'Form', 'FormSetName', '' ); - FormAddStrParameter( Owner.Name ); - end - else - if AName <> 'nil' {can be 'Result.Form'} then // this control placed NOT on datamodule - SL.Add( Prefix + AName + '.SetName( ' + {'Result.Form'} 'Applet' + ', ''' + Owner.Name + ''' );') - // Applet используется для хранения имен форм! - else // not on form - SL.Add(Format( '%sResult.SetName( Result, ''%s'' ); ', [Prefix, Owner.Name])); - FNameSetuped := TRUE; + if FNameSetuped then + Exit; + if (name <> '') and GenerateCtlNames then begin + if AName <> 'nil' {can be 'Result.Form'} then // this control placed NOT on datamodule + SL.Add(Prefix + AName + '.SetName( ' + {'Result.Form'} 'Applet' + ', ''' + Owner.name + ''' );') + // Applet используется для хранения имен форм! + else // not on form + SL.Add(Format('%sResult.SetName( Result, ''%s'' ); ', [Prefix, Owner.name])); + FNameSetuped := True; end; end; procedure TKOLForm.SetKeyPreview(const Value: Boolean); begin - if FKeyPreview = Value then Exit; + if FKeyPreview = Value then + Exit; FKeyPreview := Value; - Change( Self ); + Change(Self); end; procedure TKOLForm.SetOnMoving(const Value: TOnEventMoving); @@ -17854,13 +14299,13 @@ begin DB 'TKOLForm.SetOnMoving', 0 @@e_signature: end; - Log( '->TKOLForm.SetOnMoving' ); + Log('->TKOLForm.SetOnMoving'); try - FOnMoving := Value; - Change( Self ); - LogOK; + FOnMoving := Value; + Change(Self); + LogOK; finally - Log( '<-TKOLForm.SetOnMoving' ); + Log('<-TKOLForm.SetOnMoving'); end; end; @@ -17872,496 +14317,156 @@ begin DB 'TKOLForm.SetRestoreNormalMaximized', 0 @@e_signature: end; - Log( '->TKOLForm.SetRestoreNormalMaximized' ); + Log('->TKOLForm.SetRestoreNormalMaximized'); try - if not FLocked then - begin - if FRestoreNormalMaximized <> Value then - begin - FRestoreNormalMaximized := Value; - Change( Self ); + if not FLocked then begin + if FRestoreNormalMaximized <> Value then begin + FRestoreNormalMaximized := Value; + Change(Self); end; - end; + end; - LogOK; + LogOK; finally - Log( '<-TKOLForm.SetRestoreNormalMaximized' ); + Log('<-TKOLForm.SetRestoreNormalMaximized'); end; end; procedure TKOLForm.SetFontDefault(const Value: Boolean); begin - if FFontDefault = Value then Exit; - FFontDefault := Value; - TRY - if Value and (KOLProject <> nil) then - begin - TRY - if Font = nil then - Font := TKOLFont.Create(Self); - TRY - Font := KOLProject.DefaultFont; - EXCEPT - ShowMessage( 'exception 3' ); - END; - EXCEPT - ShowMessage( 'exception 2' ); - END; + if FFontDefault = Value then + Exit; + FFontDefault := Value; + try + if Value and (KOLProject <> nil) then begin + try + if Font = nil then + Font := TKOLFont.Create(Self); + try + Font := KOLProject.DefaultFont; + except + Showmessage('exception 3'); end; - EXCEPT - ShowMessage( 'exception 1' ); - END; - Change( Self ); -end; - -procedure TKOLForm.SetFormCompact(const Value: Boolean); -begin - FFormCompact := Value; - Change( Self ); -end; - -function TKOLForm.FormAddAlphabet(const funname: String; creates_ctrl, add_call: Boolean; - const Comment: String): Integer; -begin - if FFormAlphabet = nil then - FFormAlphabet := TStringList.Create; - Result := FFormAlphabet.IndexOf( funname ); - if Result < 0 then - begin - Result := FFormAlphabet.Count; - FFormAlphabet.AddObject( funname, Pointer(Integer( creates_ctrl )) ); + except + Showmessage('exception 2'); + end; end; - if add_call then - begin - if creates_ctrl then - begin - FFormCommandsAndParams := FFormCommandsAndParams + #13#10 + - ' +{' + funname + Comment + '}'#9 + EncodeFormNumParameter( -Result-1 ); - end - else - begin - FFormCommandsAndParams := FFormCommandsAndParams + #13#10 + - ' +{' + funname + Comment + '}'#9 + EncodeFormNumParameter( Result+1 ); - end; - end; -end; - -procedure TKOLForm.FormAddCtlParameter(const S: String); -begin - if FFormCtlParams = nil then - FFormCtlParams := TStringList.Create; - FFormCtlParams.Add( S ); -end; - -procedure TKOLForm.FormAddNumParameter(N: Integer); -begin - FFormCommandsAndParams := FFormCommandsAndParams + EncodeFormNumParameter( N ); -end; - -procedure TKOLForm.FormAddStrParameter(const S: String); -var i: Integer; - in_q: Boolean; - special: Boolean; -begin - FFormCommandsAndParams := FFormCommandsAndParams + - EncodeFormNumParameter( Length( S ) ) + ''''; - in_q := TRUE; - for i := 1 to Length( S ) do - begin - special := S[I] < ' '; - {$IFDEF _D2009orHigher} - if Byte(S[I]) >= 128 then - special := TRUE; - {$ELSE} - if (Byte(S[I]) >= 128) and not(S[I] in ['А'..'Я', 'а'..'я', 'Ё', 'ё']) then - special := TRUE; - {$ENDIF} - if special then - begin - if in_q then - FFormCommandsAndParams := FFormCommandsAndParams + ''''; - in_q := FALSE; - FFormCommandsAndParams := FFormCommandsAndParams + '#' + Int2Str(Byte(S[I])); - end - else - begin - if not in_q then - FFormCommandsAndParams := FFormCommandsAndParams + ''''; - in_q := TRUE; - FFormCommandsAndParams := FFormCommandsAndParams + S[I]; - end; - end; - if in_q then - FFormCommandsAndParams := FFormCommandsAndParams + ''''; -end; - -procedure TKOLForm.FormAddCtlCommand(const CtlName, FunName, Comment: String); -var i: Integer; - C: TComponent; -begin - if (CtlName <> '') - and (FormCurrentCtlForTransparentCalls <> CtlName) then - begin - //FormAddCtlParameter( CtlName ); - //FormCurrentCtlForTransparentCalls := CtlName; - C := Owner.FindComponent( CtlName ); - if (C <> nil) and (C is TKOLTabPage) - and ((C as TKOLTabPage).Parent is TKOLTabControl) then - begin - FormAddAlphabet( 'FormSetCurCtl', FALSE, TRUE, ' ' + CtlName ); - i := FormIndexOfControl( (C as TKOLTabPage).Parent.Name ); - FormAddNumParameter( i ); - FormCurrentCtlForTransparentCalls := (C as TKOLTabPage).Parent.Name; - FormAddAlphabet( 'FormSetTabpageAsParent', FALSE, TRUE, ' ' + CtlName ); - i := ((C as TKOLTabPage).Parent as TKOLTabControl).IndexOfPage( CtlName ); - FormAddNumParameter( i ); - FormCurrentParent := CtlName; - FormCurrentParentCtl := C as TKOLControl; - end - else - begin - FormAddAlphabet( 'FormSetCurCtl', FALSE, TRUE, ' ' + CtlName ); - i := FormIndexOfControl( CtlName ); - FormAddNumParameter( i ); - FormCurrentCtlForTransparentCalls := CtlName; - end; - end; - FormAddAlphabet( FunName, FALSE, TRUE, Comment ); -end; - -procedure TKOLForm.FormFlushCompact(SL: TFormStringList); -var i, j: Integer; - s: String; - //UL: TStringList; - //CL: TStringList; - AL: TStringList; -begin - if not FormCompact then Exit; - if FormFlushedCompact then - Exit; - if IsFormFlushing then Exit; - IsFormFlushing := TRUE; - TRY - SL.OnAdd := nil; - inc( FormIndexFlush ); - - Rpt( 'FormFlushCompact ' + IntToStr( FormIndexFlush ), YELLOW ); - RptDetailed( CopyTail( FFormCommandsAndParams, 100 ), CYAN ); - Rpt_Stack; - - {LogFileOutput( 'C:\BuggMCK+cp.txt', '--------------------- flush ' + - IntToStr( FormIndexFlush ) + #13#10 + SL.Text + #13#10 + - '-------------------- cmds¶ms on flush ' + IntToStr( FormIndexFlush ) + - ': ' + FFormCommandsAndParams);} - FFormCommandsAndParams := FFormCommandsAndParams + #13#10' +#0 {' + - 'flush:' + IntToStr( FormIndexFlush ) + '}'; - - {LogFileOutput( 'C:\BuggMCK.txt', '--------------------- flush ' + - IntToStr( FormIndexFlush ) + #13#10 + SL.Text );} - - if (FFormCtlParams = nil) or (FFormCtlParams.Count = 0) then - SL.Add( ' Result.Form.FormExecuteCommands( nil, nil ); ' + - '// flush: ' + IntToStr( FormIndexFlush ) ) - else - begin - {UL := TStringList.Create; - CL := TStringList.Create; - TRY} - s := UnitSourcePath + FormUnit + '.pas'; - //SL.Add( '// Loading from ' + s ); - //UL.LoadFromFile( s ); - //if UL.Count > 0 then - if FileExists( s ) then - begin - {for i := 0 to UL.Count-1 do - begin - if Trim( UL[i] ) = 'Form: PControl;' then - begin - //SL.Add( '// Form: PControl was found in line ' + IntToStr(i) ); - CL.Add( 'Form' ); - for j := i+4 to UL.Count-1 do - begin - s := Trim( UL[j] ); - if pos( ':', s ) <= 0 then break; - CL.Add( Trim( Parse( s, ':' ) ) ); - end; - break; - end; - end;} - - inc( FormFunArrayIdx ); - Rpt( 'Adding Result.Form.FormExecuteCommands( @ Result.Form, ' + - '@ FormControlsArray' + IntToStr( FormFunArrayIdx ) + '[0]);' + - '// flush: ' + IntToStr( FormIndexFlush ), RED ); - SL.Add( ' Result.Form.FormExecuteCommands( @ Result.Form, ' + - '@ FormControlsArray' + IntToStr( FormFunArrayIdx ) + '[0]);' + - '// flush: ' + IntToStr( FormIndexFlush ) ); - AL := TStringList.Create; - TRY - AL.Add( 'const FormControlsArray' + IntToStr( FormFunArrayIdx ) + - ': array[0..' + - IntToStr( FFormCtlParams.Count-1 ) + - '] of SmallInt = (' ); - for i := 0 to FFormCtlParams.Count-1 do - begin - j := //CL.IndexOf( FFormCtlParams[i] ); - FormIndexOfControl( FFormCtlParams[i] ); - s := Int2Str(j) + ' {' + FFormCtlParams[i] + '}'; - if i < FFormCtlParams.Count-1 then - s := s + ',' - else - s := s + ' );'; - AL.Add( ' ' + s ); - end; - for i := SL.Count-1 downto 0 do - begin - s := SL[i]; - if s = 'begin' then - begin - for j := AL.Count-1 downto 0 do - SL.Insert( i, AL[j] + ' // -- ' + IntToStr(j) ); - break; - end; - end; - FINALLY - AL.Free; - END; - - end else - begin - Rpt( 'not FileExists: ' + s, RED ); - end; - - {if CL.Count = 0 then - begin - SL.Add( '// Source Unit not found!!!' ); - SL.Add( ' Result.Form.FormExecuteCommands( @ Result.Form, [ ' ); - for i := 0 to FFormCtlParams.Count-1 do - begin - s := '(Integer(@ Result.' + FFormCtlParams[i] + - ') - Integer(@ Result.Form) ) div 4'; - if i < FFormCtlParams.Count-1 then - s := s + ',' - else - s := s + ' ] );'; - SL.Add( ' ' + s ); - end; - end;} - {FINALLY - UL.Free; - CL.Free; - END;} - - FFormCtlParams.Clear; - end; - //SL.Add( '// flush: ' + IntToStr( FormIndexFlush ) ); - FormFlushedUntil := Length( FFormCommandsAndParams ); - - {LogFileOutput( 'C:\BuggMCKafter.txt', '--------------------- flushed ' + - IntToStr( FormIndexFlush ) + #13#10 + SL.Text );} - - SL.OnAdd := DoFlushFormCompact; - FINALLY - IsFormFlushing := FALSE; - END; + except + Showmessage('exception 1'); + end; + Change(Self); end; procedure TKOLForm.SetGenerateCtlNames(const Value: Boolean); begin - if FGenerateCtlNames = Value then Exit; + if FGenerateCtlNames = Value then + Exit; FGenerateCtlNames := Value; - Change( Self ); -end; - -function TKOLForm.FormFlushedCompact: Boolean; -begin - Result := Length( FFormCommandsAndParams ) <= FormFlushedUntil; + Change(Self); end; procedure TKOLForm.SetUnicode(const Value: Boolean); begin FUnicode := Value; - Change( Self ); + Change(Self); end; -procedure TKOLForm.DoFlushFormCompact(Sender: TObject); +function TKOLForm.EncodeFormNumParameter(I: Integer): string; +var + B: Byte; + Buffer: array[0..7] of Byte; + k, j, II: Integer; + Sign: Boolean; begin - FormFlushCompact( Sender as TFormStringList ); -end; - -procedure TKOLForm.GenerateTransparentInits_Compact; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLForm.GenerateTransparentInits_Compact', 0 - @@e_signature: - end; - Log( '->TKOLForm.GenerateTransparentInits_Compact' ); + II := I; try - if not FLocked then - begin - - if not DefaultPosition then - begin - if not DoNotGenerateSetPosition then - begin - if FBounds <> nil then - begin - FormAddCtlCommand( 'Form', 'FormSetPosition', '' ); - FormAddNumParameter( Bounds.Left ); - FormAddNumParameter( Bounds.Top ); + k := 0; + if I = 0 then begin + k := 1; + Buffer[0] := 0; + end + else begin + Sign := False; + if I < 0 then begin + I := -I; + Sign := True; + end; + while True do begin + if k = 0 then begin + B := I shl 2; + if Sign then + B := B or 2; + I := I shr 6; + Buffer[k] := B; + Inc(k); + if I = 0 then + Break; + end + else if I and not $7F = 0 then begin + B := I shl 1; + //I := DWORD( I ) shr 7; + Buffer[k] := B; + Inc(k); + Break; + end + else begin + B := I shl 1; + I := DWORD(I) shr 7; + Buffer[k] := B; + Inc(k); + Continue; end; end; - end; - if not DefaultSize then - begin - if (Owner = nil) or not(Owner is TForm) then - if HasCaption then - begin - FormAddCtlCommand( 'Form', 'FormSetSize', '' ); - FormAddNumParameter( Bounds.Width ); - FormAddNumParameter( Bounds.Height ); - end - else - begin - FormAddCtlCommand( 'Form', 'FormSetSize', '' ); - FormAddNumParameter( Bounds.Width ); - FormAddNumParameter( Bounds.Height - GetSystemMetrics(SM_CYCAPTION) ); - end; + Result := ''; + for j := k - 1 downto 0 do begin + B := Buffer[j]; + if j > 0 then + B := B or 1; + Result := Result + '#$' + Int2Hex(B, 2); end; - - if Tabulate then - FormAddCtlCommand( 'Form', 'TControl.Tabulate', '' ) - else - if TabulateEx then - FormAddCtlCommand( 'Form', 'TControl.TabulateEx', '' ); - - if PreventResizeFlicks then - FormAddCtlCommand( 'Form', 'TControl.PreventResizeFlicks', '' ); - - if supportMnemonics then - FormAddCtlCommand( 'Form', 'TControl.SupportMnemonics' , ''); - - if HelpContext <> 0 then - begin - FormAddCtlCommand( 'Form', 'FormAssignHelpContext', '' ); - FormAddNumParameter( HelpContext ); + except on E: Exception do begin + RptDetailed('exception ' + E.Message + #13#10 + + '(in EncodeFormNumParameter I = ' + IntToStr(II) + ')', + RED); end; end; - - LogOK; - finally - Log( '<-TKOLForm.GenerateTransparentInits_Compact' ); - end; end; -function TKOLForm.EncodeFormNumParameter(I: Integer): String; -var b: Byte; - Buffer: array[ 0..7 ] of Byte; - k, j, II: Integer; - Sign: Boolean; +function TKOLForm.FormIndexOfControl(const CtlName: string): Integer; +var + s: KOLString; + UL: TStringList; + I, j: Integer; begin - II := I; - TRY - k := 0; - if I = 0 then - begin - k := 1; - Buffer[0] := 0; - end - else - begin - Sign := FALSE; - if I < 0 then - begin - I := -I; - Sign := TRUE; - end; - while TRUE do - begin - if k = 0 then - begin - b := I shl 2; - if Sign then - b := b or 2; - I := I shr 6; - Buffer[k] := b; - inc( k ); - if I = 0 then break; - end else - if I and not $7F = 0 then - begin - b := I shl 1; - //I := DWORD( I ) shr 7; - Buffer[k] := b; - inc( k ); - break; - end else - begin - b := I shl 1; - I := DWORD( I ) shr 7; - Buffer[k] := b; - inc( k ); - continue; - end; - end; + if FormControlsList = nil then begin + RptDetailed('Loading source of ' + formUnit, WHITE); + FormControlsList := TStringList.Create; + s := UnitSourcePath + formUnit + '.pas'; + UL := TStringList.Create; + try + LoadSource(UL, s); + RptDetailed('source loaded, searching Form: PControl', WHITE); + for I := 0 to UL.Count - 1 do begin + if Trim(UL[I]) = 'Form: PControl;' then begin + FormControlsList.Add('Form'); + for j := I + 4 to UL.Count - 1 do begin + s := Trim(UL[j]); + if Pos(':', s) <= 0 then + Break; + FormControlsList.Add(Trim(Parse(s, ':'))); + end; + Break; end; - - Result := ''; - for j := k-1 downto 0 do - begin - b := Buffer[j]; - if j > 0 then - b := b or 1; - Result := Result + '#$' + Int2Hex( b, 2 ); - end; - EXCEPT on E: Exception do - begin - RptDetailed( 'exception ' + E.Message + #13#10 + - '(in EncodeFormNumParameter I = ' + IntToStr( II ) + ')', - RED ); - end; - END; -end; - -function TKOLForm.FormIndexOfControl(const CtlName: String): Integer; -var s: KOLString; - UL: TStringList; - i, j: Integer; -begin - if FormControlsList = nil then - begin - RptDetailed( 'Loading source of ' + FormUnit, WHITE ); - FormControlsList := TStringList.Create; - s := UnitSourcePath + FormUnit + '.pas'; - UL := TStringList.Create; - TRY - LoadSource( UL, s ); - RptDetailed( 'source loaded, searching Form: PControl', WHITE ); - for i := 0 to UL.Count-1 do - begin - if Trim( UL[i] ) = 'Form: PControl;' then - begin - FormControlsList.Add( 'Form' ); - for j := i+4 to UL.Count-1 do - begin - s := Trim( UL[j] ); - if pos( ':', s ) <= 0 then break; - FormControlsList.Add( Trim( Parse( s, ':' ) ) ); - end; - break; - end; - end; - FINALLY - UL.Free; - END; + end; + finally + UL.free; end; - RptDetailed( 'searching ' + CtlName, WHITE ); - Result := FormControlsList.IndexOf( CtlName ); + end; + RptDetailed('searching ' + CtlName, WHITE); + Result := FormControlsList.IndexOf(CtlName); end; procedure TKOLForm.SetOverrideScrollbars(const Value: Boolean); @@ -18371,51 +14476,27 @@ end; procedure TKOLForm.SetAssignTextToControls(const Value: Boolean); begin - if fAssignTextToControls = Value then Exit; + if fAssignTextToControls = Value then + Exit; fAssignTextToControls := Value; - Change( Self ); + Change(Self); end; procedure TKOLForm.SetAssignTabOrders(const Value: Boolean); begin - if FAssignTabOrders = Value then Exit; + if FAssignTabOrders = Value then + Exit; FAssignTabOrders := Value; - Change( Self ); + Change(Self); end; -function TKOLForm.GetFormCompact: Boolean; +procedure TKOLForm.SetFormCurrentParent(const Value: string); begin - Result := FFormCompact; - if (KOLProject <> nil) and KOLProject.FormCompactDisabled then - Result := FALSE; -end; - -procedure TKOLForm.SetFormCurrentParent(const Value: String); -begin - RptDetailed( 'FormCurrentParent set to ' + Value + ' (was: ' + fFormCurrentParent + ')', - CYAN ); + RptDetailed('FormCurrentParent set to ' + Value + ' (was: ' + fFormCurrentParent + ')', + CYAN); fFormCurrentParent := Value; end; -procedure TKOLForm.ClearBeforeGenerateForm(SL: TStringList); -begin - if not FormCompact then Exit; - SL.Add( ' //--< place to call FormCreateParameters >--//' ); - FreeAndNil( FFormAlphabet ); - FreeAndNil( FFormCtlParams ); - FFormAlphabet := TStringList.Create; - FFormCtlParams := TStringList.Create; - Rpt( 'Clear before GenerateCreateForm (FormCompact', WHITE + LIGHT ); - FFormCommandsAndParams := ''; - FormCurrentParent := ''; - FormCurrentParentCtl := nil; - FormCurrentCtlForTransparentCalls := 'Form'; - GenerateTransparentInits_Compact; - FormFlushedUntil := 0; - FormIndexFlush := 0; - FreeAndNil( FormControlsList ); -end; - procedure TKOLForm.SetCenterOnCurScrn(const Value: Boolean); begin fCenterOnCurScrn := Value; @@ -18426,18 +14507,19 @@ end; procedure TKOLProject.AfterGenerateDPR(const SL: TStringList; var Updated: Boolean); begin - Log( 'TKOLProject.AfterGenerateDPR' ); + Log('TKOLProject.AfterGenerateDPR'); end; procedure TKOLProject.BeforeGenerateDPR(const SL: TStringList; var Updated: Boolean); begin - Log( 'TKOLProject.BeforeGenerateDPR' ); + Log('TKOLProject.BeforeGenerateDPR'); end; procedure TKOLProject.BroadCastPaintTypeToAllForms; -var I, J: Integer; - F: TForm; - C: TComponent; +var + I, j: Integer; + F: TForm; + c: TComponent; begin asm jmp @@e_signature @@ -18445,25 +14527,23 @@ begin DB 'TKOLProject.BroadCastPaintTypeToAllForms', 0 @@e_signature: end; - Log( '->TKOLProject.BroadCastPaintTypeToAllForms' ); - TRY + Log('->TKOLProject.BroadCastPaintTypeToAllForms'); + try if Screen <> nil then - for I := 0 to Screen.FormCount-1 do - begin - F := Screen.Forms[ I ]; - for J := 0 to F.ComponentCount-1 do - begin - C := F.Components[ J ]; - if C is TKOLForm then - (C as TKOLForm).PaintType := PaintType; + for I := 0 to Screen.FormCount - 1 do begin + F := Screen.Forms[I]; + for j := 0 to F.ComponentCount - 1 do begin + c := F.Components[j]; + if c is TKOLForm then + (c as TKOLForm).PaintType := PaintType; + end; end; - end; - LogOK; - FINALLY - Log( '<-TKOLProject.BroadCastPaintTypeToAllForms' ); - END; + LogOK; + finally + Log('<-TKOLProject.BroadCastPaintTypeToAllForms'); + end; end; procedure TKOLProject.Change; @@ -18474,67 +14554,62 @@ begin DB 'TKOLProject.Change', 0 @@e_signature: end; - Log( '->TKOLProject.Change' ); - TRY - - if fChangingNow or FLocked or (csLoading in ComponentState) then - begin - LogOK; - Exit; - end; - fChangingNow := TRUE; + Log('->TKOLProject.Change'); try - if AutoBuild then - begin - if fTimer <> nil then - begin - if FAutoBuildDelay > 0 then - begin - Rpt( 'Autobuild timer off/on', WHITE ); - //Rpt_Stack; - fTimer.Enabled := False; - fTimer.Enabled := True; - end - else - begin - RptDetailed( 'Calling TimerTick directly', WHITE ); - //Rpt_Stack; - fTimer.Enabled := FALSE; - TimerTick( fTimer ); - fTimer.Enabled := FALSE; + if fChangingNow or FLocked or (csLoading in ComponentState) then begin + LogOK; + Exit; + end; + fChangingNow := True; + try + + if autoBuild then begin + if fTimer <> nil then begin + if FAutoBuildDelay > 0 then begin + Rpt('Autobuild timer off/on', WHITE); + //Rpt_Stack; + fTimer.Enabled := False; + fTimer.Enabled := True; + end + else begin + RptDetailed('Calling TimerTick directly', WHITE); + //Rpt_Stack; + fTimer.Enabled := False; + TimerTick(fTimer); + fTimer.Enabled := False; + end; end; end; + + finally + fChangingNow := False; end; + LogOK; finally - fChangingNow := FALSE; + Log('<-TKOLProject.Change'); end; - - LogOK; - FINALLY - Log( '<-TKOLProject.Change' ); - END; end; procedure TKOLProject.ChangeAllForms; -var I: Integer; - F: TKolForm; +var + I: Integer; + F: TKOLForm; begin if FormsList <> nil then - for I := 0 to FormsList.Count - 1 do - begin - F := FormsList[ I ]; - F.Change( F ); - end; + for I := 0 to FormsList.Count - 1 do begin + F := FormsList[I]; + F.Change(F); + end; end; -function TKOLProject.ConvertVCL2KOL( ConfirmOK: Boolean; ForceAllForms: Boolean ): Boolean; -var I, E, N: Integer; - F: TKolForm; - S, E_reason: String; - tmp: String; - Color: Integer; +function TKOLProject.ConvertVCL2KOL(ConfirmOK: Boolean; ForceAllForms: Boolean): Boolean; +var + I, E, N: Integer; + F: TKOLForm; + s, E_reason: string; + Color: Integer; begin asm jmp @@e_signature @@ -18542,115 +14617,98 @@ begin DB 'TKOLProject.ConvertVCL2KOL', 0 @@e_signature: end; - Log( '->TKOLProject.ConvertVCL2KOL' ); - TRY - - Result := FALSE; - if not FLocked then - begin - if ProjectDest = '' then - begin - if not AutoBuilding then - ShowMessage( 'You have forgot to assign valid name to ProjectDest property ' + - 'TKOLProject component, which define KOL project name after ' + - 'converting of your mirror project. It must not much name of any other ' + - 'form in your project (FormName property of correspondent ' + - 'TKOLForm component). But if You want, it can much the name of ' + - 'source project (it will be stored in \KOL subdirectory, created ' + - 'in directory with source (mirror) project).' ); - LogOK; - Exit; - end; - if FormsList = nil then - begin - if not AutoBuilding then - begin - Log('--- There are not found TKOLForm instances ---'); - ShowMessage( 'There are not found TKOLForm component instances. You must create '+ - 'an instance for each form in your mirror project to provide ' + - 'converting mirror project to KOL.' ); + Log('->TKOLProject.ConvertVCL2KOL'); + try + Result := False; + if not FLocked then begin + if projectDest = '' then begin + if not AutoBuilding then + Showmessage('You have forgot to assign valid name to ProjectDest property ' + + 'TKOLProject component, which define KOL project name after ' + + 'converting of your mirror project. It must not much name of any other ' + + 'form in your project (FormName property of correspondent ' + + 'TKOLForm component). But if You want, it can much the name of ' + + 'source project (it will be stored in \KOL subdirectory, created ' + + 'in directory with source (mirror) project).'); + LogOK; + Exit; end; - LogOK; - Exit; - end; - FBuilding := True; - try + if FormsList = nil then begin + if not AutoBuilding then begin + Log('--- There are not found TKOLForm instances ---'); + Showmessage('There are not found TKOLForm component instances. You must create ' + + 'an instance for each form in your mirror project to provide ' + + 'converting mirror project to KOL.'); - fOutdcuPath := ''; - S := SourcePath; - S := S + ProjectDest; - E := 0; - E_reason := ''; - if not GenerateDPR( S ) then - begin - Inc( E ); - E_reason := 'dpr:' + S; - end; - N := 0; - if FormsList <> nil then - for I := 0 to FormsList.Count - 1 do - begin - F := FormsList[ I ]; - if not ForceAllForms and not F.FChanged then continue; - S := SourcePath + F.FormUnit; - if not F.GenerateUnit( S ) then - begin - Inc( E ); - E_reason := E_reason + ' unit:' + S; - end - else - Inc( N ); - end; - if E = 0 then - if not IsKOLProject then - UpdateConfig; - Color := WHITE; - if E = 0 then - begin - S := 'Converting finished successfully.'; - Color := GREEN; - if not ConfirmOK then S := ''; - Result := N > 0; - if Trim( CallPCompiler ) <> '' then - begin - tmp := '/S "' + IncludeTrailingPathDelimiter( ProjectSourcePath ) + - ProjectDest + '.exe"'; - I := ShellExecute( 0, nil, PChar( CallPCompiler ), - PChar(tmp), PChar( ProjectSourcePath ), SW_HIDE ); - RptDetailed( 'Called pcompiler: ' + IntToStr( I ), GREEN ); + end; + LogOK; + Exit; end; - end - else - begin - if N > 0 then - begin - S := 'Converting finished.'#13 + IntToStr( E ) + ' errors found( ' + - E_reason + ')'; - Color := RED; + FBuilding := True; + try + + fOutdcuPath := ''; + s := sourcePath; + s := s + projectDest; + E := 0; + E_reason := ''; + if not GenerateDPR(s) then begin + Inc(E); + E_reason := 'dpr:' + s; + end; + N := 0; + if FormsList <> nil then + for I := 0 to FormsList.Count - 1 do begin + F := FormsList[I]; + if not ForceAllForms and not F.FChanged then + Continue; + s := sourcePath + F.formUnit; + if not F.GenerateUnit(s) then begin + Inc(E); + E_reason := E_reason + ' unit:' + s; + end + else + Inc(N); + end; + if E = 0 then + if not isKOLProject then + UpdateConfig; + Color := WHITE; + if E = 0 then begin + s := 'Converting finished successfully.'; + Color := GREEN; + if not ConfirmOK then + s := ''; + Result := N > 0; + end else begin + if N > 0 then begin + s := 'Converting finished.'#13 + IntToStr(E) + ' errors found( ' + + E_reason + ')'; + Color := RED; + end; + end; + if s <> '' then + Report(s, Color); + + except + on E: Exception do begin + Showmessage('Can not convert VCL to KOL, exception: ' + E.Message); + end; end; end; - if S <> '' then - Report( S, color ); - except - on E: Exception do - begin - ShowMessage( 'Can not convert VCL to KOL, exception: ' + E.Message ); - end; - end; + FBuilding := False; + LogOK; + finally + Log('<-TKOLProject.ConvertVCL2KOL'); end; - - FBuilding := False; - LogOK; - FINALLY - Log( '<-TKOLProject.ConvertVCL2KOL' ); - END; end; constructor TKOLProject.Create(AOwner: TComponent); -var I: Integer; - C: TComponent; +var + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -18658,68 +14716,56 @@ begin DB 'TKOLProject.Create', 0 @@e_signature: end; - Log( '->TKOLProject.Create' ); - TRY + Log('->TKOLProject.Create'); + try + inherited; + fAutoBuild := True; + FAutoBuildDelay := 500; + fProtect := True; + fShowReport := False; // True; + fTimer := TTimer.Create(Self); + fTimer.Interval := 500; + fTimer.OnTimer := TimerTick; + fTimer.Enabled := False; + FDefaultFont := TKOLFont.Create(Self); + FDefaultFont.FontName := 'System'; - inherited; - {$IFDEF _D6orHigher} - FNewIF := TRUE; - {$ELSE} - FNewIF := FALSE; - {$ENDIF} + if AOwner <> nil then + for I := 0 to AOwner.ComponentCount - 1 do begin + c := AOwner.Components[I]; + if IsVCLControl(c) then begin + FLocked := True; + Showmessage('The form ' + AOwner.name + ' contains already VCL controls.'#13 + + 'The TKOLProject component is locked now and will not functioning.'#13 + + 'Just delete it and never drop onto forms, beloning to VCL projects.'); + Break; + end; + end; + if not FLocked then begin - fAutoBuild := True; - fAutoBuildDelay := 500; - fProtect := True; - fShowReport := FALSE; // True; - fTimer := TTimer.Create( Self ); - fTimer.Interval := 500; - fTimer.OnTimer := TimerTick; - fTimer.Enabled := FALSE; - FDefaultFont := TKOLFont.Create(Self); - FDefaultFont.FontName := 'System'; - - if AOwner <> nil then - for I := 0 to AOwner.ComponentCount-1 do - begin - C := AOwner.Components[ I ]; - if IsVCLControl( C ) then - begin - FLocked := TRUE; - ShowMessage( 'The form ' + AOwner.Name + ' contains already VCL controls.'#13 + - 'The TKOLProject component is locked now and will not functioning.'#13 + - 'Just delete it and never drop onto forms, beloning to VCL projects.' ); - break; - end; - end; - if not FLocked then - begin - - if (KOLProject <> nil) and (KOLProject.Owner <> AOwner) then - ShowMessage( 'You have more then one instance of TKOLProject component in ' + - 'your mirror project. Please remove all ambigous ones before ' + - 'running the project to avoid problems with generating code.' + - ' Or, may be, you open several projects at a time or open main ' + - 'form of another KOL&MCK project. This is not allowed.' ) - else - begin - KOLProject := Self; - if not( csDesigning in ComponentState) then - begin - ShowMessage( 'You did not finish converting VCL project to MCK. ' + - 'Do not forget, that you first must drop TKOLProject on ' + - 'form and change its property projectDest, and then drop ' + - 'TKOLForm component. Then you can open destination (MCK) project' + - ' and work with it.' ); - PostQuitMessage( 0 ); + if (KOLProject <> nil) and (KOLProject.Owner <> AOwner) then + Showmessage('You have more then one instance of TKOLProject component in ' + + 'your mirror project. Please remove all ambigous ones before ' + + 'running the project to avoid problems with generating code.' + + ' Or, may be, you open several projects at a time or open main ' + + 'form of another KOL&MCK project. This is not allowed.') + else begin + KOLProject := Self; + if not (csDesigning in ComponentState) then begin + Showmessage('You did not finish converting VCL project to MCK. ' + + 'Do not forget, that you first must drop TKOLProject on ' + + 'form and change its property projectDest, and then drop ' + + 'TKOLForm component. Then you can open destination (MCK) project' + + ' and work with it.'); + PostQuitMessage(0); + end; end; end; - end; - LogOK; - FINALLY - Log( '<-TKOLProject.Create' ); - END; + LogOK; + finally + Log('<-TKOLProject.Create'); + end; end; destructor TKOLProject.Destroy; @@ -18730,37 +14776,39 @@ begin DB 'TKOLProject.Destroy', 0 @@e_signature: end; - Log( '->TKOLProject.Destroy' ); - FIsDestroying := TRUE; - TRY + Log('->TKOLProject.Destroy'); + FIsDestroying := True; + try - if KOLProject = Self then - KOLProject := nil; - if FConsoleOut then - FreeConsole; - ResStrings.Free; - DefaultFont.Free; - inherited; + if KOLProject = Self then + KOLProject := nil; + if FConsoleOut then + FreeConsole; + ResStrings.free; + DefaultFont.free; + inherited; - LogOK; - FINALLY - Log( '<-TKOLProject.Destroy' ); - END; + LogOK; + finally + Log('<-TKOLProject.Destroy'); + end; end; type - TFormKind = ( fkNormal, fkMDIParent, fkMDIChild ); + TFormKind = (fkNormal, fkMDIParent, fkMDIChild); -function FormKind( const FName: String; var ParentFName: String ): TFormKind; -const Kinds: array[ TFormKind ] of String = ( 'fkNormal', 'fkMDIParent', 'fkMDIChild' ); -var I, J: Integer; - UN: String; - MI: TIModuleInterface; - FI: TIFormInterface; - FCI, CI: TIComponentInterface; - KindDefined: Boolean; - S, ObjName, ObjType: KOLString; - SL: TStringList; +function FormKind(const FName: string; var ParentFName: string): TFormKind; +const + Kinds: array[TFormKind] of string = ('fkNormal', 'fkMDIParent', 'fkMDIChild'); +var + I, j: Integer; + UN: string; + MI: TIModuleInterface; + FI: TIFormInterface; + FCI, CI: TIComponentInterface; + KindDefined: Boolean; + s, ObjName, ObjType: KOLString; + SL: TStringList; begin asm jmp @@e_signature @@ -18768,145 +14816,126 @@ begin DB 'FormKind', 0 @@e_signature: end; - Log( '->FormKind' ); - TRY + Log('->FormKind'); + try - Rpt( 'Analizing form: ' + FName, WHITE ); - //Rpt_Stack; - Result := fkNormal; - TRY + Rpt('Analizing form: ' + FName, WHITE); + //Rpt_Stack; + Result := fkNormal; + try - KindDefined := FALSE; - //-- 1. Try to search a form among loaded into the designer. - for I := 0 to ToolServices.GetUnitCount-1 do - begin - UN := ToolServices.GetUnitName( I ); - MI := ToolServices.GetModuleInterface( UN ); - if MI <> nil then - TRY - FI := MI.GetFormInterface; - if FI <> nil then - TRY - FCI := FI.GetFormComponent; - if FCI <> nil then - TRY - S := ''; - FCI.GetPropValueByName( 'Name', S ); - //Rpt( 'Form component interface obtained for ' + FName + - // ', Name=' + S + ' (Unit=' + UN + ')', WHITE ); - if AnsiCompareText( S, FName ) = 0 then - for J := 0 to FCI.GetComponentCount-1 do - begin - CI := FCI.GetComponent( J ); - if CI.GetComponentType = 'TKOLMDIClient' then - begin - Rpt( 'TKOLMDIClient found in ' + FName, WHITE ); - Result := fkMDIParent; - KindDefined := TRUE; - end - else - if CI.GetComponentType = 'TKOLMDIChild' then - begin - Rpt( 'TKOLMDIChild found in ' + FName, WHITE ); - Result := fkMDIChild; - CI.GetPropValueByName( 'ParentMDIForm', ParentFName ); - KindDefined := TRUE; - end; - if KindDefined then - begin - LogOK; - Exit; - end; - end - else - if S = '' then - begin - if CompareText( ExtractFileExt( UN ), '.pas' ) = 0 then - begin - SL := TStringList.Create; - TRY - SL.LoadFromFile( ChangeFileExt( UN, '.dfm' ) ); - Rpt( 'Loaded dfm for ' + UN, WHITE ); - ObjName := ''; - ObjType := ''; - KindDefined := FALSE; - for J := 0 to SL.Count-1 do - begin - S := Trim( SL[ J ] ); - if StrIsStartingFrom( PKOLChar( S ), 'object ' ) then - begin - Parse( S, AnsiString(' ') ); - ObjName := Trim( Parse( S, ':' ) ); - ObjType := Trim( S ); - if J = 0 then - begin - if AnsiCompareText( ObjName, FName ) <> 0 then - begin - Rpt( 'Another form - - continue', WHITE ); - break; - end; - end; - if (ObjType = 'TKOLMDIClient') then - begin - Rpt( 'TKOLMDIClient found for ' + FName + ' in dfm', WHITE ); - Result := fkMDIParent; - KindDefined := TRUE; - end; + KindDefined := False; + //-- 1. Try to search a form among loaded into the designer. + for I := 0 to ToolServices.GetUnitCount - 1 do begin + UN := ToolServices.GetUnitName(I); + MI := ToolServices.GetModuleInterface(UN); + if MI <> nil then try + FI := MI.GetFormInterface; + if FI <> nil then try + FCI := FI.GetFormComponent; + if FCI <> nil then try + s := ''; + FCI.GetPropValueByName('Name', s); + //Rpt( 'Form component interface obtained for ' + FName + + // ', Name=' + S + ' (Unit=' + UN + ')', WHITE ); + if AnsiCompareText(s, FName) = 0 then + for j := 0 to FCI.GetComponentCount - 1 do begin + CI := FCI.GetComponent(j); + if CI.GetComponentType = 'TKOLMDIClient' then begin + Rpt('TKOLMDIClient found in ' + FName, WHITE); + Result := fkMDIParent; + KindDefined := True; end - else - begin - if not KindDefined and - (ObjType = 'TKOLMDIChild') and - StrIsStartingFrom( PKOLChar( S ), 'ParentMDIForm = ' ) then - begin - Rpt( 'TKOLMDIChild found for ' + FName + ' in dfm', WHITE ); - Result := fkMDIChild; - KindDefined := TRUE; - Parse( S, '=' ); - S := Trim( S ); - if Length( S ) > 2 then - S := Copy( S, 2, Length( S ) - 2 ); - ParentFName := S; - end; + else if CI.GetComponentType = 'TKOLMDIChild' then begin + Rpt('TKOLMDIChild found in ' + FName, WHITE); + Result := fkMDIChild; + CI.GetPropValueByName('ParentMDIForm', ParentFName); + KindDefined := True; end; - if KindDefined then - begin + if KindDefined then begin LogOK; Exit; end; + end + else if s = '' then begin + if CompareText(ExtractFileExt(UN), '.pas') = 0 then begin + SL := TStringList.Create; + try + SL.LoadFromFile(ChangeFileExt(UN, '.dfm')); + Rpt('Loaded dfm for ' + UN, WHITE); + ObjName := ''; + ObjType := ''; + KindDefined := False; + for j := 0 to SL.Count - 1 do begin + s := Trim(SL[j]); + if StrIsStartingFrom(PKOLChar(s), 'object ') then begin + Parse(s, AnsiString(' ')); + ObjName := Trim(Parse(s, ':')); + ObjType := Trim(s); + if j = 0 then begin + if AnsiCompareText(ObjName, FName) <> 0 then begin + Rpt('Another form - - continue', WHITE); + Break; + end; + end; + if (ObjType = 'TKOLMDIClient') then begin + Rpt('TKOLMDIClient found for ' + FName + ' in dfm', WHITE); + Result := fkMDIParent; + KindDefined := True; + end; + end + else begin + if not KindDefined and + (ObjType = 'TKOLMDIChild') and + StrIsStartingFrom(PKOLChar(s), 'ParentMDIForm = ') then begin + Rpt('TKOLMDIChild found for ' + FName + ' in dfm', WHITE); + Result := fkMDIChild; + KindDefined := True; + Parse(s, '='); + s := Trim(s); + if Length(s) > 2 then + s := Copy(s, 2, Length(s) - 2); + ParentFName := s; + end; + end; + if KindDefined then begin + LogOK; + Exit; + end; + end; + finally + SL.free; + end; end; - FINALLY - SL.Free; - END; + end; + finally + FCI.free; end; + finally + FI.free; end; - FINALLY - FCI.Free; - END; - FINALLY - FI.Free; - END; - FINALLY - MI.Free; - END; - end; - Result := fkNormal; - FINALLY - Rpt( 'Analized form ' + FName + 'Kind: ' + Kinds[ Result ], WHITE ); - END; + finally + MI.free; + end; + end; + Result := fkNormal; + finally + Rpt('Analized form ' + FName + 'Kind: ' + Kinds[Result], WHITE); + end; - LogOK; - FINALLY - Log( '<-FormKind' ); - END; + LogOK; + finally + Log('<-FormKind'); + end; end; -procedure ReorderForms( Prj: TKOLProject; Forms: TStringList ); -var Rslt: TStringList; - I, J: Integer; - FormName, Name2, ParentFormName: String; - S: KOLString; - Kind: TFormKind; +procedure ReorderForms(Prj: TKOLProject; Forms: TStringList); +var + Rslt: TStringList; + I, j: Integer; + formName, Name2, ParentFormName: string; + s: KOLString; + Kind: TFormKind; begin asm jmp @@e_signature @@ -18914,356 +14943,335 @@ begin DB 'ReorderForms', 0 @@e_signature: end; - Log( '->ReorderForms' ); - TRY + Log('->ReorderForms'); + try - Rslt := TStringList.Create; - TRY - /// D[u]fa - /// без проверки на 0 падала генерация кода - /// после добавления все работает (по идее эта проврка исключает вызов - /// FormKind в котором скорее всего ошибка) - /// дальше копать не стал - for I := 0 to Forms.Count-1 do - if Assigned(Forms.Objects[I]) then - begin - Kind := FormKind( Forms.Strings[ I ], ParentFormName ); -//rpt('->ReorderForms2', YELLOW); - Forms.Objects[ I ] := Pointer( Kind ); - if Kind = fkMDIChild then - Forms[ I ] := Forms[ I ] + ',' + ParentFormName; - end; - for I := 0 to Forms.Count-1 do - begin - FormName := Forms[ I ]; - if FormName = '' then continue; - Kind := TFormKind( Forms.Objects[ I ] ); - if Kind in [ fkNormal, fkMDIParent ] then - begin - Rslt.Add( FormName ); - Forms[ I ] := ''; - end; - if Kind = fkMDIParent then - for J := 0 to Forms.Count - 1 do - begin - Name2 := Forms[ J ]; - if Name2 = '' then continue; - if TFormKind( Forms.Objects[ J ] ) = fkMDIChild then - begin - S := Name2; - {$IFDEF UNICODE_CTRLS} ParseW {$ELSE} Parse {$ENDIF} ( S, ',' ); - if CompareText( S, FormName ) = 0 then - begin - Rslt.Add( Name2 ); - Forms[ J ] := ''; - end; + Rslt := TStringList.Create; + try + /// dufa + /// без проверки на 0 падала генерация кода + /// после добавления все работает (по идее эта проврка исключает вызов + /// FormKind в котором скорее всего ошибка) + /// дальше копать не стал + for I := 0 to Forms.Count - 1 do + if Assigned(Forms.Objects[I]) then begin + Kind := FormKind(Forms.Strings[I], ParentFormName); + //rpt('->ReorderForms2', YELLOW); + Forms.Objects[I] := Pointer(Kind); + if Kind = fkMDIChild then + Forms[I] := Forms[I] + ',' + ParentFormName; end; + for I := 0 to Forms.Count - 1 do begin + formName := Forms[I]; + if formName = '' then + Continue; + Kind := TFormKind(Forms.Objects[I]); + if Kind in [fkNormal, fkMDIParent] then begin + Rslt.Add(formName); + Forms[I] := ''; + end; + if Kind = fkMDIParent then + for j := 0 to Forms.Count - 1 do begin + Name2 := Forms[j]; + if Name2 = '' then + Continue; + if TFormKind(Forms.Objects[j]) = fkMDIChild then begin + s := Name2; +{$IFDEF UNICODE_CTRLS}ParseW{$ELSE}Parse{$ENDIF}(s, ','); + if CompareText(s, formName) = 0 then begin + Rslt.Add(Name2); + Forms[j] := ''; + end; + end; + end; end; + Forms.Assign(Rslt); + finally + Rslt.free; end; - Forms.Assign( Rslt ); - FINALLY - Rslt.Free; - END; - LogOK; - FINALLY - Log( '<-ReorderForms' ); - END; + LogOK; + finally + Log('<-ReorderForms'); + end; end; -function TKOLProject.GenerateDPR(const Path: String): Boolean; -const BeginMark = 'begin // PROGRAM START HERE -- Please do not remove this comment'; - BeginResourceStringsMark = '// RESOURCE STRINGS START HERE -- Please do not change this section'; -var SL, Source, AForms: TStringList; - A, S, S1, FM: KOLString; - I, J: Integer; - F: TKOLForm; - Found: Boolean; - Updated: Boolean; - Object2Run: TObject; - IsDLL: Boolean; - FormsToAutoCreate: TStringList; - ///////////////////////////////////////////////////////////////////////// - procedure Prepare_0inc; - var SL: TStringList; - I, J: Integer; - S: String; - {$IFDEF _D2009orHigher} - C, C2: WideString; - {$ELSE} - C: string; - {$ENDIF} - begin - // prepare _0.inc, which is to replace - // begin .. end. of a project. +///////////////////////////////////////////////////////////////////////// - SL := TStringList.Create; - TRY +procedure TKOLProject.Prepare_0inc(const Path: String; const IsDLL: Boolean; const AForms: TStringList; + var AParent: KOLString; var Updated: Boolean); +var + SL: TStringList; + F: TKOLForm; + I: Integer; + j: Integer; + s: string; + FM: KOLString; + Object2Run: TObject; + Found: Boolean; +{$IFDEF _D2009orHigher} + c, C2: WideString; +{$ELSE} + c: string; +{$ENDIF} +begin + // prepare _0.inc, which is to replace + // begin .. end. of a project. + SL := TStringList.Create; + try + SL.Add(Signature); + SL.Add('{ ' + projectDest + '_0.inc'); + SL.Add(' Do not edit this file manually - it is generated automatically.'); + SL.Add(' You can only modify ' + projectDest + '_1.inc and ' + projectDest + '_3.inc'); + SL.Add(' files. }'); + SL.Add(''); - SL.Add( Signature ); - SL.Add( '{ ' + ProjectDest + '_0.inc' ); - SL.Add( ' Do not edit this file manually - it is generated automatically.' ); - SL.Add( ' You can only modify ' + ProjectDest + '_1.inc and ' + ProjectDest + '_3.inc' ); - SL.Add( ' files. }' ); - SL.Add( '' ); + if SupportAnsiMnemonics <> 0 then begin + if SupportAnsiMnemonics = 1 then + I := GetUserDefaultLCID + else + I := SupportAnsiMnemonics; + SL.Add(' SupportAnsiMnemonics( $' + IntToHex(I, 8) + ' );'); + end; - SL.Add( '{$IFDEF Pcode}' ); - SL.Add( ' InstallCollapse;' ); - SL.Add( '{$ENDIF Pcode}' ); + Object2Run := nil; + AParent := 'nil'; + if (Applet <> nil) then {// TODO: TKOLApplet must be on main form} begin // (to be always available for TKOLProject) + AParent := 'Applet'; + Object2Run := Applet; + end; - if SupportAnsiMnemonics <> 0 then - begin - if SupportAnsiMnemonics = 1 then - I := GetUserDefaultLCID - else - I := SupportAnsiMnemonics; - SL.Add( ' SupportAnsiMnemonics( $' + IntToHex( I, 8 ) + ' );' ); + if (Applet <> nil) then begin + c := Applet.Caption; +{$IFDEF _D2009orHigher} + C2 := ''; + for I := 1 to Length(c) do + C2 := C2 + '#' + int2str(Ord(c[I])); + c := C2; + SL.Add(' Applet := NewApplet( ' + c + ' );'); +{$ELSE} + SL.Add(' Applet := NewApplet( ''' + c + ''' );'); +{$ENDIF} + if not Applet.Visible then begin + SL.Add(' Applet.GetWindowHandle;'); + SL.Add(' Applet.Visible := False;'); end; - - if Applet <> nil then - begin - C := Applet.Caption; - {$IFDEF _D2009orHigher} - C2 := ''; - for i := 1 to Length(C) do C2 := C2 + '#'+int2str(ord(C[i])); - C := C2; - SL.Add( ' Applet := NewApplet( ' + C + ' );' ); - {$ELSE} - SL.Add( ' Applet := NewApplet( ''' + C + ''' );' ); - {$ENDIF} - if not Applet.Visible then - begin - SL.Add( ' Applet.GetWindowHandle;' ); - SL.Add( ' Applet.Visible := False;' ); - end; - if (Applet.Icon <> '') or Applet.ForceIcon16x16 then - begin - if Copy( Applet.Icon, 1, 4 ) = 'IDI_' then - SL.Add( ' Applet.IconLoad( 0, ' + Applet.Icon + ' );' ) + if (Applet.Icon <> '') or Applet.ForceIcon16x16 then begin + if Copy(Applet.Icon, 1, 4) = 'IDI_' then + SL.Add(' Applet.IconLoad( 0, ' + Applet.Icon + ' );') + else if Applet.Icon = '-1' then + SL.Add(' Applet.Icon := THandle(-1);') + else begin + if (Applet.Icon <> '-1') and Applet.ForceIcon16x16 then begin + s := Applet.Icon; + if s = '' then + s := 'MAINICON'; + SL.Add(' Applet.Icon := LoadImgIcon( ' + String2Pascal(s, '+') + ', 16 );'); + end else - if Applet.Icon = '-1' then - SL.Add( ' Applet.Icon := THandle(-1);' ) - else - begin - if (Applet.Icon <> '-1') and Applet.ForceIcon16x16 then - begin - S := Applet.Icon; - if S = '' then - S := 'MAINICON'; - SL.Add( ' Applet.Icon := LoadImgIcon( ' + String2Pascal( S, '+' ) + ', 16 );' ); - end - else - SL.Add( ' Applet.IconLoad( hInstance, ''' + Applet.Icon + ''' );' ); - end; - end; - end - else - if not IsDLL then - begin - for I := 0 to FormsList.Count - 1 do - begin - F := FormsList[ I ]; - if F is TKOLFrame then continue; - if F.FormMain then - begin - SL.Add( ' New' + F.FormName + '( ' + F.FormName + ', ' + - A + ' );' ); - //SL.Add( ' Applet := ' + F.FormName + '.Form;' ); - A := F.FormName + '.Form'; - Object2Run := F; - - end; + SL.Add(' Applet.IconLoad( hInstance, ''' + Applet.Icon + ''' );'); end; end; + end else if not IsDLL then begin + for I := 0 to FormsList.Count - 1 do begin + F := FormsList[I]; + if (F is TKOLFrame) then + Continue; + + if F.formMain then begin + SL.Add(' New' + F.formName + '( ' + F.formName + ', ' + AParent + ' );'); + AParent := F.formName + '.Form'; + Object2Run := F; + end; + end; + end; - SL.Add( '{$I ' + ProjectDest + '_1.inc}' ); + SL.Add('{$I ' + projectDest + '_1.inc}'); + SL.Add('{$I ' + projectDest + '_2.inc}'); + SL.Add('{$I ' + projectDest + '_3.inc}'); + SL.Add(''); - SL.Add( '' ); - SL.Add( '{$I ' + ProjectDest + '_2.inc}' ); - - SL.Add( '' ); - SL.Add( '{$I ' + ProjectDest + '_3.inc}' ); - - SL.Add( '' ); - - FM := ''; - if FormsList <> nil then - for I := 0 to FormsList.Count - 1 do - begin - F := FormsList[ I ]; - if F is TKOLFrame then continue; - if F.FormMain then - begin - FM := F.FormName + '.Form'; - if Object2Run = nil then + FM := ''; + if (FormsList <> nil) then begin + for I := 0 to FormsList.Count - 1 do begin + F := FormsList[I]; + if F is TKOLFrame then + Continue; + if F.formMain then begin + FM := F.formName + '.Form'; + if (Object2Run = nil) then Object2Run := F; end; end; + end; - if A <> 'nil' then - FM := A; + if (AParent <> 'nil') then + FM := AParent; - if (HelpFile <> '') and not IsDLL then - begin - if AnsiCompareText( ExtractFileExt( HelpFile ), '.chm' ) = 0 then - SL.Add( ' AssignHtmlHelp( ' + StringConstant( 'HelpFile', HelpFile ) + ' );' ) - else - SL.Add( ' Applet.HelpPath := ' + StringConstant( 'HelpFile', HelpFile ) + ';' ); - end; - if not IsDLL then - begin - TKOLApplet( Object2Run ).GenerateRun( SL, FM ); - //SL.Add( ' Run( ' + FM + ' );' ); + if (HelpFile <> '') and not IsDLL then begin + if AnsiCompareText(ExtractFileExt(HelpFile), '.chm') = 0 then + SL.Add(' AssignHtmlHelp( ' + StringConstant('HelpFile', HelpFile) + ' );') + else + SL.Add(' Applet.HelpPath := ' + StringConstant('HelpFile', HelpFile) + ';'); + end; - if FormsList <> nil then - for I := 0 to FormsList.Count - 1 do - begin - F := FormsList[ I ]; - if F is TKOLFrame then continue; - Found := FALSE; - for J := 0 to AForms.Count-1 do - begin - if CompareText( AForms[ J ], F.FormName ) = 0 then - begin - Found := TRUE; - break; + if not IsDLL then begin + TKOLApplet(Object2Run).GenerateRun(SL, FM); + + if (FormsList <> nil) then + for I := 0 to FormsList.Count - 1 do begin + F := FormsList[I]; + if F is TKOLFrame then + Continue; + Found := False; + for j := 0 to AForms.Count - 1 do begin + if CompareText(AForms[j], F.formName) = 0 then begin + Found := True; + Break; end; end; if Found then - F.GenerateDestroyAfterRun( SL ); + F.GenerateDestroyAfterRun(SL); + end; + end; + + SL.Add(''); + SL.Add('{$I ' + projectDest + '_4.inc}'); + SL.Add(''); + SaveStrings(SL, Path + '_0.inc', Updated); + finally + SL.free; + end; +end; + + +procedure TKOLProject.Prepare_134inc(const Path: string; var Updated: Boolean); +var + SL: TStringList; +begin + SL := TStringList.Create; + try + // if files _1.inc and _3.inc do not exist, create it (empty). + if not FileExists(Path + '_1.inc') then begin + SL.Add('{ ' + projectDest + '_1.inc'); + SL.Add(' This file is for you. Place here any code to run it'); + SL.Add(' just following Applet creation (if it present) but '); + SL.Add(' before creating other forms. E.g., You can place here'); + SL.Add(' statement, which prevents running of application'); + SL.Add(' in some cases. TIP: always use Applet for such checks'); + SL.Add(' and make it invisible until final decision if to run'); + SL.Add(' application or not. }'); + SL.Add(''); + SaveStrings(SL, Path + '_1.inc', Updated); + SL.Clear; + end; + + if not FileExists(Path + '_3.inc') then begin + SL.Add('{ ' + projectDest + '_3.inc'); + SL.Add(' This file is for you. Place here any code to run it'); + SL.Add(' after forms creating, but before Run call, if necessary. }'); + SL.Add(''); + SaveStrings(SL, Path + '_3.inc', Updated); + SL.Clear; + end; + + if not FileExists(Path + '_4.inc') then begin + SL.Add('{ ' + projectDest + '_4.inc'); + SL.Add(' This file is for you. Place here any code to be inserted'); + SL.Add(' after Run call, if necessary. }'); + SL.Add(''); + SaveStrings(SL, Path + '_4.inc', Updated); + SL.Clear; + end; + + finally + SL.free; + end; +end; + +procedure TKOLProject.Prepare_2inc(const Path: String; const IsDLL: Boolean; const AForms: TStringList; + var AParent: KOLString; var Updated: Boolean; const FormsToAutoCreate: TStringList); + +var + SL: TStringList; + I: Integer; + j: Integer; + s: KOLString; + S1: KOLString; + F: TKOLForm; +begin + SL := TStringList.Create; + try + // for now, generate _2.inc + SL.Add(Signature); + SL.Add('{ ' + projectDest + '_2.inc'); + SL.Add(' Do not modify this file manually - it is generated automatically. }'); + SL.Add(''); + + if not IsDLL then begin + for I := 0 to AForms.Count - 1 do begin + s := AForms[I]; + s := Trim({$IFDEF UNICODE_CTRLS}ParseW{$ELSE}Parse{$ENDIF}(s, ',')); + F := nil; + for j := 0 to FormsList.Count - 1 do begin + F := FormsList[j]; + if CompareText(AForms[I], F.formName) = 0 then + Break + else + F := nil; + // Это недостаточно, чтобы решить, что перед нами frame, а не form. + // Фрейм должен быть исключен из списка авто-create. + end; + if (F <> nil) and (F is TKOLFrame) then + Continue; + //Rpt( 'AutoForm: ' + S ); + if (LowerCase(AParent) = LowerCase(s + '.Form')) then + Continue; + + Log('check auto create: ' + AForms[I] + ' list: ' + + FormsToAutoCreate.Text); + if (Pos(',', AForms[I]) > 0) and + ((FormsToAutoCreate.Count = 0) or (FormsToAutoCreate.IndexOf(AForms[I]) >= 0)) then begin + Log('Yes, auto create'); + // MDI child form + S1 := AForms[I]; + if (Pos(',', S1) > 0) then + Parse(S1, ','); + SL.Add(' New' + Trim(s) + '( ' + Trim(s) + ', ' + Trim(S1) + '.Form );'); + end else if (FormsToAutoCreate.Count = 0) or (FormsToAutoCreate.IndexOf(AForms[I]) >= 0) then begin + // normal or MDI parent form + SL.Add(' New' + s + '( ' + s + ', Pointer( ' + AParent + ' ) );'); end; end; - - SL.Add( '' ); - SL.Add( '{$I ' + ProjectDest + '_4.inc}' ); - - SL.Add( '' ); - SaveStrings( SL, Path + '_0.inc', Updated ); - - FINALLY - SL.Free; - END; end; + SaveStrings(SL, Path + '_2.inc', Updated); + finally + SL.free; + end; +end; - ///////////////////////////////////////////////////////////////////////// - procedure Prepare_134inc; - var SL: TStringList; - begin +function TKOLProject.GenerateDPR(const Path: string): Boolean; +const + BeginMark = 'begin // PROGRAM START HERE -- Please do not remove this comment'; + BeginResourceStringsMark = '// RESOURCE STRINGS START HERE -- Please do not change this section'; - SL := TStringList.Create; - TRY +var + SL: TStringList; + Source: TStringList; + AForms: TStringList; + AParent: KOLString; + s: KOLString; + I, j: Integer; + F: TKOLForm; + Updated: Boolean; + IsDLL: Boolean; + FormsToAutoCreate: TStringList; - // if files _1.inc and _3.inc do not exist, create it (empty). + ///////////////////////////////////////////////////////////////////////// - if not FileExists( Path + '_1.inc' ) then - begin - SL.Add( '{ ' + ProjectDest + '_1.inc' ); - SL.Add( ' This file is for you. Place here any code to run it' ); - SL.Add( ' just following Applet creation (if it present) but ' ); - SL.Add( ' before creating other forms. E.g., You can place here' ); - SL.Add( ' statement, which prevents running of application' ); - SL.Add( ' in some cases. TIP: always use Applet for such checks' ); - SL.Add( ' and make it invisible until final decision if to run' ); - SL.Add( ' application or not. }' ); - SL.Add( '' ); - SaveStrings( SL, Path + '_1.inc', Updated ); - SL.Clear; - end; - - if not FileExists( Path + '_3.inc' ) then - begin - SL.Add( '{ ' + ProjectDest + '_3.inc' ); - SL.Add( ' This file is for you. Place here any code to run it' ); - SL.Add( ' after forms creating, but before Run call, if necessary. }' ); - SL.Add( '' ); - SaveStrings( SL, Path + '_3.inc', Updated ); - SL.Clear; - end; - - if not FileExists( Path + '_4.inc' ) then - begin - SL.Add( '{ ' + ProjectDest + '_4.inc' ); - SL.Add( ' This file is for you. Place here any code to be inserted' ); - SL.Add( ' after Run call, if necessary. }' ); - SL.Add( '' ); - SaveStrings( SL, Path + '_4.inc', Updated ); - SL.Clear; - end; - - FINALLY - SL.Free; - END; - end; - - //////////////////////////////////////////////////////////////////////// - procedure Prepare_2inc; - var SL: TStringList; - I, J: Integer; - begin - SL := TStringList.Create; - TRY - // for now, generate _2.inc - SL.Add( Signature ); - SL.Add( '{ ' + ProjectDest + '_2.inc' ); - SL.Add( ' Do not modify this file manually - it is generated automatically. }' ); - SL.Add( '' ); - - if not IsDLL then - begin - for I := 0 to AForms.Count - 1 do - begin - S := AForms[ I ]; - S := Trim( {$IFDEF UNICODE_CTRLS} ParseW {$ELSE} Parse {$ENDIF} ( S, ',' ) ); - F := nil; - for J := 0 to FormsList.Count - 1 do - begin - F := FormsList[ J ]; - if CompareText( AForms[ I ], F.formName ) = 0 then - break - else - F := nil; - // Это недостаточно, чтобы решить, что перед нами frame, а не form. - // Фрейм должен быть исключен из списка авто-create. - end; - if (F <> nil) and (F is TKOLFrame) then continue; - //Rpt( 'AutoForm: ' + S ); - if LowerCase( A ) = LowerCase( S + '.Form' ) then Continue; - - Log('check auto create: ' + AForms[I] + ' list: ' + - FormsToAutoCreate.Text); - if (pos( ',', AForms[ I ] ) > 0) and - ((FormsToAutoCreate.Count = 0) or - (FormsToAutoCreate.IndexOf(AForms[I]) >= 0) - ) then - begin - Log('Yes, auto create'); - // MDI child form - S1 := AForms[ I ]; - if pos(',', S1) > 0 then Parse( S1, ',' ); - SL.Add( ' New' + Trim( S ) + '( ' + Trim( S ) + ', ' + - Trim( S1 ) + '.Form );' ); - end - else - if (FormsToAutoCreate.Count = 0) or - (FormsToAutoCreate.IndexOf(AForms[I]) >= 0) then - begin - // normal or MDI parent form - SL.Add( ' New' + S + '( ' + S + ', Pointer( ' + A + ' ) );' ); - end; - end; - end; - - SaveStrings( SL, Path + '_2.inc', Updated ); - - FINALLY - SL.Free; - END; - end; - - ///////////////////////////////////////////////////////////////////////// - -var Kol_added, DontChangeUses: Boolean; - forms_list_auto: String; +var + Kol_added, DontChangeUses: Boolean; + forms_list_auto: string; begin asm jmp @@e_signature @@ -19271,320 +15279,275 @@ begin DB 'TKOLProject.GenerateDPR', 0 @@e_signature: end; - Log( '->TKOLProject.GenerateDPR' ); + Log('->TKOLProject.GenerateDPR'); //---------------------- список форм для автоматического создания ------------ FormsToAutoCreate := TStringList.Create; - TRY - - forms_list_auto := AutoCreateForms; - while forms_list_auto <> '' do - begin - FormsToAutoCreate.Add(KOL.Parse(forms_list_auto, ';')); - end; - - TRY - - Rpt( 'Generating DPR for ' + Path, WHITE ); //Rpt_Stack; - Result := False; - if FLocked then - begin - Rpt( 'TKOLProject LOCKED.', RED ); - LogOK; Exit; - end; - Updated := FALSE; - SL := TStringList.Create; - Source := TStringList.Create; - AForms := TStringList.Create; - try + forms_list_auto := AutoCreateForms; + while (forms_list_auto <> '') do + FormsToAutoCreate.Add(KOL.Parse(forms_list_auto, ';')); - ResStrings.Free; - ResStrings := nil; - - // First, generate .dpr - // TODO: dll in B.dpr of A.dproj start from MSBuild to 2009 - // TODO: may output inc files into old folders if MCK projects moved or KOLProject/KOLForm properties out of date - S := ExtractFilePath( Path ) + ProjectName + '.dpr'; - LoadSource( Source, S ); - if Source.Count = 0 then - begin - S := ExtractFilePath( Path ) + ExtractFileNameWOExt( Path ) + '.dpr'; - LoadSource( Source, S ); - end; - IsDLL := FALSE; - for I := 0 to Source.Count-1 do - begin - if pos( 'library', LowerCase( Source[ I ] ) ) > 0 then - begin - IsDLL := TRUE; - break; - end - else - if pos( 'program', LowerCase( Source[ I ] ) ) > 0 then - break; - end; - if Source.Count = 0 then - begin - Rpt( 'Could not get source from ' + S, WHITE ); - SL.Free; - Source.Free; - LogOK; - Exit; - end; - - BeforeGenerateDPR( SL, Updated ); - - Object2Run := nil; - A := 'nil'; - if Applet <> nil then // TODO: TKOLApplet must be on main form - begin // (to be always available for TKOLProject) - A := 'Applet'; - Object2Run := Applet; - end; - - SL.Clear; - - J := -1; - for I := 0 to Source.Count - 1 do - begin - if Source[ I ] = 'begin' then - begin - if J = -1 then J := I else J := -2; - end; - if Source[ I ] = BeginMark then - begin - J := I; break; - end; - end; - if J >= 0 then - Source[ J ] := BeginMark - else - begin - ShowMessage( 'Error while converting dpr: begin markup could not be found. ' + - 'Dpr-file of the project must either have a single line having only ' + - '''begin'' reserved word at the beginning or such line must be marked ' + - 'with special comment:'#13 + - BeginMark ); - LogOK; - Exit; - end; - RptDetailed( 'generate dpr -- A', WHITE ); - // copy lines from the first to 'begin', making - // some changes: - SL.Add( Signature ); // insert signature - S := ''; - I := -1; - Kol_added := FALSE; - DontChangeUses := FALSE; - while I < Source.Count - 1 do - begin - Inc( I ); - S := Source[ I ]; - - J := IndexOfStr(S, 'Vcl.'); - if J > 0 then - S := Copy(S, 1, J-1) + Copy(S, J+4, MaxInt); - - RptDetailed( 'generate dpr -- A1 - ' + IntToStr(I) + ': ' + S, WHITE ); - if RemoveSpaces( S ) = RemoveSpaces( Signature ) then continue; // skip signature if present - if LowerCase( Trim( S ) ) = LowerCase( 'program ' + ProjectName + ';' ) then - begin - SL.Add( 'program ' + ProjectDest + ';' ); - continue; - end; - if (LowerCase( Trim( S ) ) = LowerCase( 'library ' + ProjectName + ';' )) - then - begin - SL.Add( 'library ' + ProjectDest + ';' ); - continue; - end; - if S = BeginMark then - break; - RptDetailed( 'generate dpr -- A2', WHITE ); - if S = '//don''t change uses' then - DontChangeUses := TRUE; - if not DontChangeUses then - begin - RptDetailed( 'generate dpr -- A3', WHITE ); - if LowerCase( Trim( S ) ) = 'uses' then - begin - SL.Add( S ); - SL.Add( 'KOL,' ); - Kol_added := TRUE; - continue; + try + Rpt('Generating DPR for ' + Path, WHITE); //Rpt_Stack; + Result := False; + if FLocked then begin + Rpt('TKOLProject LOCKED.', RED); + LogOK; + Exit; end; - RptDetailed( 'generate dpr -- A4', WHITE ); - if Kol_added then - begin - J := IndexOfStr( S, 'KOL,' ); //pos( 'KOL,', S ); - if J > 0 then - begin - S := Copy( S, 1, J-1 ) + Copy( S, J+4, Length( S )-J-3 ); - if Trim( S ) = '' then continue; + + Updated := False; + SL := TStringList.Create; + Source := TStringList.Create; + AForms := TStringList.Create; + + try + ResStrings.free; + ResStrings := nil; + + // First, generate .dpr + // TODO: dll in B.dpr of AParent.dproj start from MSBuild to 2009 + // TODO: may output inc files into old folders if MCK projects moved or KOLProject/KOLForm properties out of date + s := ExtractFilePath(Path) + projectName + '.dpr'; + LoadSource(Source, s); + if (Source.Count = 0) then begin + s := ExtractFilePath(Path) + ExtractFileNameWOExt(Path) + '.dpr'; + LoadSource(Source, s); + end; + + if (Source.Count = 0) then begin + Rpt('Could not get source from ' + s, WHITE); + SL.free; + Source.free; + LogOK; + Exit; + end; + + IsDLL := False; + for I := 0 to Source.Count - 1 do begin + if Pos('library', LowerCase(Source[I])) > 0 then begin + IsDLL := True; + Break; + end else if Pos('program', LowerCase(Source[I])) > 0 then + Break; end; - end; - RptDetailed( 'generate dpr -- A5: <' + S + '>', WHITE ); - J := IndexOfStr( S, 'Forms,' ); // pos( 'Forms,', S ); - RptDetailed( 'generate dpr -- A5-a', WHITE ); - if J > 0 then // remove reference to Forms.pas - begin - S := Copy( S, 1, J-1 ) + Copy( S, J+6, Length( S )-J-5 ); - if Trim( S ) = '' then continue; - end; - end; - RptDetailed( 'generate dpr -- A6', WHITE ); - J := pos( '{$r *.res}', LowerCase( S ) ); - if J > 0 then // remove/insert reference to project resource file - if DprResource then - S := '{$R *.res}' - else - S := '//{$R *.res}'; - SL.Add( S ); - end; - RptDetailed( 'generate dpr -- B', WHITE ); - SL.Add( BeginMark ); - SL.Add( '' ); - if GlobalNewIf then // D[u]fa теперь форма видна сразу на версиях выше 7 - SL.Add( '{$IF Defined(KOL_MCK)} {$I ' + ProjectDest + '_0.inc} {$ELSE}' ) - else - SL.Add( '{$IFDEF KOL_MCK} {$I ' + ProjectDest + '_0.inc} {$ELSE}' ); - SL.Add( '' ); - // copy the rest of source dpr - between begin .. end. - // and store all autocreated forms in AForms string list - while I < Source.Count - 1 do - begin - Inc( I ); - S := Source[ I ]; - if Trim( S ) = '' then continue; + BeforeGenerateDPR(SL, Updated); - if GlobalNewIf then begin // D[u]fa теперь форма видна сразу на версиях выше 7 - if UpperCase( S ) = UpperCase( '{$IF Defined(KOL_MCK)} {$I ' + ProjectDest + '_0.INC} {$ELSE}' ) then - continue; - - if UpperCase( S ) = '{$IFEND}' then - continue; - end else begin - if UpperCase( S ) = UpperCase( '{$IFDEF KOL_MCK} {$I ' + ProjectDest + '_0.INC} {$ELSE}' ) then - continue; - - if UpperCase( S ) = '{$ENDIF}' then - continue; - end; + SL.Clear; - if LowerCase( S ) = 'end.' then - begin - SL.Add( '' ); - if GlobalNewIf then // D[u]fa теперь форма видна сразу на версиях выше 7 - SL.Add( '{$IFEND}' ) - else - SL.Add( '{$ENDIF}' ); - SL.Add( '' ); - end; - SL.Add( S ); - - J := pos( 'application.createform(', LowerCase( S ) ); - if J > 0 then - begin - S := Copy( S, J + 23, Length( S ) - J - 22 ); - J := pos( ',', S ); - if J > 0 then - S := Copy( S, J + 1, Length( S ) - J ); - J := pos( ')', S ); - if J > 0 then - S := Copy( S, 1, J - 1 ); - AForms.Add( Trim( S ) ); - end; - end; - RptDetailed( 'generate dpr -- C', WHITE ); - ReorderForms( Self, AForms ); - - Prepare_0inc; - Prepare_134inc; - Prepare_2inc; - - RptDetailed( 'generate dpr -- D', WHITE ); - if (ResStrings <> nil) and (ResStrings.Count > 0) then - begin - for I := 0 to SL.Count-1 do - begin - S := SL[ I ]; - if S = BeginResourceStringsMark then - begin - while S <> BeginMark do - begin - SL.Delete( I ); - if I >= SL.Count then - begin - Rpt( 'Error: begin mark not found', RED ); - break; + j := -1; + for I := 0 to Source.Count - 1 do begin + if (Source[I] = 'begin') then begin + if (j = -1) then + j := I + else + j := -2; + end; + if (Source[I] = BeginMark) then begin + j := I; + Break; + end; + end; + + if (j >= 0) then + Source[j] := BeginMark + else begin + Showmessage('Error while converting dpr: begin markup could not be found. ' + + 'Dpr-file of the project must either have a single line having only ' + + '''begin'' reserved word at the beginning or such line must be marked ' + + 'with special comment:'#13 + BeginMark); + LogOK; + Exit; + end; + + RptDetailed('generate dpr -- A', WHITE); + // copy lines from the first to 'begin', making + // some changes: + SL.Add(Signature); // insert signature + s := ''; + I := -1; + Kol_added := False; + DontChangeUses := False; + while I < Source.Count - 1 do begin + Inc(I); + s := Source[I]; + + j := IndexOfStr(s, 'Vcl.'); + if (j > 0) then + s := Copy(s, 1, j - 1) + Copy(s, j + 4, MaxInt); + + RptDetailed('generate dpr -- A1 - ' + IntToStr(I) + ': ' + s, WHITE); + if (RemoveSpaces(s) = RemoveSpaces(Signature)) then + Continue; // skip signature if present + if LowerCase(Trim(s)) = LowerCase('program ' + projectName + ';') then begin + SL.Add('program ' + projectDest + ';'); + Continue; + end; + if (LowerCase(Trim(s)) = LowerCase('library ' + projectName + ';')) then begin + SL.Add('library ' + projectDest + ';'); + Continue; + end; + if s = BeginMark then + Break; + RptDetailed('generate dpr -- A2', WHITE); + if s = '//don''t change uses' then + DontChangeUses := True; + if not DontChangeUses then begin + RptDetailed('generate dpr -- A3', WHITE); + if LowerCase(Trim(s)) = 'uses' then begin + SL.Add(s); + SL.Add('KOL,'); + Kol_added := True; + Continue; + end; + RptDetailed('generate dpr -- A4', WHITE); + if Kol_added then begin + j := IndexOfStr(s, 'KOL,'); //pos( 'KOL,', S ); + if j > 0 then begin + s := Copy(s, 1, j - 1) + Copy(s, j + 4, Length(s) - j - 3); + if Trim(s) = '' then + Continue; + end; + end; + RptDetailed('generate dpr -- A5: <' + s + '>', WHITE); + j := IndexOfStr(s, 'Forms,'); // pos( 'Forms,', S ); + RptDetailed('generate dpr -- A5-a', WHITE); + if j > 0 then {// remove reference to Forms.pas} begin + s := Copy(s, 1, j - 1) + Copy(s, j + 6, Length(s) - j - 5); + if Trim(s) = '' then + Continue; + end; + end; + RptDetailed('generate dpr -- A6', WHITE); + j := Pos('{$r *.res}', LowerCase(s)); + if j > 0 then // remove/insert reference to project resource file + if dprResource then + s := '{$R *.res}' + else + s := '//{$R *.res}'; + SL.Add(s); + end; + RptDetailed('generate dpr -- B', WHITE); + SL.Add(BeginMark); + SL.Add(''); + SL.Add('{$IF Defined(KOL_MCK)} {$I ' + projectDest + '_0.inc} {$ELSE}'); + SL.Add(''); + + // copy the rest of source dpr - between begin .. end. + // and store all autocreated forms in AForms string list + while (I < Source.Count - 1) do begin + Inc(I); + s := Source[I]; + if (Trim(s) = '') then + Continue; + + if (UpperCase(s) = UpperCase('{$IF Defined(KOL_MCK)} {$I ' + projectDest + '_0.INC} {$ELSE}')) then + Continue; + + if (UpperCase(s) = '{$IFEND}') then + Continue; + + if (LowerCase(s) = 'end.') then begin + SL.Add(''); + SL.Add('{$IFEND}'); + SL.Add(''); + end; + SL.Add(s); + + j := Pos('application.createform(', LowerCase(s)); + if (j > 0) then begin + s := Copy(s, j + 23, Length(s) - j - 22); + j := Pos(',', s); + if j > 0 then + s := Copy(s, j + 1, Length(s) - j); + j := Pos(')', s); + if j > 0 then + s := Copy(s, 1, j - 1); + AForms.Add(Trim(s)); + end; + end; + RptDetailed('generate dpr -- C', WHITE); + ReorderForms(Self, AForms); + + Prepare_0inc(Path, IsDLL, AForms, AParent, Updated); + Prepare_134inc(Path, Updated); + Prepare_2inc(Path, IsDLL, AForms, AParent, Updated, FormsToAutoCreate); + + RptDetailed('generate dpr -- D', WHITE); + if (ResStrings <> nil) and (ResStrings.Count > 0) then begin + for I := 0 to SL.Count - 1 do begin + s := SL[I]; + if s = BeginResourceStringsMark then begin + while s <> BeginMark do begin + SL.Delete(I); + if I >= SL.Count then begin + Rpt('Error: begin mark not found', RED); + Break; + end; + s := SL[I]; + end; + end; + if s = BeginMark then begin + SL.Insert(I, BeginResourceStringsMark); + for j := ResStrings.Count - 1 downto 0 do + SL.Insert(I + 1, ResStrings[j]); + //Updated := TRUE; + Break; + end; + end; + end; + + RptDetailed('generate dpr -- E', WHITE); + AfterGenerateDPR(SL, Updated); + // store SL as .dpr + SaveStrings(SL, Path + '.dpr', Updated); + + // at last, generate code for all (opened in designer) forms + + if (FormsList <> nil) then begin + for I := 0 to FormsList.Count - 1 do begin + F := FormsList[I]; + F.GenerateUnit(ExtractFilePath(Path) + F.formUnit); + end; + end; + + RptDetailed('generate dpr -- F', WHITE); + if Updated then begin + // mark modified here + MarkModified(Path + '.dpr'); + MarkModified(Path + '_1.inc'); + MarkModified(Path + '_2.inc'); + MarkModified(Path + '_3.inc'); + end; + + RptDetailed('generate dpr -- G', WHITE); + Result := True; + + except + on E: Exception do begin + SL := TStringList.Create; + try + SL := GetCallStack; + Showmessage('Exception 11873: ' + E.Message + #13#10 + SL.Text); + finally + SL.free; end; - S := SL[ I ]; end; end; - if S = BeginMark then - begin - SL.Insert( I, BeginResourceStringsMark ); - for J := ResStrings.Count-1 downto 0 do - SL.Insert( I + 1, ResStrings[ J ] ); - //Updated := TRUE; - break; - end; + + SL.free; + Source.free; + AForms.free; + + LogOK; + finally + RptDetailed('ENDOF Generating dpr', LIGHT + BLUE); + Log('<-TKOLProject.GenerateDPR'); end; + finally + FormsToAutoCreate.free; end; - - RptDetailed( 'generate dpr -- E', WHITE ); - AfterGenerateDPR( SL, Updated ); - // store SL as .dpr - SaveStrings( SL, Path + '.dpr', Updated ); - - - // at last, generate code for all (opened in designer) forms - - if FormsList <> nil then - for I := 0 to FormsList.Count - 1 do - begin - F := FormsList[ I ]; - F.GenerateUnit( ExtractFilePath( Path ) + F.FormUnit ); - end; - - RptDetailed( 'generate dpr -- F', WHITE ); - if Updated then - begin - // mark modified here - MarkModified( Path + '.dpr' ); - MarkModified( Path + '_1.inc' ); - MarkModified( Path + '_2.inc' ); - MarkModified( Path + '_3.inc' ); - end; - - RptDetailed( 'generate dpr -- G', WHITE ); - Result := True; - - except on E: Exception do - begin - SL := TStringList.Create; - TRY - SL := GetCallStack; - ShowMessage( 'Exception 11873: ' + E.Message + #13#10 + SL.Text ); - FINALLY - SL.Free; - END; - end; - end; - - SL.Free; - Source.Free; - AForms.Free; - - LogOK; - FINALLY - RptDetailed( 'ENDOF Generating dpr', LIGHT + BLUE ); - Log( '<-TKOLProject.GenerateDPR' ); - END; - FINALLY - FormsToAutoCreate.Free; - END; end; function TKOLProject.GetBuild: Boolean; @@ -19599,8 +15562,9 @@ begin end; function TKOLProject.GetIsKOLProject: Boolean; -var SL: TStringList; - I: Integer; +var + SL: TStringList; + I: Integer; begin asm jmp @@e_signature @@ -19608,58 +15572,49 @@ begin DB 'TKOLProject.GetIsKOLProject', 0 @@e_signature: end; - Log( '->GetIsKOLProject' ); - TRY + Log('->GetIsKOLProject'); + try - Result := FALSE; - if not FLocked then - begin - if fIsKOL = 0 then - begin - //ShowMessage( 'find if project Is KOL...: SourcePath=' + SourcePath + - // ' ProjectName:' + ProjectName); - if (SourcePath <> '') and DirectoryExists( SourcePath ) then - begin + Result := False; + if not FLocked then begin + if fIsKOL = 0 then begin + //ShowMessage( 'find if project Is KOL...: SourcePath=' + SourcePath + + // ' ProjectName:' + ProjectName); + if (sourcePath <> '') and DirectoryExists(sourcePath) then begin //ShowMessage('SourcePath=' + SourcePath + ' ProjectName=' + ProjectName); - if (ProjectName <> '') and FileExists( SourcePath + ProjectName + '.dpr' ) then - begin + if (projectName <> '') and FileExists(sourcePath + projectName + '.dpr') then begin //ShowMessage( 'find if project Is KOL in ' + SourcePath + ProjectName + '.dpr' ); SL := TStringList.Create; try - LoadSource( SL, SourcePath + ProjectName + '.dpr' ); + LoadSource(SL, sourcePath + projectName + '.dpr'); for I := 0 to SL.Count - 1 do - if KOL.RemoveSpaces( SL[ I ] ) = KOL.RemoveSpaces( Signature ) then - begin + if KOL.RemoveSpaces(SL[I]) = KOL.RemoveSpaces(Signature) then begin fIsKOL := 1; - break; + Break; end; //if fIsKOL = 0 then // fIsKOL := -1; finally - SL.Free; + SL.free; end; //ShowMessage( IntToStr( fIsKOL ) ); end; + end; end; + Result := fIsKOL > 0; end; - Result := fIsKOL > 0; + + LogOK; + finally + Log('<-GetIsKOLProject'); end; - - LogOK; - FINALLY - Log( '<-GetIsKOLProject' ); - END; -end; - -function TKOLProject.getNewIf: Boolean; -begin - Result := FNewIF; end; function TKOLProject.GetOutdcuPath: TFileName; -var S: String; - L: TStringList; - I: Integer; +var + s: string; + L: TStringList; + I: Integer; begin asm jmp @@e_signature @@ -19667,50 +15622,47 @@ begin DB 'TKOLProject.GetOutdcuPath', 0 @@e_signature: end; - Log( '->TKOLProject.GetOutdcuPath' ); - TRY + Log('->TKOLProject.GetOutdcuPath'); + try - Result := ''; - if not FLocked then - begin - Result := SourcePath; - S := SourcePath + ProjectName + '.cfg'; - if FileExists( S ) then - begin - L := TStringList.Create; - L.LoadFromFile( S ); - for I := 0 to L.Count - 1 do - begin - if Length( L[ I ] ) < 2 then continue; - if L[ I ][ 2 ] = 'N' then - begin - S := Trim( Copy( L[ I ], 3, Length( L[ I ] ) - 2 ) ); - if S[ 1 ] = '"' then - S := Copy( S, 2, Length( S ) - 1 ); - if S[ Length( S ) ] = '"' then - S := Copy( S, 1, Length( S ) - 1 ); - Result := S; - break; + Result := ''; + if not FLocked then begin + Result := sourcePath; + s := sourcePath + projectName + '.cfg'; + if FileExists(s) then begin + L := TStringList.Create; + L.LoadFromFile(s); + for I := 0 to L.Count - 1 do begin + if Length(L[I]) < 2 then + Continue; + if L[I][2] = 'N' then begin + s := Trim(Copy(L[I], 3, Length(L[I]) - 2)); + if s[1] = '"' then + s := Copy(s, 2, Length(s) - 1); + if s[Length(s)] = '"' then + s := Copy(s, 1, Length(s) - 1); + Result := s; + Break; + end; end; + L.free; end; - L.Free; + + if Result = '' then + Result := fOutdcuPath; + if Result <> '' then + if Result[Length(Result)] <> '\' then + Result := Result + '\'; + fOutdcuPath := Result; end; - if Result = '' then - Result := fOutdcuPath; - if Result <> '' then - if Result[ Length( Result ) ] <> '\' then - Result := Result + '\'; - fOutdcuPath := Result; + LogOK; + finally + Log('<-TKOLProject.GetOutdcuPath'); end; - - LogOK; - FINALLY - Log( '<-TKOLProject.GetOutdcuPath' ); - END; end; -function TKOLProject.GetProjectDest: String; +function TKOLProject.GetProjectDest: string; begin asm jmp @@e_signature @@ -19718,30 +15670,28 @@ begin DB 'TKOLProject.GetProjectDest', 0 @@e_signature: end; - Log( '->TKOLProject.GetProjectDest' ); - TRY + Log('->TKOLProject.GetProjectDest'); + try - Result := ''; - if not FLocked then - begin - //Result := ProjectName; - if IsKOLProject then - Result := ProjectName - else - begin - Result := FProjectDest; - if (ProjectName <> '') and (LowerCase(Result) = LowerCase(ProjectName)) then - Result := ''; + Result := ''; + if not FLocked then begin + //Result := ProjectName; + if isKOLProject then + Result := projectName + else begin + Result := FProjectDest; + if (projectName <> '') and (LowerCase(Result) = LowerCase(projectName)) then + Result := ''; + end; end; - end; - LogOK; - FINALLY - Log( '<-TKOLProject.GetProjectDest' ); - END; + LogOK; + finally + Log('<-TKOLProject.GetProjectDest'); + end; end; -function TKOLProject.GetProjectName: String; +function TKOLProject.GetProjectName: string; var I: Integer; {$IFDEF _D2005orHigher} @@ -19754,12 +15704,11 @@ begin DB 'TKOLProject.GetProjectName', 0 @@e_signature: end; - Log( '->TKOLProject.GetProjectName' ); - TRY + Log('->TKOLProject.GetProjectName'); + try Result := fProjectName; - if csDesigning in ComponentState then - begin + if csDesigning in ComponentState then begin (*Result := Get_ProjectName(False); if Length(Result) > 0 then begin @@ -19767,64 +15716,58 @@ begin Exit; end;*) // TODO: It's maybe an goodiear to use Get_ProjectName instead (with DontGetFromKOLProject option)? - Log('1'); - if ToolServices <> nil then - begin - Result := ExtractFileNameWOExt( ToolServices.GetProjectName ); + if ToolServices <> nil then begin + Result := ExtractFileNameWOExt(ToolServices.GetProjectName); Log('Result ' + Result); LogOK; - exit; - end; - // TODO: use new OTAPI instead workaroud - // TODO: fix AAA_D12.dproj copy from AAA.dproj that link to AAA.dpr (only AAA.dll affect) - {$IFDEF _D2005orHigher} - Log('2'); - try - IProjectGroup := Get_ProjectGroup; - if Assigned(IProjectGroup) then - begin - Result := ExtractFileNameWOExt( IProjectGroup.ActiveProject.ProjectOptions.TargetName ); - // More Effective than dproj name by ActiveProject.GetFilename - Log('Result ' + Result); - LogOK; Exit; end; + // TODO: use new OTAPI instead workaroud + // TODO: fix AAA_D12.dproj copy from AAA.dproj that link to AAA.dpr (only AAA.dll affect) +{$IFDEF _D2005orHigher} + Log('2'); + try + IProjectGroup := Get_ProjectGroup; + if Assigned(IProjectGroup) then begin + Result := ExtractFileNameWOExt(IProjectGroup.ActiveProject.ProjectOptions.TargetName); + // More Effective than dproj name by ActiveProject.GetFilename + Log('Result ' + Result); + LogOK; + Exit; + end; except end; - {$ENDIF} - +{$ENDIF} Log('3'); Result := Application.MainForm.Caption; - if Length(Result) <> 0 then - begin - I := pos( '-', Result ); - /// D[u]fa + if Length(Result) <> 0 then begin + I := Pos('-', Result); + /// dufa /// вот тут загвоздка такая что вместо имени юнита /// попадает чушь типа "Codegear Delphi for win32......" /// для совместимости ставлю директиву начиная c 2005 делфи /// хотя проверял только на 2007 и Турбе! /// конечно лучше заменить на универсальный метод if (I > 0) then - {$IFDEF _D2005orHigher} // VK: это наверное так только в новых версиях +{$IFDEF _D2005orHigher} // VK: это наверное так только в новых версиях SetLength(Result, Pos(' ', Result) - 1); - {$ELSE} - Result := Trim( Copy( Result, I + 1, Length( Result ) - I ) ); - {$ENDIF} +{$ELSE} + Result := Trim(Copy(Result, I + 1, Length(Result) - I)); +{$ENDIF} //rpt('Len'+Result, YELLOW); - if pos( '[', Result ) > 0 then - Result := Trim( Copy( Result, 1, pos( '[', Result ) - 1 ) ); - if pos( '(', Result ) > 0 then - Result := Trim( Copy( Result, 1, pos( '(', Result ) - 1 ) ); + if (Pos('[', Result) > 0) then + Result := Trim(Copy(Result, 1, Pos('[', Result) - 1)); + if (Pos('(', Result) > 0) then + Result := Trim(Copy(Result, 1, Pos('(', Result) - 1)); end; end; Log('4'); - Log('Result ' + Result); LogOK; - FINALLY - Log( '<-TKOLProject.GetProjectName' ) - END; + finally + Log('<-TKOLProject.GetProjectName') + end; end; function TKOLProject.GetShowReport: Boolean; @@ -19836,21 +15779,22 @@ begin @@e_signature: end; //Log( '->TKOLProject.GetShowReport' ); - TRY + try - Result := fShowReport; - if AutoBuilding then - Result := False; + Result := fShowReport; + if AutoBuilding then + Result := False; - LogOK; - FINALLY + LogOK; + finally //Log( '<-TKOLProject.GetShowReport' ); - END; + end; end; // From D3, Get Interface for bpg n groupproj // like Get_ProjectName? {$IFDEF _D2005orHigher} + function Get_ProjectGroup: IOTAProjectGroup; var IModuleServices: IOTAModuleServices; @@ -19860,9 +15804,8 @@ begin // from Mike Shkolnik's post IModuleServices := BorlandIDEServices as IOTAModuleServices; Result := nil; - for i := 0 to IModuleServices.ModuleCount - 1 do - begin - IModule := IModuleServices.Modules[i]; + for I := 0 to IModuleServices.ModuleCount - 1 do begin + IModule := IModuleServices.Modules[I]; if IModule.QueryInterface(IOTAProjectGroup, Result) = S_OK then Break; end; @@ -19873,9 +15816,9 @@ function TKOLProject.GetSourcePath: TFileName; var BI: TBrowseInfo; IIL: PItemIdList; - Buf: Array[ 0..MAX_PATH ] of Char; // TODO: dangerous, if D2 have treat Char as D2009? + Buf: array[0..MAX_PATH] of Char; // TODO: dangerous, if D2 have treat Char as D2009? SL: TStringList; - s: String; + s: string; {$IFDEF _D2005orHigher} IProjectGroup: IOTAProjectGroup; {$ENDIF} @@ -19886,147 +15829,135 @@ begin DB 'TKOLProject.GetSourcePath', 0 @@e_signature: end; - Log( '->TKOLProject.GetSourcePath' ); - TRY + Log('->TKOLProject.GetSourcePath'); + try - Result := ''; - TRY - if FLocked then - begin - Rpt( 'TKOLProject LOCKED.', RED ); - LogOK; Exit; - end; - Result := fSourcePath; - if Result <> '' then - if Result[ Length( Result ) ] <> '\' then - Result := Result + '\'; - if (Result <> '') and DirectoryExists( Result ) {and (FprojectDest <> '') and - FileExists( Result + FprojectDest + '.dpr' )} then - begin - LogOK; Exit; - end; - if fGettingSourcePath then - begin - LogOK; Exit; - end; - fGettingSourcePath := True; - TRY - try - if Result <> '' then - if Result[ Length( Result ) ] <> '\' then + Result := ''; + try + if FLocked then begin + Rpt('TKOLProject LOCKED.', RED); + LogOK; + Exit; + end; + Result := fSourcePath; + if Result <> '' then + if Result[Length(Result)] <> '\' then Result := Result + '\'; - if Result <> '' then - if not DirectoryExists( Result ) or - not FileExists( Result + fprojectDest + '.dpr' ) or - not IsKOLProject then - Result := ''; - if Result = '' then - if csDesigning in ComponentState then - //if not (csLoading in ComponentState) then - begin - try - if ToolServices <> nil then - begin - Result := ToolServices.GetProjectName; // AAA.dpr - Result := ExtractFilePath( Result ); - end - {$IFDEF _D2005orHigher} - else - begin - IProjectGroup := Get_ProjectGroup(); - if Assigned(IProjectGroup) then - begin - // TODO: check if current project is not active(startup) Project - //Result := IProjectGroup.ActiveProject.GetFileName; // AAA_D12.dproj - Result := IProjectGroup.ActiveProject.ProjectOptions.TargetName; // ProjPath(output folder discard)AAA.exe (AAA_D12.dll havn't fix by CodeGear) - //Result := IProjectGroup.GetFileName;} // Tests.bdsgroup - Result := ExtractFilePath( Result ); + if (Result <> '') and DirectoryExists(Result) {and (FprojectDest <> '') and + FileExists( Result + FprojectDest + '.dpr' )}then begin + LogOK; + Exit; + end; + if fGettingSourcePath then begin + LogOK; + Exit; + end; + fGettingSourcePath := True; + try + try + if Result <> '' then + if Result[Length(Result)] <> '\' then + Result := Result + '\'; + if Result <> '' then + if not DirectoryExists(Result) or + not FileExists(Result + FProjectDest + '.dpr') or + not isKOLProject then + Result := ''; + if Result = '' then + if csDesigning in ComponentState then + {//if not (csLoading in ComponentState) then} begin + try + if ToolServices <> nil then begin + Result := ToolServices.GetProjectName; // AAA.dpr + Result := ExtractFilePath(Result); + end +{$IFDEF _D2005orHigher} + else begin + IProjectGroup := Get_ProjectGroup(); + if Assigned(IProjectGroup) then begin + // TODO: check if current project is not active(startup) Project + //Result := IProjectGroup.ActiveProject.GetFileName; // AAA_D12.dproj + Result := IProjectGroup.ActiveProject.ProjectOptions.TargetName; // ProjPath(output folder discard)AAA.exe (AAA_D12.dll havn't fix by CodeGear) + //Result := IProjectGroup.GetFileName;} // Tests.bdsgroup + Result := ExtractFilePath(Result); + end; + end; +{$ENDIF} + except on E: Exception do begin + SL := TStringList.Create; + try + SL := GetCallStack; + Showmessage('Exception 12108: ' + E.Message + #13#10 + SL.Text); + finally + SL.free; + end; + end; + end; + + if Result <> '' then begin + if Result[Length(Result)] <> '\' then + Result := Result + '\'; + fGettingSourcePath := False; + LogOK; + Exit; + end; + + FillChar(BI, Sizeof(BI), 0); // byte behavor havn't change in D2009 + BI.lpszTitle := 'Define mirror project source (directory ' + + 'where your source project is located before ' + + 'converting it to KOL).'; + BI.ulFlags := BIF_RETURNONLYFSDIRS; + BI.pszDisplayName := @Buf[0]; + IIL := SHBrowseForFolder(BI); + if IIL <> nil then begin + SHGetPathFromIDList(IIL, @Buf[0]); + CoTaskMemFree(IIL); + Result := string(Buf); + fSourcePath := Result; end; end; - {$ENDIF} - except on E: Exception do - begin - SL := TStringList.Create; - TRY - SL := GetCallStack; - ShowMessage( 'Exception 12108: ' + E.Message + #13#10 + SL.Text ); - FINALLY - SL.Free; - END; - end; - end; - if Result <> '' then - begin - if Result[ Length( Result ) ] <> '\' then + if Result[Length(Result)] <> '\' then Result := Result + '\'; - fGettingSourcePath := False; - LogOK; - Exit; - end; - - FillChar( BI, Sizeof( BI ), 0 ); // byte behavor havn't change in D2009 - BI.lpszTitle := 'Define mirror project source (directory ' + - 'where your source project is located before '+ - 'converting it to KOL).'; - BI.ulFlags := BIF_RETURNONLYFSDIRS; - BI.pszDisplayName := @Buf[ 0 ]; - IIL := SHBrowseForFolder( BI ); - if IIL <> nil then - begin - SHGetPathFromIDList( IIL, @Buf[ 0 ] ); - CoTaskMemFree( IIL ); - Result := String(Buf); - fSourcePath := Result; + except on E: Exception do begin + SL := TStringList.Create; + try + SL := GetCallStack; + Showmessage('Exception 12146: ' + E.Message + #13#10 + SL.Text); + finally + SL.free; + end; end; end; - if Result <> '' then - if Result[ Length( Result ) ] <> '\' then - Result := Result + '\'; - except on E: Exception do - begin - SL := TStringList.Create; - TRY - SL := GetCallStack; - ShowMessage( 'Exception 12146: ' + E.Message + #13#10 + SL.Text ); - FINALLY - SL.Free; - END; - end; + finally + fGettingSourcePath := False; + end; + except + on E: Exception do begin + Showmessage('Can not obtain project source path, exception: ' + E.Message); + Result := ''; end; - FINALLY - fGettingSourcePath := False; - END; - EXCEPT - on E: Exception do - begin - ShowMessage( 'Can not obtain project source path, exception: ' + E.Message ); - Result := ''; end; - END; - LogOK; - FINALLY - //ShowMessage('GetSourcePath==>' + Result); - if ExtractFileName(ExcludeTrailingPathDelimiter(Result)) = 'Debug' then - begin - s := ExtractFilePath(ExcludeTrailingPathDelimiter(Result)); - //ShowMessage('Yes, Debug; s=' + s); - if ExtractFileName(ExcludeTrailingPathDelimiter(s)) = 'Win32' then - begin - s := ExtractFilePath(ExcludeTrailingPathDelimiter(s)); - //ShowMessage('Yes, Win32; s=' + s); - //s := ExtractFilePath(ExcludeTrailingPathDelimiter(s)); - // XE2, XE отбрасывать не надо, как раз там и лежит проект - if DirectoryExists(s) then - begin - Result := s; - //ShowMessage('Result==>' + s); - end; - end; + LogOK; + finally + //ShowMessage('GetSourcePath==>' + Result); + if ExtractFileName(ExcludeTrailingPathDelimiter(Result)) = 'Debug' then begin + s := ExtractFilePath(ExcludeTrailingPathDelimiter(Result)); + //ShowMessage('Yes, Debug; s=' + s); + if ExtractFileName(ExcludeTrailingPathDelimiter(s)) = 'Win32' then begin + s := ExtractFilePath(ExcludeTrailingPathDelimiter(s)); + //ShowMessage('Yes, Win32; s=' + s); + //s := ExtractFilePath(ExcludeTrailingPathDelimiter(s)); + // XE2, XE отбрасывать не надо, как раз там и лежит проект + if DirectoryExists(s) then begin + Result := s; + //ShowMessage('Result==>' + s); + end; end; - Log( '<-TKOLProject.GetSourcePath' ); - END; + end; + Log('<-TKOLProject.GetSourcePath'); + end; end; procedure TKOLProject.Loaded; @@ -20037,37 +15968,38 @@ begin DB 'TKOLProject.Loaded', 0 @@e_signature: end; - Log( '->TKOLProject.Loaded' ); - TRY + Log('->TKOLProject.Loaded'); + try inherited; //fTimer.Enabled := TRUE; BroadCastPaintTypeToAllForms; - LogOK; - FINALLY - Log( '<-TKOLProject.Loaded' ); - END; + LogOK; + finally + Log('<-TKOLProject.Loaded'); + end; end; procedure TKOLProject.MakeResourceString(const ResourceConstName, - Value: String); + Value: string); begin - Log( '->TKOLProject.MakeResourceString' ); - TRY + Log('->TKOLProject.MakeResourceString'); + try - if ResStrings = nil then - ResStrings := TStringList.Create; - ResStrings.Add( 'resourcestring ' + ResourceConstName + ' = ' + - String2Pascal( Value, '+' ) + ';' ); + if ResStrings = nil then + ResStrings := TStringList.Create; + ResStrings.Add('resourcestring ' + ResourceConstName + ' = ' + + String2Pascal(Value, '+') + ';'); - LogOK; - FINALLY - Log( '<-TKOLProject.MakeResourceString' ); - END; + LogOK; + finally + Log('<-TKOLProject.MakeResourceString'); + end; end; function TKOLProject.OwnerKOLForm: TKOLForm; -var C, D: TComponent; - I: Integer; +var + c, D: TComponent; + I: Integer; begin asm jmp @@e_signature @@ -20075,61 +16007,32 @@ begin DB 'TKOLProject.ParentKOLForm', 0 @@e_signature: end; - C := Owner; - while (C <> nil) and not(C is TForm) do - C := C.Owner; + c := Owner; + while (c <> nil) and not (c is TForm) do + c := c.Owner; Result := nil; - if C <> nil then - if C is TForm then - begin - for I := 0 to (C as TForm).ComponentCount - 1 do - begin - D := (C as TForm).Components[ I ]; - if D is TKOLForm then - begin - Result := D as TKOLForm; - break; + if c <> nil then + if c is TForm then begin + for I := 0 to (c as TForm).ComponentCount - 1 do begin + D := (c as TForm).Components[I]; + if D is TKOLForm then begin + Result := D as TKOLForm; + Break; + end; end; end; - end; end; -function TKOLProject.P_StringConstant(const Propname, - Value: String): String; -begin - Log( '->TKOLProject.P_StringConstant' ); - TRY +var + LastColor: Integer = 0; - if Localizy and (Value <> '') then - begin - //Result := Name + '_' + Propname; - {P}Result := ' ResourceString(' + Name + '_' + PropName + ')'; - //todo: implement ResourceString in P-machine! - MakeResourceString( Result, Value ); - end - else - begin - //Result := String2Pascal( Value ); - if Value <> '' then - {P}Result := ' LoadAnsiStr ' + P_String2Pascal( Value ) - else - {P}Result := ' LoadAnsiStr #0'; - end; - - LogOK; - FINALLY - Log( '<-TKOLProject.P_StringConstant' ); - END; -end; - -var LastColor: Integer = 0; - -procedure TKOLProject.Report(const Txt: String; Color: Integer ); -var w: DWORD; - {$IFDEF REPORT_TIME} - s: String; - {$ENDIF} - tmp: String; +procedure TKOLProject.Report(const Txt: string; Color: Integer); +var + W: DWORD; +{$IFDEF REPORT_TIME} + s: string; +{$ENDIF} + Tmp: string; begin asm jmp @@e_signature @@ -20138,29 +16041,27 @@ begin @@e_signature: end; //if FLocked then Exit; - if FConsoleOut and (FOut <> 0) then - begin + if FConsoleOut and (FOut <> 0) then begin //Writeln( FOut, Txt ); //Write( FOut, Txt + #10 ); - {$IFDEF REPORT_TIME} - TRY - SetConsoleTextAttribute( FOut, CYAN ); - s := FormatDateTime( 'hh:nn:ss:zzz ', Now ); - WriteConsole( FOut, PAnsiChar( s ), Length( s ), w, nil ); - EXCEPT - END; - {$ELSE} +{$IFDEF REPORT_TIME} + try + SetConsoleTextAttribute(FOut, CYAN); + s := FormatDateTime('hh:nn:ss:zzz ', Now); + WriteConsole(FOut, PAnsiChar(s), Length(s), W, nil); + except + end; +{$ELSE} if LastColor <> Color then - {$ENDIF} - begin - SetConsoleTextAttribute( FOut, Color ); +{$ENDIF}begin + SetConsoleTextAttribute(FOut, Color); LastColor := Color; end; - tmp := Txt + #10; - WriteConsole( FOut, PChar(tmp), Length( Txt ) + 1, w, nil ); + Tmp := Txt + #10; + WriteConsole(FOut, PChar(Tmp), Length(Txt) + 1, W, nil); end; - if ShowReport and Building then - ShowMessage( Txt ); + if showReport and Building then + Showmessage(Txt); end; procedure TKOLProject.SetAutoBuild(const Value: Boolean); @@ -20171,35 +16072,31 @@ begin DB 'TKOLProject.SetAutoBuild', 0 @@e_signature: end; - Log( '->TKOLProject.SetAutoBuild' ); - TRY + Log('->TKOLProject.SetAutoBuild'); + try - if not FLocked then - begin - if fAutoBuild <> Value then - begin - fAutoBuild := Value; - if Value then - begin - // Setup timer - if fTimer = nil then - fTimer := TTimer.Create( Self ); - fTimer.Interval := FAutoBuildDelay; - fTimer.OnTimer := TimerTick; - end - else - begin - // Stop timer - if fTimer <> nil then - fTimer.Enabled := False; + if not FLocked then begin + if fAutoBuild <> Value then begin + fAutoBuild := Value; + if Value then begin + // Setup timer + if fTimer = nil then + fTimer := TTimer.Create(Self); + fTimer.Interval := FAutoBuildDelay; + fTimer.OnTimer := TimerTick; + end + else begin + // Stop timer + if fTimer <> nil then + fTimer.Enabled := False; + end; end; end; - end; - LogOK; - FINALLY - Log( '<-TKOLProject.SetAutoBuild' ); - END; + LogOK; + finally + Log('<-TKOLProject.SetAutoBuild'); + end; end; procedure TKOLProject.SetAutoBuildDelay(const Value: Integer); @@ -20210,40 +16107,40 @@ begin DB 'TKOLProject.SetAutoBuildDelay', 0 @@e_signature: end; - Log( '->TKOLProject.SetAutoBuildDelay' ); - TRY + Log('->TKOLProject.SetAutoBuildDelay'); + try - if not FLocked then - begin - FAutoBuildDelay := Value; - if fAutoBuildDelay < 0 then - fAutoBuildDelay := 0; - if AutoBuildDelay > 3000 then - fAutoBuildDelay := 3000; - if fTimer <> nil then - if fAutoBuildDelay > 50 then - fTimer.Interval := Value - else - fTimer.Interval := 50; + if not FLocked then begin + FAutoBuildDelay := Value; + if FAutoBuildDelay < 0 then + FAutoBuildDelay := 0; + if autoBuildDelay > 3000 then + FAutoBuildDelay := 3000; + if fTimer <> nil then + if FAutoBuildDelay > 50 then + fTimer.Interval := Value + else + fTimer.Interval := 50; + end; + LogOK; + finally + Log('<-TKOLProject.SetAutoBuildDelay'); end; - LogOK; - FINALLY - Log( '<-TKOLProject.SetAutoBuildDelay' ); - END; end; -procedure TKOLProject.SetAutoCreateForms(const Value: String); +procedure TKOLProject.SetAutoCreateForms(const Value: string); begin - if FAutoCreateForms = Value then - Exit; - FAutoCreateForms := Value; - if not (csLoading in ComponentState) then - - ConvertVCL2KOL(false, true); + if FAutoCreateForms = Value then + Exit; + FAutoCreateForms := Value; + if not (csLoading in ComponentState) then + + ConvertVCL2KOL(False, True); end; procedure TKOLProject.SetBuild(const Value: Boolean); -var S: String; +var + s: string; begin asm jmp @@e_signature @@ -20251,60 +16148,50 @@ begin DB 'TKOLProject.SetBuild', 0 @@e_signature: end; - Log( '->TKOLProject.SetBuild' ); - TRY + Log('->TKOLProject.SetBuild'); + try - if not (csLoading in ComponentState) and not FLocked then - begin - if not IsKOLProject then - begin - S := 'Option is not available at design time ' + - 'unless project is already converted to KOL-MCK.'; - if projectDest = '' then - S := S + #13#10'To convert a project to KOL-MCK, change property ' + - 'projectDest of TKOLProject component!'; - ShowMessage( S ); - LogOK; - Exit; - end; - if Value = False then - begin - LogOK; - Exit; - end; - fBuild := TRUE; - try - if not ConvertVCL2KOL( TRUE, FALSE ) then - if (OwnerKOLForm <> nil) then - OwnerKOLForm.Change( OwnerKOLForm ); - except - on E: Exception do - begin - ShowMessage( 'ConvertVCL2KOL failed, exception: ' + E.Message ); + if not (csLoading in ComponentState) and not FLocked then begin + if not isKOLProject then begin + s := 'Option is not available at design time ' + + 'unless project is already converted to KOL-MCK.'; + if projectDest = '' then + s := s + #13#10'To convert a project to KOL-MCK, change property ' + + 'projectDest of TKOLProject component!'; + Showmessage(s); + LogOK; + Exit; end; + if Value = False then begin + LogOK; + Exit; + end; + fBuild := True; + try + if not ConvertVCL2KOL(True, False) then + if (OwnerKOLForm <> nil) then + OwnerKOLForm.Change(OwnerKOLForm); + except + on E: Exception do begin + Showmessage('ConvertVCL2KOL failed, exception: ' + E.Message); + end; + end; + fBuild := False; end; - fBuild := False; + + LogOK; + finally + Log('<-TKOLProject.SetBuild'); end; - - LogOK; - FINALLY - Log( '<-TKOLProject.SetBuild' ); - END; end; -procedure TKOLProject.SetCallPCompiler(const Value: String); +function ConsoleHandler(dwCtrlType: DWORD): BOOL; stdcall; begin - FCallPCompiler := Value; -end; - -function ConsoleHandler( dwCtrlType: DWORD ): Bool; stdcall; -begin - Result := FALSE; - if dwCtrlType = CTRL_CLOSE_EVENT then - begin - Result := TRUE; - Rpt( 'Do not close console window, instead change property consoleOut of ' + - 'TKOLProject component to FALSE!', YELLOW ); + Result := False; + if dwCtrlType = CTRL_CLOSE_EVENT then begin + Result := True; + Rpt('Do not close console window, instead change property consoleOut of ' + + 'TKOLProject component to FALSE!', YELLOW); end; end; @@ -20316,56 +16203,48 @@ begin DB 'TKOLProject.SetConsoleOut', 0 @@e_signature: end; - Log( '->TKOLProject.SetConsoloeOut' ); - TRY + Log('->TKOLProject.SetConsoloeOut'); + try - if not FLocked and (FConsoleOut <> Value) then - begin - FConsoleOut := Value; - if Value then - begin - AllocConsole; - FOut := GetStdHandle( STD_OUTPUT_HANDLE ); - if FOut <> 0 then - begin - FIn := GetStdHandle( STD_INPUT_HANDLE ); - SetConsoleTitle( 'KOL MCK console. Do not close! (use prop. ConsoleOut)' ); - SetConsoleMode( FIn, ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT ); - SetConsoleCtrlHandler( @ ConsoleHandler, TRUE ); + if not FLocked and (FConsoleOut <> Value) then begin + FConsoleOut := Value; + if Value then begin + AllocConsole; + FOut := GetStdHandle(STD_OUTPUT_HANDLE); + if FOut <> 0 then begin + FIn := GetStdHandle(STD_INPUT_HANDLE); + SetConsoleTitle('KOL MCK console. Do not close! (use prop. ConsoleOut)'); + SetConsoleMode(FIn, ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT); + SetConsoleCtrlHandler(@ConsoleHandler, True); + end + else + FConsoleOut := False; end - else FConsoleOut := False; - end - else - FreeConsole; + else + FreeConsole; + end; + + LogOK; + finally + Log('<-TKOLProject.SetConsoleOut'); end; - - LogOK; - FINALLY - Log( '<-TKOLProject.SetConsoleOut' ); - END; end; -procedure TKOLProject.SetGeneratePCode(const Value: Boolean); +procedure TKOLProject.SetHelpFile(const Value: string); begin - FGeneratePCode := Value; - Change; - ChangeAllForms; -end; + if FHelpFile = Value then + Exit; + Log('->TKOLProject.SetHelpFile'); + try -procedure TKOLProject.SetHelpFile(const Value: String); -begin - if FHelpFile = Value then Exit; - Log( '->TKOLProject.SetHelpFile' ); - TRY + FHelpFile := Value; + Change; + ChangeAllForms; - FHelpFile := Value; - Change; - ChangeAllForms; - - LogOK; - FINALLY - Log( '<-TKOLProject.SetHelpFile' ); - END; + LogOK; + finally + Log('<-TKOLProject.SetHelpFile'); + end; end; procedure TKOLProject.SetIsKOLProject(const Value: Boolean); @@ -20376,53 +16255,51 @@ begin DB 'TKOLProject.SetIsKOLProject', 0 @@e_signature: end; - Log( '->TKOLProject.SetIsKOLProject' ); - TRY + Log('->TKOLProject.SetIsKOLProject'); + try - if not FLocked and not (csLoading in ComponentState) then - begin - if Value then - begin - GetIsKOLProject; - if fIsKOL < 1 then - begin - ShowMessage( 'Your project is not yet converted to KOL-MCK. '+ - 'To convert it, change property projectDest of TKOLProject first, ' + - 'and then drop TKOLForm (or change any TKOLForm property, if ' + - 'it is already dropped). Then, open destination project and work ' + - 'with it.' ); - LogOK; - Exit; + if not FLocked and not (csLoading in ComponentState) then begin + if Value then begin + GetIsKOLProject; + if fIsKOL < 1 then begin + Showmessage('Your project is not yet converted to KOL-MCK. ' + + 'To convert it, change property projectDest of TKOLProject first, ' + + 'and then drop TKOLForm (or change any TKOLForm property, if ' + + 'it is already dropped). Then, open destination project and work ' + + 'with it.'); + LogOK; + Exit; + end; + end + else begin + fIsKOL := 0; + GetIsKOLProject; end; - end - else - begin - fIsKOL := 0; - GetIsKOLProject; end; - end; - LogOK; - FINALLY - Log( '<-TKOLProject.SetIsKOLProject' ); - END; + LogOK; + finally + Log('<-TKOLProject.SetIsKOLProject'); + end; end; procedure TKOLProject.SetLocalizy(const Value: Boolean); begin - if FLocalizy = Value then Exit; - Log( '->TKOLProject.SetLocalizy' ); - TRY - FLocalizy := Value; - Change; - LogOK; - FINALLY - Log( '<-TKOLProject.SetLocalizy' ); - END; + if FLocalizy = Value then + Exit; + Log('->TKOLProject.SetLocalizy'); + try + FLocalizy := Value; + Change; + LogOK; + finally + Log('<-TKOLProject.SetLocalizy'); + end; end; procedure TKOLProject.SetLocked(const Value: Boolean); -var I: Integer; +var + I: Integer; begin asm jmp @@e_signature @@ -20430,45 +16307,43 @@ begin DB 'TKOLProject.SetLocked', 0 @@e_signature: end; - Log( '->TKOLProject.SetLocked' ); - TRY + Log('->TKOLProject.SetLocked'); + try - if FLocked = Value then - begin - Rpt( 'TKOLProject made LOCKED.', RED ); - LogOK; Exit; - end; - if not Value then - begin - for I := 0 to Owner.ComponentCount-1 do - if IsVCLControl( Owner.Components[ I ] ) then - begin - ShowMessage( 'Form ' + Owner.Name + ' contains VCL controls. TKOLProject ' + - 'component can not be unlocked.' ); - LogOK; - Exit; - end; - I := MessageBox( 0, 'TKOLProject component was locked because one of project''s form had ' + - 'VCL controls placed on it. Are You sure You want to unlock TKOLProject?'#13 + - '(Note: if the the project is VCL-based, unlocking TKOLProject ' + - 'component can damage it).', 'CAUTION!', MB_YESNO or MB_SETFOREGROUND ); - if I = ID_NO then - begin + if FLocked = Value then begin + Rpt('TKOLProject made LOCKED.', RED); LogOK; Exit; end; - end; - FLocked := Value; + if not Value then begin + for I := 0 to Owner.ComponentCount - 1 do + if IsVCLControl(Owner.Components[I]) then begin + Showmessage('Form ' + Owner.name + ' contains VCL controls. TKOLProject ' + + 'component can not be unlocked.'); + LogOK; + Exit; + end; + I := MessageBox(0, 'TKOLProject component was locked because one of project''s form had ' + + 'VCL controls placed on it. Are You sure You want to unlock TKOLProject?'#13 + + '(Note: if the the project is VCL-based, unlocking TKOLProject ' + + 'component can damage it).', 'CAUTION!', MB_YESNO or MB_SETFOREGROUND); + if I = ID_NO then begin + LogOK; + Exit; + end; + end; + FLocked := Value; - LogOK; - FINALLY - Log( '<-TKOLProject.SetLocked' ); - END; + LogOK; + finally + Log('<-TKOLProject.SetLocked'); + end; end; procedure TKOLProject.SetName(const NewName: TComponentName); -var I: Integer; - C: TComponent; +var + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -20476,63 +16351,27 @@ begin DB 'TKOLProject.SetName', 0 @@e_signature: end; - Log( '->TKOLProject.SetName' ); - TRY + Log('->TKOLProject.SetName'); + try - inherited; - if not (csLoading in ComponentState) then - if Owner <> nil then - if Owner is TForm then - if IsKOLProject then - begin - for I := 0 to (Owner as TForm).ComponentCount-1 do - begin - C := (Owner as TForm).Components[ I ]; - if C is TKOLForm then - begin - Build := TRUE; - break; - end; - end; - end; + inherited; + if not (csLoading in ComponentState) then + if Owner <> nil then + if Owner is TForm then + if isKOLProject then begin + for I := 0 to (Owner as TForm).ComponentCount - 1 do begin + c := (Owner as TForm).Components[I]; + if c is TKOLForm then begin + BUILD := True; + Break; + end; + end; + end; - LogOK; - FINALLY - Log( '<-TKOLProject.SetName' ); - END; -end; - -procedure TKOLProject.setNewIf(const Value: Boolean); -begin - if FNewIF = Value then Exit; - {$IFNDEF _D6orHigher} - if Value and not(csLoading in ComponentState) then - begin - CASE MessageBox( 0, 'Are you sure? ' + - 'Directives {$IF...} and {$IFEND} are not supported in this version of Delphi.', - nil, MB_YESNO or MB_DEFBUTTON2 ) OF - ID_YES: ; - ID_NO : Exit; - END; + LogOK; + finally + Log('<-TKOLProject.SetName'); end; - {$ENDIF} - {$IFDEF _D2005orHigher} - if Value and not(csLoading in ComponentState) then - begin - CASE MessageBox( 0, 'Are you sure? ' + - 'Directives {$IF...} and {$IFEND} must be used in this version of Delphi.', - nil, MB_YESNO or MB_DEFBUTTON2 ) OF - ID_YES: ; - ID_NO : Exit; - END; - end; - {$ENDIF} - FNewIF := Value; - GlobalNewIF := Value; -// FNewIF := true; -// GlobalNewIF := true; - Change; - ChangeAllForms; end; procedure TKOLProject.SetOutdcuPath(const Value: TFileName); @@ -20543,14 +16382,14 @@ begin DB 'TKOLProject.SetOutdcuPath', 0 @@e_signature: end; - Log( '->TKOLProject.SetOutdcuPath' ); - TRY - fOutdcuPath := ''; //TODO: understand what is it... + Log('->TKOLProject.SetOutdcuPath'); + try + fOutdcuPath := ''; //TODO: understand what is it... //if FLocked then Exit; - LogOK; - FINALLY - Log( '<-TKOLProject.SetOutdcuPath' ); - END; + LogOK; + finally + Log('<-TKOLProject.SetOutdcuPath'); + end; end; procedure TKOLProject.SetPaintType(const Value: TPaintType); @@ -20561,23 +16400,23 @@ begin DB 'TKOLProject.SetPaintType', 0 @@e_signature: end; - Log( '->TKOLProject.SetPaintType' ); - TRY + Log('->TKOLProject.SetPaintType'); + try - if FPaintType = Value then - begin - LogOK; Exit; + if FPaintType = Value then begin + LogOK; + Exit; + end; + FPaintType := Value; + BroadCastPaintTypeToAllForms; + + LogOK; + finally + Log('<-TKOLProject.SetPaintType'); end; - FPaintType := Value; - BroadCastPaintTypeToAllForms; - - LogOK; - FINALLY - Log( '<-TKOLProject.SetPaintType' ); - END; end; -procedure TKOLProject.SetProjectDest(const Value: String); +procedure TKOLProject.SetProjectDest(const Value: string); begin asm jmp @@e_signature @@ -20585,22 +16424,20 @@ begin DB 'TKOLProject.SetProjectDest', 0 @@e_signature: end; - Log( '->TKOLProject.SetProjectDest' ); - TRY + Log('->TKOLProject.SetProjectDest'); + try - if not FLocked then - begin - if not IsValidIdent( Value ) then - ShowMessage( 'Destination project name must be valid identifier.' ) - else - if (ProjectName = '') or (LowerCase( Value ) <> LowerCase( ProjectName )) then - FProjectDest := Value; + if not FLocked then begin + if not IsValidIdent(Value) then + Showmessage('Destination project name must be valid identifier.') + else if (projectName = '') or (LowerCase(Value) <> LowerCase(projectName)) then + FProjectDest := Value; + end; + + LogOK; + finally + Log('<-TKOLProject.SetProjectDest'); end; - - LogOK; - FINALLY - Log( '<-TKOLProject.SetProjectDest' ); - END; end; procedure TKOLProject.SetReportDetailed(const Value: Boolean); @@ -20610,16 +16447,17 @@ end; procedure TKOLProject.SetShowHint(const Value: Boolean); begin - if FShowHint = Value then Exit; - Log( '->TKOLProject.SetShowHint' ); - TRY - FShowHint := Value; - Change; - ChangeAllForms; - LogOK; - FINALLY - Log( '<-TKOLProject.SetShowHint' ); - END; + if FShowHint = Value then + Exit; + Log('->TKOLProject.SetShowHint'); + try + FShowHint := Value; + Change; + ChangeAllForms; + LogOK; + finally + Log('<-TKOLProject.SetShowHint'); + end; end; procedure TKOLProject.SetSupportAnsiMnemonics(const Value: LCID); @@ -20630,40 +16468,39 @@ begin DB 'TKOLProject.SetSupportAnsiMnemonics', 0 @@e_signature: end; - if FSupportAnsiMnemonics = Value then Exit; - Log( '->TKOLProject.SetSupportAnsiMnemonics' ); - TRY + if FSupportAnsiMnemonics = Value then + Exit; + Log('->TKOLProject.SetSupportAnsiMnemonics'); + try FSupportAnsiMnemonics := Value; Change; ChangeAllForms; - LogOK; - FINALLY - Log( '<-TKOLProject.SetSupportAnsiMnemonics' ); - END; -end; - -function TKOLProject.StringConstant(const Propname, Value: String): String; -begin - Log( '->TKOLProject.StringConstant' ); - TRY - - if Localizy and (Value <> '') then - begin - Result := Name + '_' + Propname; - MakeResourceString( Result, Value ); - end - else - begin - Result := String2Pascal( Value, '+' ); + LogOK; + finally + Log('<-TKOLProject.SetSupportAnsiMnemonics'); end; - - LogOK; - FINALLY - Log( '<-TKOLProject.StringConstant' ); - END; end; -procedure TKOLProject.TimerTick( Sender: TObject ); +function TKOLProject.StringConstant(const Propname, Value: string): string; +begin + Log('->TKOLProject.StringConstant'); + try + + if Localizy and (Value <> '') then begin + Result := name + '_' + Propname; + MakeResourceString(Result, Value); + end + else begin + Result := String2Pascal(Value, '+'); + end; + + LogOK; + finally + Log('<-TKOLProject.StringConstant'); + end; +end; + +procedure TKOLProject.TimerTick(Sender: TObject); begin asm jmp @@e_signature @@ -20671,33 +16508,31 @@ begin DB 'TKOLProject.TimerTick', 0 @@e_signature: end; - Log( '->TKOLProject.TimerTick' ); - TRY + Log('->TKOLProject.TimerTick'); + try - if not FBuilding and not AutoBuilding then - begin - fTimer.Enabled := False; - if not FLocked and not (csLoading in ComponentState) then - begin - if AutoBuild then - begin - AutoBuilding := True; - ConvertVCL2KOL( FALSE, FALSE ); - AutoBuilding := False; + if not FBuilding and not AutoBuilding then begin + fTimer.Enabled := False; + if not FLocked and not (csLoading in ComponentState) then begin + if autoBuild then begin + AutoBuilding := True; + ConvertVCL2KOL(False, False); + AutoBuilding := False; + end; + end; end; - end; - end; - LogOK; - FINALLY - Log( '<-TKOLProject.TimerTick' ); - END; + LogOK; + finally + Log('<-TKOLProject.TimerTick'); + end; end; {$IFDEF _D2007orHigher} + function TKOLProject.MakeupConfig: Boolean; var - DestConf: String; + DestConf: string; DummyList: TStringList; Updated: Boolean; begin @@ -20709,23 +16544,20 @@ begin end; Result := False; - if not FLocked then - begin + if not FLocked then begin DummyList := TStringList.Create; - DestConf := SourcePath + ProjectDest + '.cfg'; // TODO: change ProjectDest to (Unicode)String - if not(FileExists(DestConf)) then - begin + DestConf := sourcePath + projectDest + '.cfg'; // TODO: change ProjectDest to (Unicode)String + if not (FileExists(DestConf)) then begin DummyList.Add('-AClasses=;mirror='); DummyList.Add('-DKOL_MCK'); SaveStrings(DummyList, DestConf, Updated); Result := Updated; end; - DestConf := SourcePath + ProjectDest + '.dof'; + DestConf := sourcePath + projectDest + '.dof'; DummyList.Clear; - if not(FileExists(DestConf)) then - begin + if not (FileExists(DestConf)) then begin DummyList.Add('[Compiler]'); DummyList.Add('UnitAliases=Classes=;mirror='); DummyList.Add('[Directories]'); @@ -20734,17 +16566,18 @@ begin Result := Result and Updated; end; - DummyList.Free; + DummyList.free; end; end; {$ENDIF} function TKOLProject.UpdateConfig: Boolean; -var S, R: String; - L: TStringList; - I: Integer; - AFound, DFound {, DWere}: Boolean; - Updated: Boolean; +var + s, R: string; + L: TStringList; + I: Integer; + AFound, DFound {, DWere}: Boolean; + Updated: Boolean; begin asm jmp @@e_signature @@ -20752,84 +16585,71 @@ begin DB 'TKOLProject.UpdateConfig', 0 @@e_signature: end; - Log( '->TKOLProject.UpdateConfig' ); - TRY + Log('->TKOLProject.UpdateConfig'); + try - Result := False; - if not FLocked then - begin -{$IFDEF _D2007orHigher} // TODO: 2005? - MakeupConfig(); // TODO: move to ConvertVCL2KOL, or genreate both source/dest cfg + Result := False; + if not FLocked then begin +{$IFDEF _D2007orHigher} // TODO: 2005? + MakeupConfig(); // TODO: move to ConvertVCL2KOL, or genreate both source/dest cfg {$ENDIF} - S := SourcePath + ProjectName + '.cfg'; - R := SourcePath + ProjectDest + '.cfg'; - L := TStringList.Create; - //DWere := FALSE; - if FileExists( S ) then - begin - LoadSource( L, S ); - AFound := False; - DFound := False; - for I := 0 to L.Count - 1 do - begin - if Length( L[ I ] ) < 2 then continue; - if L[ I ][ 2 ] = 'A' then - begin - L[ I ] := '-AClasses=;Controls=;mirror='; - AFound := True; + s := sourcePath + projectName + '.cfg'; + R := sourcePath + projectDest + '.cfg'; + L := TStringList.Create; + //DWere := FALSE; + if FileExists(s) then begin + LoadSource(L, s); + AFound := False; + DFound := False; + for I := 0 to L.Count - 1 do begin + if Length(L[I]) < 2 then + Continue; + if L[I][2] = 'A' then begin + L[I] := '-AClasses=;Controls=;mirror='; + AFound := True; + end; + if L[I][2] = 'D' then begin + {if pos( 'KOL_MCK', UpperCase( L[ I ] ) ) then + DWere := TRUE;} + if Pos('KOL_MCK', UpperCase(L[I])) <= 0 then + L[I] := //'-DKOL_MCK'; + IncludeTrailingChar(L[I], ';') + 'KOL_MCK'; + DFound := True; + end; end; - if L[ I ][ 2 ] = 'D' then - begin - {if pos( 'KOL_MCK', UpperCase( L[ I ] ) ) then - DWere := TRUE;} - if pos( 'KOL_MCK', UpperCase( L[ I ] ) ) <= 0 then - L[ I ] := //'-DKOL_MCK'; - IncludeTrailingChar( L[ I ], ';' ) + 'KOL_MCK'; - DFound := True; + if not AFound then + L.Add('-AClasses=;Controls=;StdCtrls=;ExtCtrls=;mirror='); + if not DFound then + L.Add('-DKOL_MCK'); + SaveStrings(L, R, Updated); + end; + L.Clear; + s := sourcePath + projectName + '.dof'; + R := sourcePath + projectDest + '.dof'; + if FileExists(s) then begin + LoadSource(L, s); + for I := 0 to L.Count - 1 do begin + if Copy(L[I], 1, Length('UnitAliases=')) = 'UnitAliases=' then + L[I] := 'UnitAliases=Classes=;mirror='; + if Copy(L[I], 1, Length('Conditionals=')) = 'Conditionals=' then + if Pos('KOL_MCK', UpperCase(L[I])) <= 0 then + L[I] := 'Conditionals=KOL_MCK'; end; + SaveStrings(L, R, Updated); end; - if not AFound then - L.Add( '-AClasses=;Controls=;StdCtrls=;ExtCtrls=;mirror=' ); - if not DFound then - L.Add( '-DKOL_MCK' ); - SaveStrings( L, R, Updated ); + L.free; end; - L.Clear; - S := SourcePath + ProjectName + '.dof'; - R := SourcePath + ProjectDest + '.dof'; - if FileExists( S ) then - begin - LoadSource( L, S ); - for I := 0 to L.Count - 1 do - begin - if Copy( L[ I ], 1, Length( 'UnitAliases=' ) ) = 'UnitAliases=' then - L[ I ] := 'UnitAliases=Classes=;mirror='; - if Copy( L[ I ], 1, Length( 'Conditionals=' ) ) = 'Conditionals=' then - if pos( 'KOL_MCK', UpperCase( L[ I ] ) ) <= 0 then - L[ I ] := 'Conditionals=KOL_MCK'; - end; - SaveStrings( L, R, Updated ); - end; - L.Free; + LogOK; + finally + Log('<-TKOLProject.UpdateConfig'); end; - LogOK; - FINALLY - Log( '<-TKOLProject.UpdateConfig' ); - END; end; procedure TKOLProject.SetDefaultFont(const Value: TKOLFont); begin - if FDefaultFont.Equal2( Value ) then Exit; - FDefaultFont.Assign( Value ); - Change; - ChangeAllForms; -end; - -procedure TKOLProject.SetFormCompactDisabled(const Value: Boolean); -begin - if FFormCompactDisabled = Value then Exit; - FFormCompactDisabled := Value; + if FDefaultFont.Equal2(Value) then + Exit; + FDefaultFont.Assign(Value); Change; ChangeAllForms; end; @@ -20850,9 +16670,9 @@ begin fT := Top; fH := Height; fW := Width; - (Owner as TKOLForm).Change( nil ); + (Owner as TKOLForm).Change(nil); if not (csLoading in (Owner as TKOLForm).ComponentState) then - (Owner as TKOLForm).AlignChildren( nil, FALSE ); + (Owner as TKOLForm).AlignChildren(nil, False); end; procedure TFormBounds.CheckFormSize(Sender: TObject); @@ -20863,16 +16683,21 @@ begin DB 'TFormBounds.CheckFormSize', 0 @@e_signature: end; - if Owner = nil then Exit; + if Owner = nil then + Exit; //if Owner.Name = '' then Exit; - if Owner.Owner = nil then Exit; + if Owner.Owner = nil then + Exit; //if Owner.Owner.Name = '' then Exit; - if csLoading in (Owner as TComponent).ComponentState then Exit; - if csLoading in (Owner.Owner as TComponent).ComponentState then Exit; + if csLoading in (Owner as TComponent).ComponentState then + Exit; + if csLoading in (Owner.Owner as TComponent).ComponentState then + Exit; if fL = (Owner.Owner as TForm).Left then - if fT = (Owner.Owner as TForm).Top then - if fW = (Owner.Owner as TForm).Width then - if fH = (Owner.Owner as TForm).Height then Exit; + if fT = (Owner.Owner as TForm).Top then + if fW = (Owner.Owner as TForm).Width then + if fH = (Owner.Owner as TForm).Height then + Exit; {Rpt( 'L=' + IntToStr( fL ) + ' <> ' + IntToStr( (Owner.Owner as TForm).Left ) + #13#10 + 'T=' + IntToStr( fT ) + ' <> ' + IntToStr( (Owner.Owner as TForm).Top ) + #13#10 + 'W=' + IntToStr( fW ) + ' <> ' + IntToStr( (Owner.Owner as TForm).Width ) + #13#10 + @@ -20889,10 +16714,10 @@ begin @@e_signature: end; inherited; - fTimer := TTimer.Create( Owner ); + fTimer := TTimer.Create(Owner); fTimer.Interval := 300; fTimer.OnTimer := CheckFormSize; - fTimer.Enabled := FALSE; + fTimer.Enabled := False; end; destructor TFormBounds.Destroy; @@ -20903,10 +16728,9 @@ begin DB 'TFormBounds.Destroy', 0 @@e_signature: end; - if Assigned( fTimer ) then - begin + if Assigned(fTimer) then begin fTimer.Enabled := False; - fTimer.Free; + fTimer.free; fTimer := nil; end; inherited; @@ -20918,7 +16742,8 @@ begin end; function TFormBounds.GetHeight: Integer; -var F: TControl; +var + F: TControl; begin asm jmp @@e_signature @@ -20931,7 +16756,8 @@ begin end; function TFormBounds.GetLeft: Integer; -var F: TControl; +var + F: TControl; begin asm jmp @@e_signature @@ -20944,7 +16770,8 @@ begin end; function TFormBounds.GetTop: Integer; -var F: TControl; +var + F: TControl; begin asm jmp @@e_signature @@ -20957,7 +16784,8 @@ begin end; function TFormBounds.GetWidth: Integer; -var F: TControl; +var + F: TControl; begin asm jmp @@e_signature @@ -20970,7 +16798,8 @@ begin end; procedure TFormBounds.SetHeight(const Value: Integer); -var F: TControl; +var + F: TControl; begin asm jmp @@e_signature @@ -20980,13 +16809,15 @@ begin end; fH := Value; F := Owner.Owner as TControl; - if F.Height = Value then Exit; + if F.Height = Value then + Exit; F.Height := Value; Change; end; procedure TFormBounds.SetLeft(const Value: Integer); -var F: TControl; +var + F: TControl; begin asm jmp @@e_signature @@ -20996,7 +16827,8 @@ begin end; fL := Value; F := Owner.Owner as TControl; - if F.Left = Value then Exit; + if F.Left = Value then + Exit; F.Left := Value; Change; end; @@ -21005,12 +16837,13 @@ procedure TFormBounds.SetOwner(const Value: TComponent); begin fOwner := Value; if fOwner <> nil then - if not(csLoading in fOwner.ComponentState) then - fTimer.Enabled := True; + if not (csLoading in fOwner.ComponentState) then + fTimer.Enabled := True; end; procedure TFormBounds.SetTop(const Value: Integer); -var F: TControl; +var + F: TControl; begin asm jmp @@e_signature @@ -21020,13 +16853,15 @@ begin end; fT := Value; F := Owner.Owner as TControl; - if F.Top = Value then Exit; + if F.Top = Value then + Exit; F.Top := Value; Change; end; procedure TFormBounds.SetWidth(const Value: Integer); -var F: TControl; +var + F: TControl; begin asm jmp @@e_signature @@ -21036,14 +16871,15 @@ begin end; fW := Value; F := Owner.Owner as TControl; - if F.Width = Value then Exit; + if F.Width = Value then + Exit; F.Width := Value; Change; end; { TKOLObj } -function TKOLObj.AdditionalUnits: String; +function TKOLObj.AdditionalUnits: string; begin asm jmp @@e_signature @@ -21062,12 +16898,12 @@ begin DB 'TKOLObj.AddToNotifyList', 0 @@e_signature: end; - if Assigned( fNotifyList ) then - if fNotifyList.IndexOf( Sender ) < 0 then - fNotifyList.Add( Sender ); + if Assigned(fNotifyList) then + if fNotifyList.IndexOf(Sender) < 0 then + fNotifyList.Add(Sender); end; -procedure TKOLObj.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLObj.AssignEvents(SL: TStringList; const AName: string); begin asm jmp @@e_signature @@ -21075,12 +16911,12 @@ begin DB 'TKOLObj.AssignEvents', 0 @@e_signature: end; - DoAssignEvents( SL, AName, - [ 'OnDestroy' ], - [ @ OnDestroy ] ); + DoAssignEvents(SL, AName, + ['OnDestroy'], + [@OnDestroy]); end; -function TKOLObj.BestEventName: String; +function TKOLObj.BestEventName: string; begin asm jmp @@e_signature @@ -21099,13 +16935,15 @@ begin DB 'TKOLObj.Change', 0 @@e_signature: end; - FreeAndNil( CacheLines_SetupFirst ); - if (csLoading in ComponentState) then Exit; - if ParentKOLForm = nil then Exit; - ParentKOLForm.Change( Self ); + FreeAndNil(CacheLines_SetupFirst); + if (csLoading in ComponentState) then + Exit; + if ParentKOLForm = nil then + Exit; + ParentKOLForm.Change(Self); end; -function TKOLObj.CompareFirst(c, n: string): boolean; +function TKOLObj.CompareFirst(c, N: string): Boolean; begin asm jmp @@e_signature @@ -21113,7 +16951,7 @@ begin DB 'TKOLObj.CompareFirst', 0 @@e_signature: end; - Result := FALSE; + Result := False; end; constructor TKOLObj.Create(AOwner: TComponent); @@ -21130,9 +16968,10 @@ begin end; destructor TKOLObj.Destroy; -var F: TKOLForm; - I: Integer; - C: TComponent; +var + F: TKOLForm; + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -21140,38 +16979,36 @@ begin DB 'TKOLObj.Destroy', 0 @@e_signature: end; - FreeAndNil( CacheLines_SetupFirst ); - if Assigned( Owner ) and not (csDestroying in Owner.ComponentState) then - begin - if Assigned( fNotifyList ) then - for I := fNotifyList.Count-1 downto 0 do - begin - C := fNotifyList[ I ]; - if C is TKOLObj then - (C as TKOLObj).NotifyLinkedComponent( Self, noRemoved ) - else - if C is TKOLCustomControl then - (C as TKOLCustomControl).NotifyLinkedComponent( Self, noRemoved ); + FreeAndNil(CacheLines_SetupFirst); + if Assigned(Owner) and not (csDestroying in Owner.ComponentState) then begin + if Assigned(fNotifyList) then + for I := fNotifyList.Count - 1 downto 0 do begin + c := fNotifyList[I]; + if c is TKOLObj then + (c as TKOLObj).NotifyLinkedComponent(Self, noRemoved) + else if c is TKOLCustomControl then + (c as TKOLCustomControl).NotifyLinkedComponent(Self, noRemoved); end; - TRY - if OwnerKOLForm( Owner ) <> nil then - OwnerKOLForm( Owner ).Change( nil ); - FINALLY - Rpt( 'Exception (destroying TKOLObj)', RED ); - END; + try + if OwnerKOLForm(Owner) <> nil then + OwnerKOLForm(Owner).Change(nil); + finally + Rpt('Exception (destroying TKOLObj)', RED); + end; end; - fNotifyList.Free; + fNotifyList.free; fNotifyList := nil; F := ParentKOLForm; inherited; if (F <> nil) and not F.FIsDestroying and (Owner <> nil) and - not(csDestroying in Owner.ComponentState) then - F.Change( F ); + not (csDestroying in Owner.ComponentState) then + F.Change(F); end; -procedure TKOLObj.DoAssignEvents(SL: TStringList; const AName: String; +procedure TKOLObj.DoAssignEvents(SL: TStringList; const AName: string; const EventNames: array of PAnsiChar; const EventHandlers: array of Pointer); -var I: Integer; +var + I: Integer; begin asm jmp @@e_signature @@ -21179,12 +17016,10 @@ begin DB 'TKOLObj.DoAssignEvents', 0 @@e_signature: end; - for I := 0 to High( EventHandlers ) do - begin - if EventHandlers[ I ] <> nil then - begin - SL.Add( ' ' + AName + '.' + String(EventNames[ I ]) + ' := Result.' + - ParentForm.MethodName( EventHandlers[ I ] ) + ';' ); // TODO: KOL_ANSI + for I := 0 to High(EventHandlers) do begin + if EventHandlers[I] <> nil then begin + SL.Add(' ' + AName + '.' + string(EventNames[I]) + ' := Result.' + + ParentForm.MethodName(EventHandlers[I]) + ';'); // TODO: KOL_ANSI end; end; end; @@ -21199,7 +17034,7 @@ begin end; end; -procedure TKOLObj.DoGenerateConstants( SL: TStringList ); +procedure TKOLObj.DoGenerateConstants(SL: TStringList); begin // end; @@ -21235,12 +17070,13 @@ begin @@e_signature: end; if Operation = noRemoved then - if Assigned( fNotifyList ) then - fNotifyList.Remove( Sender ); + if Assigned(fNotifyList) then + fNotifyList.Remove(Sender); end; function TKOLObj.ParentForm: TForm; -var C: TComponent; +var + c: TComponent; begin asm jmp @@e_signature @@ -21250,16 +17086,17 @@ begin end; Result := nil; - C := Owner; - while Assigned(C) and not (C is TForm) do - C := C.Owner; - if Assigned(C) and (C is TForm) then - Result := (C as TForm); + c := Owner; + while Assigned(c) and not (c is TForm) do + c := c.Owner; + if Assigned(c) and (c is TForm) then + Result := (c as TForm); end; function TKOLObj.ParentKOLForm: TKOLForm; -var C, D: TComponent; - I: Integer; +var + c, D: TComponent; + I: Integer; begin asm jmp @@e_signature @@ -21267,29 +17104,27 @@ begin DB 'TKOLObj.ParentKOLForm', 0 @@e_signature: end; - C := Owner; - while (C <> nil) and not(C is TForm) do - C := C.Owner; + c := Owner; + while (c <> nil) and not (c is TForm) do + c := c.Owner; Result := nil; - if C <> nil then - if C is TForm then - begin - for I := 0 to (C as TForm).ComponentCount - 1 do - begin - D := (C as TForm).Components[ I ]; - if D is TKOLForm then - begin - Result := D as TKOLForm; - break; + if c <> nil then + if c is TForm then begin + for I := 0 to (c as TForm).ComponentCount - 1 do begin + D := (c as TForm).Components[I]; + if D is TKOLForm then begin + Result := D as TKOLForm; + Break; + end; end; end; - end; end; procedure TKOLObj.SetName(const NewName: TComponentName); -var OldName, NameNew: String; - I, N: Integer; - Success: Boolean; +var + OldName, NameNew: string; + I, N: Integer; + Success: Boolean; begin asm jmp @@e_signature @@ -21297,31 +17132,28 @@ begin DB 'TKOLObj.SetName', 0 @@e_signature: end; - OldName := Name; - inherited SetName( NewName ); - if (Copy( NewName, 1, 3 ) = 'KOL') and (OldName = '') then - begin - NameNew := Copy( NewName, 4, Length( NewName ) - 3 ); + OldName := name; + inherited SetName(NewName); + if (Copy(NewName, 1, 3) = 'KOL') and (OldName = '') then begin + NameNew := Copy(NewName, 4, Length(NewName) - 3); Success := True; if Owner <> nil then - while Owner.FindComponent( NameNew ) <> nil do - begin - Success := False; - for I := 1 to Length( NameNew ) do - begin - if (NameNew[ I ] >= '0') and (NameNew[ I ] <= '9') then - begin - Success := True; - N := StrToInt( Copy( NameNew, I, Length( NameNew ) - I + 1 ) ); - Inc( N ); - NameNew := Copy( NameNew, 1, I - 1 ) + IntToStr( N ); - break; + while Owner.FindComponent(NameNew) <> nil do begin + Success := False; + for I := 1 to Length(NameNew) do begin + if (NameNew[I] >= '0') and (NameNew[I] <= '9') then begin + Success := True; + N := StrToInt(Copy(NameNew, I, Length(NameNew) - I + 1)); + Inc(N); + NameNew := Copy(NameNew, 1, I - 1) + IntToStr(N); + Break; end; + end; + if not Success then + Break; end; - if not Success then break; - end; if Success then - Name := NameNew; + name := NameNew; if not (csLoading in ComponentState) then FirstCreate; end; @@ -21336,13 +17168,14 @@ begin DB 'TKOLObj.SetOnDestroy', 0 @@e_signature: end; - if @ FOnDestroy = @ Value then Exit; + if @FOnDestroy = @Value then + Exit; FOnDestroy := Value; Change; end; procedure TKOLObj.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); + AParent, Prefix: string); begin asm jmp @@e_signature @@ -21350,12 +17183,12 @@ begin DB 'TKOLObj.SetupFirst', 0 @@e_signature: end; - SL.Add( Prefix + AName + ' := New' + TypeName + ';' ); - SetupName( SL, AName, AParent, Prefix ); - GenerateTag( SL, AName, Prefix ); + SL.Add(Prefix + AName + ' := New' + TypeName + ';'); + SetupName(SL, AName, AParent, Prefix); + GenerateTag(SL, AName, Prefix); end; -procedure TKOLObj.SetupLast(SL: TStringList; const AName, AParent, Prefix: String); +procedure TKOLObj.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); begin asm jmp @@e_signature @@ -21366,7 +17199,7 @@ begin // по умолчанию ничего не надо... Разве только в наследниках. end; -function TKOLObj.TypeName: String; +function TKOLObj.TypeName: string; begin asm jmp @@e_signature @@ -21375,55 +17208,56 @@ begin @@e_signature: end; Result := ClassName; - if UpperCase( Copy( Result, 1, 4 ) ) = 'TKOL' then - Result := Copy( Result, 5, Length( Result ) - 4 ); + if UpperCase(Copy(Result, 1, 4)) = 'TKOL' then + Result := Copy(Result, 5, Length(Result) - 4); end; procedure TKOLObj.Set_Tag(const Value: Integer); begin - if F_Tag = Value then Exit; + if F_Tag = Value then + Exit; F_Tag := Value; Change; end; procedure TKOLObj.GenerateTag(SL: TStringList; const AName, - APrefix: String); -var S: String; + APrefix: string); +var + s: string; begin - if F_Tag <> 0 then - begin - S := IntToStr( F_Tag ); - if Integer( F_Tag ) < 0 then - S := 'DWORD( ' + S + ' )'; - SL.Add( APrefix + AName + '.Tag := ' + S + ';' ) + if F_Tag <> 0 then begin + s := IntToStr(F_Tag); + if Integer(F_Tag) < 0 then + s := 'DWORD( ' + s + ' )'; + SL.Add(APrefix + AName + '.Tag := ' + s + ';') end; end; -function TKOLObj.StringConstant(const Propname, Value: String): String; +function TKOLObj.StringConstant(const Propname, Value: string): string; begin - if (Value <> '') AND - ((Localizy = loForm) and (ParentKOLForm <> nil) and - (ParentKOLForm.Localizy) or (Localizy = loYes)) then - begin - Result := ParentKOLForm.Name + '_' + Name + '_' + Propname; - ParentKOLForm.MakeResourceString( Result, Value ); + if (Value <> '') and + ((Localizy = loForm) and (ParentKOLForm <> nil) and + (ParentKOLForm.Localizy) or (Localizy = loYes)) then begin + Result := ParentKOLForm.name + '_' + name + '_' + Propname; + ParentKOLForm.MakeResourceString(Result, Value); end - else - begin - Result := String2Pascal( Value, '+' ); + else begin + Result := String2Pascal(Value, '+'); end; end; procedure TKOLObj.SetLocalizy(const Value: TLocalizyOptions); begin - if FLocalizy = Value then Exit; + if FLocalizy = Value then + Exit; FLocalizy := Value; Change; end; -function TKOLObj.OwnerKOLForm( AOwner: TComponent ): TKOLForm; -var C, D: TComponent; - I: Integer; +function TKOLObj.OwnerKOLForm(AOwner: TComponent): TKOLForm; +var + c, D: TComponent; + I: Integer; begin asm jmp @@e_signature @@ -21431,227 +17265,70 @@ begin DB 'TKOLObj.ParentKOLForm', 0 @@e_signature: end; - C := AOwner; - while (C <> nil) and not(C is TForm) do - C := C.Owner; + c := AOwner; + while (c <> nil) and not (c is TForm) do + c := c.Owner; Result := nil; - if C <> nil then - if C is TForm then - begin - for I := 0 to (C as TForm).ComponentCount - 1 do - begin - D := (C as TForm).Components[ I ]; - if D is TKOLForm then - begin - Result := D as TKOLForm; - break; + if c <> nil then + if c is TForm then begin + for I := 0 to (c as TForm).ComponentCount - 1 do begin + D := (c as TForm).Components[I]; + if D is TKOLForm then begin + Result := D as TKOLForm; + Break; + end; end; end; - end; end; procedure TKOLObj.DoNotifyLinkedComponents(Operation: TNotifyOperation); -var I: Integer; - C: TComponent; +var + I: Integer; + c: TComponent; begin - if Assigned( fNotifyList ) then - for I := fNotifyList.Count-1 downto 0 do - begin - C := fNotifyList[ I ]; - if C is TKOLObj then - (C as TKOLObj).NotifyLinkedComponent( Self, Operation ) - else - if C is TKOLCustomControl then - (C as TKOLCustomControl).NotifyLinkedComponent( Self, Operation ); + if Assigned(fNotifyList) then + for I := fNotifyList.Count - 1 downto 0 do begin + c := fNotifyList[I]; + if c is TKOLObj then + (c as TKOLObj).NotifyLinkedComponent(Self, Operation) + else if c is TKOLCustomControl then + (c as TKOLCustomControl).NotifyLinkedComponent(Self, Operation); end; end; -function TKOLObj.Pcode_Generate: Boolean; -begin - Result := FALSE; -end; - -procedure TKOLObj.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLObj.P_SetupFirst', 0 - @@e_signature: - end; - //SL.Add( Prefix + AName + ' := New' + TypeName + ';' ); - {P}SL.Add( ' New' + TypeName + ' RESULT' ); - P_SetupName( SL ); - P_GenerateTag( SL, AName, Prefix ); - {P}SL.Add( ' DUP C2 AddWord_Store ##T' + ParentKOLForm.FormName + '.' + AName ); -end; - -function TKOLObj.P_AssignEvents(SL: TStringList; const AName: String; CheckOnly: Boolean): Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLObj.P_AssignEvents', 0 - @@e_signature: - end; - Result := P_DoAssignEvents( SL, AName, - [ 'OnDestroy' ], - [ @ OnDestroy ], - [ FALSE ], CheckOnly ); -end; - -function TKOLObj.P_DoAssignEvents(SL: TStringList; const AName: String; - const EventNames: array of PAnsiChar; const EventHandlers: array of Pointer; - const EventAssignProc: array of Boolean; CheckOnly: Boolean): Boolean; -var I: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLObj.P_DoAssignEvents', 0 - @@e_signature: - end; - Result := TRUE; - for I := 0 to High( EventHandlers ) do - begin - if EventHandlers[ I ] <> nil then - begin - if CheckOnly then Exit; - //SL.Add( ' ' + AName + '.' + EventNames[ I ] + ' := Result.' + - // ParentForm.MethodName( EventHandlers[ I ] ) + ';' ); - P_DoProvideFakeType( SL ); - if EventAssignProc[ I ] then - begin - {P}SL.Add( ' LoadSELF Load4 ####T' + (Owner as TForm).Name + '.' + - (Owner as TForm).MethodName( EventHandlers[ I ] ) ); - {P}SL.Add( ' C2 T' + TypeName + '_.Set' + String(EventNames[ I ]) + '<1>' - ); // TODO: KOL_ANSI - end - else - begin - {P}SL.Add( ' Load4 ####T' + (Owner as TForm).Name + '.' + - (Owner as TForm).MethodName( EventHandlers[ I ] ) ); - {P}SL.Add( ' C1 AddWord_Store ##T' + TypeName + '_.f' + String(EventNames[ I ]) ); // TODO: KOL_ANSI - {P}SL.Add( ' LoadSELF C1 AddWord_Store ##(4+T' + TypeName + '_.f' + - String(EventNames[ I ]) + ')' ); // TODO: KOL_ANSI - end; - end; - end; - if CheckOnly then - Result := FALSE; -end; - -procedure TKOLObj.P_GenerateTag(SL: TStringList; const AName, - APrefix: String); -begin - if F_Tag <> 0 then - begin - {S := IntToStr( F_Tag ); - if Integer( F_Tag ) < 0 then - S := 'DWORD( ' + S + ' )'; - SL.Add( APrefix + AName + '.Tag := ' + S + ';' )} - {P}SL.Add( ' L(' + IntToStr( F_Tag ) + ')' ); - {P}SL.Add( ' C1 AddByte_Store #TObj_.fTag' ); - end; -end; - -procedure TKOLObj.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLObj.P_SetupLast', 0 - @@e_signature: - end; - // по умолчанию ничего не надо... Разве только в наследниках. -end; - procedure TKOLObj.ProvideObjInStack(SL: TStrings); begin - if not ObjInStack then - begin - {P}SL.Add( ' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name ); - ObjInStack := TRUE; + if not ObjInStack then begin + {P}SL.Add(' LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + name); + ObjInStack := True; end; end; -function TKOLObj.P_StringConstant(const Propname, Value: String): String; -begin - if (Value <> '') AND - ((Localizy = loForm) and (ParentKOLForm <> nil) and - (ParentKOLForm.Localizy) or (Localizy = loYes)) then - begin - //Result := ParentKOLForm.Name + '_' + Name + '_' + Propname; - {P}Result := ' ResourceString(' + Name + '_' + PropName + ')'; - ParentKOLForm.MakeResourceString( Result, Value ); - end - else - begin - //Result := String2Pascal( Value ); - {P}Result := ' LoadAnsiStr ' + P_String2Pascal( Value ); - end; -end; - -procedure TKOLObj.P_ProvideFakeType(SL: TStrings; - const Declaration: String); -var i: Integer; -begin - for i := 0 to SL.Count-1 do - if AnsiCompareText( SL[ i ], Declaration ) = 0 then Exit; - SL.Insert( 1, Declaration ); -end; - -procedure TKOLObj.P_SetupFirstFinalizy(SL: TStringList); -begin - // -end; - -procedure TKOLObj.P_DoProvideFakeType( SL: TStringList ); -begin - P_ProvideFakeType( SL, 'type T' + TypeName + '_ = object(T' + TypeName + ') end;' ); -end; - procedure TKOLObj.SetupName(SL: TStringList; const AName, AParent, - Prefix: String ); -var KF: TKOLForm; + Prefix: string); +var + KF: TKOLForm; begin - if FNameSetuped then Exit; + if FNameSetuped then + Exit; KF := ParentKOLForm; - if KF = nil then Exit; - if (Name <> '') and KF.GenerateCtlNames then - begin - RptDetailed( 'KF=' + KF.Name + ' ----- GenerateCtlNames = TRUE', WHITE or LIGHT ); - if AParent <> 'nil' then - SL.Add(Format( '%s%s.SetName( Result.Form, ''%s'' ); ', [Prefix, AName, Name])) - else - SL.Add(Format( '%s%s.SetName( Result, ''%s'' ); ', [Prefix, AName, Name])); - FNameSetuped := TRUE; - end; -end; - -procedure TKOLObj.P_SetupName(SL: TStringList); -begin - if fP_NameSetuped then Exit; - if Name <> '' then - begin - //SL.Add( ' {$IFDEF USE_NAMES}' ); - //SL.Add( Prefix + AName + '.Name := ''' + Name + ''';' ); - //SL.Add( ' {$ENDIF}' ); - {P}SL.Add( ' IFDEF(USE_NAMES)' ); - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( Name ) ); - {P}SL.Add( ' LoadSELF' ); - {P}SL.Add( ' C3 TObj.SetName<3> DelAnsiStr' ); - {P}SL.Add( ' ENDIF' ); - fP_NameSetuped := TRUE; + if KF = nil then + Exit; + if (name <> '') and KF.GenerateCtlNames then begin + RptDetailed('KF=' + KF.name + ' ----- GenerateCtlNames = TRUE', WHITE or LIGHT); + if AParent <> 'nil' then + SL.Add(Format('%s%s.SetName( Result.Form, ''%s'' ); ', [Prefix, AName, name])) + else + SL.Add(Format('%s%s.SetName( Result, ''%s'' ); ', [Prefix, AName, name])); + FNameSetuped := True; end; end; { TKOLFont } procedure TKOLFont.Assign(Value: TPersistent); -var F: TKOLFont; +var + F: TKOLFont; begin asm jmp @@e_signature @@ -21660,8 +17337,7 @@ begin @@e_signature: end; //inherited; - if Value = nil then - begin + if Value = nil then begin FColor := clWindowText; FFontStyle := []; FFontHeight := 0; @@ -21672,9 +17348,7 @@ begin FFontCharset := DEFAULT_CHARSET; FFontPitch := fpDefault; end - else - if Value is TKOLFont then - begin + else if Value is TKOLFont then begin F := Value as TKOLFont; FColor := F.Color; //Rpt( '-------------------------------Assigned font color:' + Int2Hex( Color2RGB( F.Color ), 8 ) ); @@ -21691,10 +17365,11 @@ begin end; procedure TKOLFont.Change; -var ParentOfOwner: TComponent; - {$IFDEF _KOLCtrlWrapper_} - _FKOLCtrl: PControl; - {$ENDIF} +var + ParentOfOwner: TComponent; +{$IFDEF _KOLCtrlWrapper_} + _FKOLCtrl: PControl; +{$ENDIF} begin asm jmp @@e_signature @@ -21702,85 +17377,80 @@ begin DB 'TKOLFont.Change', 0 @@e_signature: end; - if fOwner = nil then Exit; - if (fOwner is TKOLForm) and (fOwner as TKOLForm).fCreating then Exit; - if csLoading in fOwner.ComponentState then Exit; - if fChangingNow then Exit; + if fOwner = nil then + Exit; + if (fOwner is TKOLForm) and (fOwner as TKOLForm).fCreating then + Exit; + if csLoading in fOwner.ComponentState then + Exit; + if fChangingNow then + Exit; try - if fOwner is TKOLForm then - begin + if fOwner is TKOLForm then begin (fOwner as TKOLForm).ApplyFontToChildren; if KOLProject <> nil then - (fOwner as TKOLForm).fFontDefault := Equal2(KOLProject.DefaultFont); - (fOwner as TKOLForm).Change( fOwner ); + (fOwner as TKOLForm).FFontDefault := Equal2(KOLProject.DefaultFont); + (fOwner as TKOLForm).Change(fOwner); end else - {if (fOwner is TKOLCustomControl) then - begin - if not (csLoading in fOwner.ComponentState) then + {if (fOwner is TKOLCustomControl) then begin + if not (csLoading in fOwner.ComponentState) then + begin + ParentOfOwner := (fOwner as TKOLCustomControl).ParentKOLControl; + if ParentOfOwner <> nil then + if ParentOfOwner is TKolForm then + begin + if not Equal2( (ParentOfOwner as TKOLForm).Font ) then + (fOwner as TKOLCustomControl).ParentFont := FALSE; + end + else + if ParentOfOwner is TKOLCustomControl then + begin + if not Equal2( (ParentOfOwner as TKOLCustomControl).Font ) then + (fOwner as TKOLCustomControl).ParentFont := FALSE; + end; + end;} + {////////////////////////////////////////// changed by YS 11-Dec-2003} if (fOwner is TKOLCustomControl) then begin ParentOfOwner := (fOwner as TKOLCustomControl).ParentKOLControl; - if ParentOfOwner <> nil then - if ParentOfOwner is TKolForm then - begin - if not Equal2( (ParentOfOwner as TKOLForm).Font ) then - (fOwner as TKOLCustomControl).ParentFont := FALSE; + if (ParentOfOwner <> nil) and not (csLoading in ParentOfOwner.ComponentState) then + if ParentOfOwner is TKOLForm then begin + if not Equal2((ParentOfOwner as TKOLForm).Font) then + (fOwner as TKOLCustomControl).parentFont := False; end - else - if ParentOfOwner is TKOLCustomControl then - begin - if not Equal2( (ParentOfOwner as TKOLCustomControl).Font ) then - (fOwner as TKOLCustomControl).ParentFont := FALSE; + else if ParentOfOwner is TKOLCustomControl then begin + if not Equal2((ParentOfOwner as TKOLCustomControl).Font) then + (fOwner as TKOLCustomControl).parentFont := False; end; - end;} - ////////////////////////////////////////// changed by YS 11-Dec-2003 - if (fOwner is TKOLCustomControl) then - begin - ParentOfOwner := (fOwner as TKOLCustomControl).ParentKOLControl; - if (ParentOfOwner <> nil) and not (csLoading in ParentOfOwner.ComponentState) then - if ParentOfOwner is TKolForm then - begin - if not Equal2( (ParentOfOwner as TKOLForm).Font ) then - (fOwner as TKOLCustomControl).ParentFont := FALSE; - end - else - if ParentOfOwner is TKOLCustomControl then - begin - if not Equal2( (ParentOfOwner as TKOLCustomControl).Font ) then - (fOwner as TKOLCustomControl).ParentFont := FALSE; - end; - ////////////////////////////////////////////////////////////////////////////// - {YS} - {$IFDEF _KOLCtrlWrapper_} - if Assigned((fOwner as TKOLCustomControl).FKOLCtrl) then - begin + ////////////////////////////////////////////////////////////////////////////// + {YS} +{$IFDEF _KOLCtrlWrapper_} + if Assigned((fOwner as TKOLCustomControl).FKOLCtrl) then begin _FKOLCtrl := (fOwner as TKOLCustomControl).FKOLCtrl; - if not Equal2(nil) then - begin - _FKOLCtrl.Font.FontName:=FontName; - _FKOLCtrl.Font.FontHeight:=FontHeight; - _FKOLCtrl.Font.FontWidth:=FontWidth; - _FKOLCtrl.Font.Color:=Self.Color; - _FKOLCtrl.Font.FontStyle:= KOL.TFontStyle( FontStyle ); - _FKOLCtrl.Font.FontCharset:=FontCharset; + if not Equal2(nil) then begin + _FKOLCtrl.Font.FontName := FontName; + _FKOLCtrl.Font.FontHeight := FontHeight; + _FKOLCtrl.Font.FontWidth := FontWidth; + _FKOLCtrl.Font.Color := Self.Color; + _FKOLCtrl.Font.FontStyle := KOL.TFontStyle(FontStyle); + _FKOLCtrl.Font.FontCharset := FontCharset; end else _FKOLCtrl.Font.AssignHandle((fOwner as TKOLCustomControl).GetDefaultControlFont); (fOwner as TKOLCustomControl).Invalidate; - end; - {$ENDIF} -{YS} - (fOwner as TKOLCustomControl).ApplyFontToChildren; - (fOwner as TKOLCustomControl).Change; - (fOwner as TKOLCustomControl).Invalidate; - end // correct by Gendalf - else // + - if (fOwner is TKOLObj) then // + + end; +{$ENDIF} + {YS} + (fOwner as TKOLCustomControl).ApplyFontToChildren; + (fOwner as TKOLCustomControl).Change; + (fOwner as TKOLCustomControl).Invalidate; + end // correct by Gendalf + else {// +} if (fOwner is TKOLObj) then // + (fOwner as TKOLObj).Change; // + finally - fChangingNow := FALSE; + fChangingNow := False; end; end; @@ -21794,8 +17464,7 @@ begin end; if fOwner is TKOLForm then (fOwner as TKOLForm).CollectChildrenWithParentFont - else - if fOwner is TKOLCustomControl then + else if fOwner is TKOLCustomControl then (fOwner as TKOLCustomControl).CollectChildrenWithParentFont; end; @@ -21809,15 +17478,15 @@ begin end; inherited Create; fOwner := AOwner; - fColor := clWindowText; - fFontName := 'Tahoma'; - fFontWidth := 0; - fFontHeight := 0; - fFontCharset := DEFAULT_CHARSET; - fFontPitch := fpDefault; + FColor := clWindowText; + FFontName := 'Tahoma'; + FFontWidth := 0; + FFontHeight := 0; + FFontCharset := DEFAULT_CHARSET; + FFontPitch := fpDefault; FFontOrientation := 0; FFontWeight := 0; - FFontStyle := [ ]; + FFontStyle := []; end; function TKOLFont.Equal2(AFont: TKOLFont): Boolean; @@ -21829,54 +17498,71 @@ begin @@e_signature: end; Result := False; - if AFont = nil then - begin - if Color <> clWindowText then Exit; - if FontStyle <> [ ] then Exit; - if FontHeight <> 0 then Exit; - if FontWidth <> 0 then Exit; - if FontWeight <> 0 then Exit; - if FontOrientation <> 0 then Exit; - if FontCharset <> DEFAULT_CHARSET then Exit; - if FontPitch <> fpDefault then Exit; - if FontQuality <> fqDefault then Exit; - if FontName <> 'System' then Exit; + if AFont = nil then begin + if Color <> clWindowText then + Exit; + if FontStyle <> [] then + Exit; + if FontHeight <> 0 then + Exit; + if FontWidth <> 0 then + Exit; + if FontWeight <> 0 then + Exit; + if FontOrientation <> 0 then + Exit; + if FontCharset <> DEFAULT_CHARSET then + Exit; + if FontPitch <> fpDefault then + Exit; + if FontQuality <> fqDefault then + Exit; + if FontName <> 'System' then + Exit; Result := True; Exit; end; - if Color <> AFont.Color then Exit; - if FontStyle <> AFont.FontStyle then Exit; - if FontHeight <> AFont.FontHeight then Exit; - if FontWidth <> AFont.FontWidth then Exit; - if FontWeight <> AFont.FontWeight then Exit; - if FontName <> AFont.FontName then Exit; - if FontOrientation <> AFont.FontOrientation then Exit; - if FontCharset <> AFont.FontCharset then Exit; - if FontPitch <> AFont.FontPitch then Exit; - if FontQuality <> AFont.FontQuality then Exit; + if Color <> AFont.Color then + Exit; + if FontStyle <> AFont.FontStyle then + Exit; + if FontHeight <> AFont.FontHeight then + Exit; + if FontWidth <> AFont.FontWidth then + Exit; + if FontWeight <> AFont.FontWeight then + Exit; + if FontName <> AFont.FontName then + Exit; + if FontOrientation <> AFont.FontOrientation then + Exit; + if FontCharset <> AFont.FontCharset then + Exit; + if FontPitch <> AFont.FontPitch then + Exit; + if FontQuality <> AFont.FontQuality then + Exit; Result := True; end; -procedure TKOLFont.GenerateCode(SL: TStrings; const AName: String; AFont: TKOLFont); +procedure TKOLFont.GenerateCode(SL: TStrings; const AName: string; AFont: TKOLFont); const - FontPitches: array[ TFontPitch ] of String = ( 'fpDefault', 'fpVariable', 'fpFixed' ); + FontPitches: array[TFontPitch] of string = ('fpDefault', 'fpVariable', 'fpFixed'); var - S: String; - FontPname: String; - Ctl_Name: String; - Lines: Integer; - BFont: TKOLFont; - KF: TKOLForm; - fs: TFontStyles; + s: string; + FontPname: string; + Ctl_Name: string; + Lines: Integer; + BFont: TKOLFont; - procedure AddLine(const S: String); + procedure AddLine(const s: string); begin if (Lines = 0) and (fOwner <> nil) and (fOwner is TKOLCustomControl) then - (fOwner as TKOLCustomControl).BeforeFontChange( SL, AName, ' ' ); - Inc( Lines ); + (fOwner as TKOLCustomControl).BeforeFontChange(SL, AName, ' '); + Inc(Lines); //Rpt( AName + '.' + FontPname + '.' + S + ';' ); - SL.Add( ' ' + AName + '.' + FontPname + '.' + S + ';' ); + SL.Add(' ' + AName + '.' + FontPname + '.' + s + ';'); end; begin @@ -21891,219 +17577,61 @@ begin if (AFont = nil) then BFont := TKOLFont.Create(nil); - KF := nil; Ctl_Name := ''; if Assigned(fOwner) then begin if (fOwner is TKOLForm) then begin - KF := fOwner as TKOLForm; Ctl_Name := 'Form'; - end else if (fOwner is TKOLCustomControl) then begin - KF := (fOwner as TKOLCustomControl).ParentKOLForm; - if Assigned(KF) then - Ctl_Name := (fOwner as TKOLCustomControl).Name; - end; + end end; FontPname := 'Font'; - Lines := 0; + Lines := 0; if Assigned(fOwner) and (fOwner is TKOLCustomControl) then FontPname := (fOwner as TKOLCustomControl).FontPropName; if (Color <> BFont.Color) then begin - if Assigned(KF) and KF.FormCompact then begin - KF.FormAddCtlCommand( Ctl_Name, 'FormSetFontColor', '' ); - KF.FormAddNumParameter( (Color shl 1) or (Color shr 31) ); - end else - AddLine( 'Color := TColor(' + Color2Str( Color ) + ')' ); + AddLine('Color := TColor(' + Color2Str(Color) + ')'); end; if (FontStyle <> BFont.FontStyle) then begin - if (KF <> nil) and KF.FormCompact then - begin - fs := FontStyle; - KF.FormAddCtlCommand( Ctl_Name, 'FormSetFontStyles', '' ); - KF.FormAddNumParameter( PByte( @fs )^ ); - end - else - begin - S := ''; - if fsBold in TFontStyles( FontStyle ) then - S := ' fsBold,'; - if fsItalic in TFontStyles( FontStyle ) then - S := S + ' fsItalic,'; - if fsStrikeout in TFontStyles( FontStyle ) then - S := S + ' fsStrikeOut,'; - if fsUnderline in TFontStyles( FontStyle ) then - S := S + ' fsUnderline,'; - if S <> '' then - S := Trim( Copy( S, 1, Length( S ) - 1 ) ); - AddLine( 'FontStyle := [ ' + S + ' ]' ); - end; + s := ''; + if fsBold in TFontStyles(FontStyle) then + s := ' fsBold,'; + if fsItalic in TFontStyles(FontStyle) then + s := s + ' fsItalic,'; + if fsStrikeout in TFontStyles(FontStyle) then + s := s + ' fsStrikeOut,'; + if fsUnderline in TFontStyles(FontStyle) then + s := s + ' fsUnderline,'; + if s <> '' then + s := Trim(Copy(s, 1, Length(s) - 1)); + AddLine('FontStyle := [ ' + s + ' ]'); end; - if FontHeight <> BFont.FontHeight then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Ctl_Name, 'FormSetFontHeight', '' ); - KF.FormAddNumParameter( FontHeight ); - end else - AddLine( 'FontHeight := ' + IntToStr( FontHeight ) ); - - if FontWidth <> BFont.FontWidth then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Ctl_Name, 'FormSetFontWidth', '' ); - KF.FormAddNumParameter( FontWidth ); - end else - AddLine( 'FontWidth := ' + IntToStr( FontWidth ) ); - - if FontName <> BFont.FontName then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Ctl_Name, 'FormSetFontName', '' ); - KF.FormAddStrParameter( FontName ); - end else - AddLine( 'FontName := ''' + FontName + '''' ); - - if FontOrientation <> BFont.FontOrientation then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Ctl_Name, 'FormSetFontOrientation', '' ); - KF.FormAddNumParameter( FontOrientation ); - end else - AddLine( 'FontOrientation := ' + IntToStr( FontOrientation ) ); - - if FontCharset <> BFont.FontCharset then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Ctl_Name, 'FormSetFontCharset', '' ); - KF.FormAddNumParameter( FontCharset ); - end else - AddLine( 'FontCharset := ' + IntToStr( FontCharset ) ); - - if FontPitch <> BFont.FontPitch then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( Ctl_Name, 'FormSetFontPitch', '' ); - KF.FormAddNumParameter( Integer( FontPitch ) ); - end else - AddLine( 'FontPitch := ' + FontPitches[ FontPitch ] ); - - if AFont = nil then - BFont.Free; - - if Lines > 0 then - if (fOwner <> nil) and (fOwner is TKOLCustomControl) then - (fOwner as TKOLCustomControl).AfterFontChange( SL, AName, ' ' ); -end; - -procedure TKOLFont.P_GenerateCode(SL: TStrings; const AName: String; AFont: TKOLFont); -const - FontPitches: array[ TFontPitch ] of String = ( 'fpDefault', 'fpVariable', 'fpFixed' ); -var BFont: TKOLFont; - FontPname: String; - -var FontInStack: Boolean; - procedure ProvideFontInStack; - begin - if not FontInStack then - begin - {P}SL.Add( ' DUP TControl_.GetFont<1> RESULT' ); - FontInStack := TRUE; - end; - end; - -var Lines: Integer; - - procedure AddLine( const S: String ); - begin - if Lines = 0 then - if (fOwner <> nil) and (fOwner is TKOLCustomControl) then - (fOwner as TKOLCustomControl).P_BeforeFontChange( SL, AName, ' ' ); - Inc( Lines ); - //Rpt( AName + '.' + FontPname + '.' + S + ';' ); - //SL.Add( ' ' + AName + '.' + FontPname + '.' + S + ';' ); - ProvideFontInStack; - {P}SL.Add( S ); - end; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLFont.P_GenerateCode', 0 - @@e_signature: - end; - FontInStack := FALSE; - //Rpt( fOwner.Name ); - BFont := AFont; - if AFont = nil then - BFont := TKOLFont.Create( nil ); - - FontPname := 'Font'; - Lines := 0; - if (fOwner <> nil) and (fOwner is TKOLCustomControl) then - FontPname := (fOwner as TKOLCustomControl).FontPropName; - - if Color <> BFont.Color then - //AddLine( 'Color := ' + Color2Str( Color ) ); - begin - {P}AddLine( ' L($' + IntToHex( Color, 6 ) +')' ); - {P}AddLine( ' C1 TGraphTool.SetColor<2>' ); - end; - - if FontStyle <> BFont.FontStyle then - begin - {P}AddLine( ' L(' + IntToStr( PByte( @ FontStyle )^ ) + ')' ); - {P}AddLine( ' C1 TGraphTool.SetFontStyle<2>' ); - end; if FontHeight <> BFont.FontHeight then - //AddLine( 'FontHeight := ' + IntToStr( FontHeight ) ); - begin - {P}AddLine( ' L(' + IntToStr( FontHeight ) + ')' ); - {P}AddLine( ' L(' + IntToStr( go_FontHeight ) + ')' ); - {P}AddLine( ' C2 TGraphTool.SetInt<3>' ); - end; + AddLine('FontHeight := ' + IntToStr(FontHeight)); + if FontWidth <> BFont.FontWidth then - //AddLine( 'FontWidth := ' + IntToStr( FontWidth ) ); - begin - {P}AddLine( ' L(' + IntToStr( FontWidth ) + ')' ); - {P}AddLine( ' L(' + IntToStr( go_FontWidth ) + ')' ); - {P}AddLine( ' C2 TGraphTool.SetInt<3>' ); - end; + AddLine('FontWidth := ' + IntToStr(FontWidth)); + if FontName <> BFont.FontName then - //AddLine( 'FontName := ''' + FontName + '''' ); - begin - {P}AddLine( ' LoadAnsiStr ' + P_String2Pascal( FontName ) ); - {P}AddLine( ' C2 TGraphTool.SetFontName<2>' ); - {P}AddLine( ' DelAnsiStr' ); - end; + AddLine('FontName := ''' + FontName + ''''); + if FontOrientation <> BFont.FontOrientation then - //AddLine( 'FontOrientation := ' + IntToStr( FontOrientation ) ); - begin - {P}AddLine( ' L(' + IntToStr( FontOrientation ) + ')' ); - {P}AddLine( ' C1 TGraphTool.SetFontOrientation<2>' ); - end; + AddLine('FontOrientation := ' + IntToStr(FontOrientation)); + if FontCharset <> BFont.FontCharset then - //AddLine( 'FontCharset := ' + IntToStr( FontCharset ) ); - begin - {P}AddLine( ' L(' + IntToStr( FontCharset ) + ')' ); - {P}AddLine( ' C1 TGraphTool.SetFontCharset<2>' ); - end; + AddLine('FontCharset := ' + IntToStr(FontCharset)); + if FontPitch <> BFont.FontPitch then - //AddLine( 'FontPitch := ' + FontPitches[ FontPitch ] ); - begin - {P}AddLine( ' L(' + IntToStr( Integer( FontPitch ) ) + ')' ); - {P}AddLine( ' C1 TGraphTool.SetFontPitch<2>' ); - end; - if FontInStack then - SL.Add( ' DEL // Font' ); + AddLine('FontPitch := ' + FontPitches[FontPitch]); if AFont = nil then - BFont.Free; + BFont.free; if Lines > 0 then - if (fOwner <> nil) and (fOwner is TKOLCustomControl) then - (fOwner as TKOLCustomControl).P_AfterFontChange( SL, AName, ' ' ); + if (fOwner <> nil) and (fOwner is TKOLCustomControl) then + (fOwner as TKOLCustomControl).AfterFontChange(SL, AName, ' '); end; procedure TKOLFont.SetColor(const Value: TColor); @@ -22114,17 +17642,16 @@ begin DB 'TKOLFont.SetColor', 0 @@e_signature: end; - if FColor = Value then Exit; - if Value <> clWindowText then - begin - if Assigned( fOwner ) then - if fOwner is TKOLCustomControl then - if (fOwner as TKOLCustomControl).CanNotChangeFontColor then - begin - if not (csLoading in fOwner.ComponentState) then - ShowMessage( 'Can not change font color for some of controls, such as button.' ); - Exit; - end; + if FColor = Value then + Exit; + if Value <> clWindowText then begin + if Assigned(fOwner) then + if fOwner is TKOLCustomControl then + if (fOwner as TKOLCustomControl).CanNotChangeFontColor then begin + if not (csLoading in fOwner.ComponentState) then + Showmessage('Can not change font color for some of controls, such as button.'); + Exit; + end; end; Changing; FColor := Value; @@ -22139,7 +17666,8 @@ begin DB 'TKOLFont.SetFontCharset', 0 @@e_signature: end; - if FFontCharset = Value then Exit; + if FFontCharset = Value then + Exit; Changing; FFontCharset := Value; Change; @@ -22153,13 +17681,14 @@ begin DB 'TKOLFont.SetFontHeight', 0 @@e_signature: end; - if FFontHeight = Value then Exit; + if FFontHeight = Value then + Exit; Changing; FFontHeight := Value; Change; end; -procedure TKOLFont.SetFontName(const Value: String); +procedure TKOLFont.SetFontName(const Value: string); begin asm jmp @@e_signature @@ -22167,7 +17696,8 @@ begin DB 'TKOLFont.SetFontName', 0 @@e_signature: end; - if FFontName = Value then Exit; + if FFontName = Value then + Exit; Changing; FFontName := Value; Change; @@ -22181,10 +17711,13 @@ begin DB 'TKOLFont.SetFontOrientation', 0 @@e_signature: end; - if FFontOrientation = Value then Exit; + if FFontOrientation = Value then + Exit; Changing; - if Value > 3600 then Value := 3600; - if Value < -3600 then Value := -3600; + if Value > 3600 then + Value := 3600; + if Value < -3600 then + Value := -3600; FFontOrientation := Value; Change; end; @@ -22197,7 +17730,8 @@ begin DB 'TKOLFont.SetFontPitch', 0 @@e_signature: end; - if FFontPitch = Value then Exit; + if FFontPitch = Value then + Exit; Changing; FFontPitch := Value; Change; @@ -22211,7 +17745,8 @@ begin DB 'TKOLFont.SetFontQuality', 0 @@e_signature: end; - if FFontQuality = Value then Exit; + if FFontQuality = Value then + Exit; Changing; FFontQuality := Value; Change; @@ -22225,7 +17760,8 @@ begin DB 'TKOLFont.SetFontStyle', 0 @@e_signature: end; - if FFontStyle = Value then Exit; + if FFontStyle = Value then + Exit; Changing; FFontStyle := Value; Change; @@ -22239,15 +17775,18 @@ begin DB 'TKOLFont.SetFontWeight', 0 @@e_signature: end; - if Value < 0 then Value := 0; - if Value > 1000 then Value := 1000; - if FFontWeight = Value then Exit; + if Value < 0 then + Value := 0; + if Value > 1000 then + Value := 1000; + if FFontWeight = Value then + Exit; Changing; FFontWeight := Value; if Value > 0 then - FFontStyle := FFontStyle + [ fsBold ] + FFontStyle := FFontStyle + [fsBold] else - FFontStyle := FFontStyle - [ fsBold ]; + FFontStyle := FFontStyle - [fsBold]; Change; end; @@ -22259,7 +17798,8 @@ begin DB 'TKOLFont.SetFontWidth', 0 @@e_signature: end; - if FFontWidth = Value then Exit; + if FFontWidth = Value then + Exit; Changing; FFontWidth := Value; Change; @@ -22275,14 +17815,17 @@ begin DB 'TKOLProjectBuilder.Edit', 0 @@e_signature: end; - if Component = nil then Exit; - if not(Component is TKOLProject) then Exit; - (Component as TKOLProject).SetBuild( True ); + if Component = nil then + Exit; + if not (Component is TKOLProject) then + Exit; + (Component as TKOLProject).SetBuild(True); end; procedure TKOLProjectBuilder.ExecuteVerb(Index: Integer); -var SL: TStringList; - S: String; +var + SL: TStringList; + s: string; begin asm jmp @@e_signature @@ -22292,24 +17835,22 @@ begin end; //ShowMessage('TKOLProjectBuilder.ExecuteVerb(Index=' + IntToStr(Index) + ')'); case Index of - 0: Edit; - 1: if Component <> nil then - if Component is TKOLProject then - TRY - S := (Component as TKOLProject).sourcePath; - ShellExecute( 0, nil, PChar( S ), nil, nil, SW_SHOW ); - EXCEPT on E: Exception do - begin - SL := TStringList.Create; - TRY - SL := GetCallStack; - ShowMessage( 'Exception 13611: ' + E.Message + ' (' + S + ')' + - #13#10 + SL.Text ); - FINALLY - SL.Free; - END; - end; - END; + 0: Edit; + 1: if Component <> nil then + if Component is TKOLProject then try + s := (Component as TKOLProject).sourcePath; + ShellExecute(0, nil, PChar(s), nil, nil, SW_SHOW); + except on E: Exception do begin + SL := TStringList.Create; + try + SL := GetCallStack; + Showmessage('Exception 13611: ' + E.Message + ' (' + s + ')' + + #13#10 + SL.Text); + finally + SL.free; + end; + end; + end; end; end; @@ -22322,8 +17863,8 @@ begin @@e_signature: end; case Index of - 0: Result := 'Convert to KOL'; - 1: Result := 'Open project folder'; + 0: Result := 'Convert to KOL'; + 1: Result := 'Open project folder'; end; end; @@ -22342,7 +17883,8 @@ end; { TLeftPropEditor } function TLeftPropEditor.VisualValue: string; -var Comp: TPersistent; +var + Comp: TPersistent; begin asm jmp @@e_signature @@ -22351,9 +17893,9 @@ begin @@e_signature: end; Result := Value; - Comp := GetComponent( 0 ); + Comp := GetComponent(0); if Comp is TKOLCustomControl then - Result := IntToStr( (Comp as TKOLCustomControl).actualLeft ); + Result := IntToStr((Comp as TKOLCustomControl).actualLeft); end; procedure TLeftPropEditor.PropDrawValue(ACanvas: TCanvas; @@ -22367,12 +17909,11 @@ begin end; ACanvas.Brush.Color := clBtnFace; ACanvas.Font.Color := clWindowText; - if ASelected then - begin - ACanvas.Brush.Color := clHighLight; + if ASelected then begin + ACanvas.Brush.Color := clHighlight; ACanvas.Font.Color := clHighlightText; end; - ACanvas.TextRect( ARect, ARect.Left, ARect.Top, VisualValue ); + ACanvas.TextRect(ARect, ARect.Left, ARect.Top, VisualValue); end; { TTopPropEditor } @@ -22388,16 +17929,16 @@ begin end; ACanvas.Brush.Color := clBtnFace; ACanvas.Font.Color := clWindowText; - if ASelected then - begin - ACanvas.Brush.Color := clHighLight; + if ASelected then begin + ACanvas.Brush.Color := clHighlight; ACanvas.Font.Color := clHighlightText; end; - ACanvas.TextRect( ARect, ARect.Left, ARect.Top, VisualValue ); + ACanvas.TextRect(ARect, ARect.Left, ARect.Top, VisualValue); end; function TTopPropEditor.VisualValue: string; -var Comp: TPersistent; +var + Comp: TPersistent; begin asm jmp @@e_signature @@ -22406,16 +17947,16 @@ begin @@e_signature: end; Result := Value; - Comp := GetComponent( 0 ); + Comp := GetComponent(0); if Comp is TKOLCustomControl then - Result := IntToStr( (Comp as TKOLCustomControl).actualTop ); + Result := IntToStr((Comp as TKOLCustomControl).actualTop); end; {$ENDIF} { TKOLDataModule } procedure TKOLDataModule.GenerateAdd2AutoFree(SL: TStringList; - const AName: String; AControl: Boolean; Add2AutoFreeProc: String; Obj: TObject); + const AName: string; AControl: Boolean; Add2AutoFreeProc: string; Obj: TObject); begin asm jmp @@e_signature @@ -22424,13 +17965,13 @@ begin @@e_signature: end; if Obj <> nil then - if Obj is TKOLObj then - if (Obj as TKOLObj).NotAutoFree then - Exit; + if Obj is TKOLObj then + if (Obj as TKOLObj).NotAutoFree then + Exit; if Add2AutoFreeProc = '' then Add2AutoFreeProc := 'Add2AutoFree'; if AName <> 'Result' then - SL.Add( ' Result.' + Add2AutoFreeProc + '( ' + AName + ' );' ); + SL.Add(' Result.' + Add2AutoFreeProc + '( ' + AName + ' );'); end; procedure TKOLDataModule.GenerateCreateForm(SL: TStringList); @@ -22453,10 +17994,10 @@ begin @@e_signature: end; if howToDestroy = ddAfterRun then - SL.Add( ' ' + inherited FormName + '.Free;' ); + SL.Add(' ' + inherited formName + '.Free;'); end; -function TKOLDataModule.GenerateINC(const Path: String; +function TKOLDataModule.GenerateINC(const Path: string; var Updated: Boolean): Boolean; begin asm @@ -22465,10 +18006,10 @@ begin DB 'TKOLDataModule.GenerateINC', 0 @@e_signature: end; - Result := inherited GenerateINC( Path, Updated ); + Result := inherited GenerateINC(Path, Updated); end; -function TKOLDataModule.GenerateTransparentInits: String; +function TKOLDataModule.GenerateTransparentInits: string; begin asm jmp @@e_signature @@ -22479,30 +18020,7 @@ begin Result := ''; end; -procedure TKOLDataModule.P_GenerateAdd2AutoFree(SL: TStringList; - const AName: String; AControl: Boolean; Add2AutoFreeProc: String; - Obj: TObject); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLDataModule.P_GenerateAdd2AutoFree', 0 - @@e_signature: - end; - if Obj <> nil then - if Obj is TKOLObj then - if (Obj as TKOLObj).NotAutoFree then - Exit; - if Add2AutoFreeProc = '' then - Add2AutoFreeProc := 'Add2AutoFree'; - if AName <> 'Result' then - //SL.Add( ' Result.' + Add2AutoFreeProc + '( ' + AName + ' );' ); - begin - {P}SL.Add( ' C1 C1 TControl.' + Add2AutoFreeProc + '<2>' ); - end; -end; - -function TKOLDataModule.Result_Form: String; +function TKOLDataModule.Result_Form: string; begin asm jmp @@e_signature @@ -22522,9 +18040,10 @@ begin DB 'TKOLDataModule.SethowToDestroy', 0 @@e_signature: end; - if Value = FhowToDestroy then Exit; + if Value = FhowToDestroy then + Exit; FhowToDestroy := Value; - Change( Self ); + Change(Self); if not (csLoading in ComponentState) then ChangeDPR; end; @@ -22538,11 +18057,11 @@ begin @@e_signature: end; FOnCreate := Value; - Change( Self ); + Change(Self); end; procedure TKOLDataModule.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); + Prefix: string); begin asm jmp @@e_signature @@ -22550,13 +18069,13 @@ begin DB 'TKOLDataModule.SetupFirst', 0 @@e_signature: end; - SetupName( SL, AName, AParent, Prefix ); + SetupName(SL, AName, AParent, Prefix); if howToDestroy = ddOnAppletDestroy then - SL.Add( Prefix + 'Applet.Add2AutoFree( ' + inherited FormName + ' );' ); + SL.Add(Prefix + 'Applet.Add2AutoFree( ' + inherited formName + ' );'); end; procedure TKOLDataModule.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); + Prefix: string); begin asm jmp @@e_signature @@ -22570,16 +18089,18 @@ end; { TKOLObjectCompEditor } ////////////////////////////////////////////////////////////////////////////////// -{$IFDEF _D6orHigher} // -procedure TKOLObjectCompEditor.CheckEdit(const PropertyEditor: IProperty); // -{$ELSE} // +{$IFDEF _D6orHigher} // + +procedure TKOLObjectCompEditor.CheckEdit(const PropertyEditor: IProperty); // +{$ELSE} // ////////////////////////////////////////////////////////////////////////////////// + procedure TKOLObjectCompEditor.CheckEdit(PropertyEditor: TPropertyEditor); var FreeEditor: Boolean; -////////////////////////////////////////////////////////////////////////////////// -{$ENDIF} // -////////////////////////////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////////////////////////////// +{$ENDIF} // + ////////////////////////////////////////////////////////////////////////////////// begin asm jmp @@e_signature @@ -22591,30 +18112,34 @@ begin FreeEditor := True; {$ENDIF} try -//*/////////////////////////////////////////////////////////////////////////////////////////////// -// if FContinue then EditProperty(PropertyEditor, FContinue, FreeEditor); -//*/////////////////////////////////////////////////////////////////////////////////////////////// - if FContinue then EditProperty(PropertyEditor, FContinue{$IFNDEF _D6orHigher}, FreeEditor{$ENDIF}); // -//*/////////////////////////////////////////////////////////////////////////////////////////////// + //*/////////////////////////////////////////////////////////////////////////////////////////////// + // if FContinue then EditProperty(PropertyEditor, FContinue, FreeEditor); + //*/////////////////////////////////////////////////////////////////////////////////////////////// + if FContinue then + EditProperty(PropertyEditor, FContinue{$IFNDEF _D6orHigher}, FreeEditor{$ENDIF}); // + //*/////////////////////////////////////////////////////////////////////////////////////////////// finally -//*/////////////////////////////////////////////// -{$IFNDEF _D6orHigher} // -//*/////////////////////////////////////////////// - if FreeEditor then PropertyEditor.Free; -//*/////////////////////////////////////////////// -{$ENDIF} // -//*/////////////////////////////////////////////// + //*/////////////////////////////////////////////// +{$IFNDEF _D6orHigher} // + //*/////////////////////////////////////////////// + if FreeEditor then + PropertyEditor.free; + //*/////////////////////////////////////////////// +{$ENDIF} // + //*/////////////////////////////////////////////// end; end; ////////////////////////////////////////////////////////////////////////////////// -{$IFDEF _D6orHigher} // -procedure TKOLObjectCompEditor.CountEvents(const PropertyEditor: IProperty ); // -{$ELSE} // +{$IFDEF _D6orHigher} // + +procedure TKOLObjectCompEditor.CountEvents(const PropertyEditor: IProperty); // +{$ELSE} // ////////////////////////////////////////////////////////////////////////////////// -procedure TKOLObjectCompEditor.CountEvents( PropertyEditor: TPropertyEditor); + +procedure TKOLObjectCompEditor.CountEvents(PropertyEditor: TPropertyEditor); ////////////////////////////////////////////////////////////////////////////////// -{$ENDIF} // +{$ENDIF} // ////////////////////////////////////////////////////////////////////////////////// begin asm @@ -22623,24 +18148,24 @@ begin DB 'TKOLObjectCompEditor.CountEvents', 0 @@e_signature: end; - {$IFDEF _D6orHigher} - if Supports( PropertyEditor, IMethodProperty ) then - {$ELSE} +{$IFDEF _D6orHigher} + if Supports(PropertyEditor, IMethodProperty) then +{$ELSE} if PropertyEditor is TMethodProperty then - {$ENDIF} - Inc( FCount ); - {$IFNDEF _D6orHigher} - PropertyEditor.Free; - {$ENDIF} +{$ENDIF} + Inc(FCount); +{$IFNDEF _D6orHigher} + PropertyEditor.free; +{$ENDIF} end; procedure TKOLObjectCompEditor.Edit; var - {$IFDEF _D6orHigher} - Components: IDesignerSelections; - {$ELSE} - Components: TDesignerSelectionList; - {$ENDIF} +{$IFDEF _D6orHigher} + Components: IDesignerSelections; +{$ELSE} + Components: TDesignerSelectionList; +{$ENDIF} begin asm jmp @@e_signature @@ -22653,32 +18178,30 @@ begin inherited; Exit; end;} - {$IFDEF _D6orHigher} - Components := CreateSelectionList; - {$ELSE} - Components := TDesignerSelectionList.Create; - {$ENDIF} +{$IFDEF _D6orHigher} + Components := CreateSelectionList; +{$ELSE} + Components := TDesignerSelectionList.Create; +{$ENDIF} try BestEventName := ''; if Component is TKOLObj then BestEventName := (Component as TKOLObj).BestEventName - else - if Component is TKOLApplet then + else if Component is TKOLApplet then BestEventName := (Component as TKOLApplet).BestEventName - else - if Component is TKOLCustomControl then + else if Component is TKOLCustomControl then BestEventName := (Component as TKOLCustomControl).BestEventName; FContinue := True; -////////////////////////////////////////////////////////// - {$IFDEF _D6orHigher} // + ////////////////////////////////////////////////////////// +{$IFDEF _D6orHigher} // Components.Add(Component); - {$ELSE} // -////////////////////////////////////////////////////////// +{$ELSE} // + ////////////////////////////////////////////////////////// Components.Add(Component); -////////////////////////////////////////////////////////// - {$ENDIF} // -////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////// +{$ENDIF} // + ////////////////////////////////////////////////////////// FFirst := nil; FBest := nil; try @@ -22686,62 +18209,62 @@ begin //ShowMessage( 'Found ' + IntToStr( FCount ) + ' events' ); GetComponentProperties(Components, tkAny, Designer, CheckEdit); if FContinue then - if Assigned(FBest) then - begin + if Assigned(FBest) then begin FBest.Edit; //ShowMessage( 'Best found ' + FBest.GetName ); end - else - if Assigned(FFirst) then - begin + else if Assigned(FFirst) then begin FFirst.Edit; //ShowMessage( 'First found ' + FFirst.GetName ); end; finally - {$IFDEF _D6orHigher} +{$IFDEF _D6orHigher} FFirst := nil; FBest := nil; - {$ELSE} - FFirst.Free; - FBest.Free; - {$ENDIF} +{$ELSE} + FFirst.free; + FBest.free; +{$ENDIF} end; finally - {$IFDEF _D6orHigher} +{$IFDEF _D6orHigher} Components := nil; - {$ELSE} - Components.Free; - {$ENDIF} +{$ELSE} + Components.free; +{$ENDIF} //ShowMessage( 'FREE' ); end; end; ////////////////////////////////////////////////////////////////////////////////////////////////////////// -{$IFDEF _D6orHigher} // -procedure TKOLObjectCompEditor.EditProperty(const PropertyEditor: IProperty; var Continue: Boolean); // +{$IFDEF _D6orHigher} // + +procedure TKOLObjectCompEditor.EditProperty(const PropertyEditor: IProperty; var Continue: Boolean); // {$ELSE} ////////////////////////////////////////////////////////////////////////////////////////////////////////// + procedure TKOLObjectCompEditor.EditProperty( PropertyEditor: TPropertyEditor; var Continue, FreeEditor: Boolean); ////////////////////////// -{$ENDIF} // +{$ENDIF} // ////////////////////////// var - PropName: string; + Propname: string; BestName: string; procedure ReplaceBest; begin - {$IFDEF _D6orHigher} +{$IFDEF _D6orHigher} FBest := nil; - {$ELSE} - FBest.Free; - {$ENDIF} +{$ELSE} + FBest.free; +{$ENDIF} FBest := PropertyEditor; - if FFirst = FBest then FFirst := nil; - {$IFNDEF _D6orHigher} + if FFirst = FBest then + FFirst := nil; +{$IFNDEF _D6orHigher} FreeEditor := False; - {$ENDIF} +{$ENDIF} end; begin @@ -22756,29 +18279,27 @@ begin inherited; Exit; end;} - {$IFDEF _D6orHigher} +{$IFDEF _D6orHigher} if not Assigned(FFirst) and Supports(PropertyEditor, IMethodProperty) then - {$ELSE} +{$ELSE} if not Assigned(FFirst) and (PropertyEditor is TMethodProperty) then - {$ENDIF} - begin - {$IFNDEF _D6orHigher} +{$ENDIF}begin +{$IFNDEF _D6orHigher} FreeEditor := False; - {$ENDIF} +{$ENDIF} FFirst := PropertyEditor; end; - PropName := PropertyEditor.GetName; + Propname := PropertyEditor.GetName; BestName := BestEventName; - {$IFDEF _D6orHigher} - if Supports( PropertyEditor, IMethodProperty ) then - {$ELSE} +{$IFDEF _D6orHigher} + if Supports(PropertyEditor, IMethodProperty) then +{$ELSE} if PropertyEditor is TMethodProperty then - {$ENDIF} - if (CompareText(PropName, BestName ) = 0) or (FCount = 1) then - ReplaceBest - else - if (BestName = '') and - (CompareText( PropName, 'ONDESTROY' ) <> 0) then +{$ENDIF} + if (CompareText(Propname, BestName) = 0) or (FCount = 1) then + ReplaceBest + else if (BestName = '') and + (CompareText(Propname, 'ONDESTROY') <> 0) then ReplaceBest; end; @@ -22796,8 +18317,7 @@ begin end; FormMethodName := GetValue; if (FormMethodName = '') or - Designer.MethodFromAncestor(GetMethodValue) then - begin + Designer.MethodFromAncestor(GetMethodValue) then begin if FormMethodName = '' then FormMethodName := GetFormMethodName; if FormMethodName = '' then @@ -22837,13 +18357,12 @@ begin DB 'BuildKOLProject', 0 @@e_signature: end; - Result := FALSE; + Result := False; if KOLProject <> nil then - Result := KOLProject.ConvertVCL2KOL( FALSE, TRUE ); - if not Result then - begin - ShowMessage( 'Main form is not opened, and changing of the project dpr file ' + - 'is not finished. To apply changes, open and show main form.' ); + Result := KOLProject.ConvertVCL2KOL(False, True); + if not Result then begin + Showmessage('Main form is not opened, and changing of the project dpr file ' + + 'is not finished. To apply changes, open and show main form.'); end; end; @@ -22857,7 +18376,7 @@ begin DB 'TCursorPropEditor.GetAttributes', 0 @@e_signature: end; - Result := [ paValueList, paSortList ]; + Result := [paValueList, paSortList]; end; function TCursorPropEditor.GetValue: string; @@ -22873,12 +18392,13 @@ end; procedure TCursorPropEditor.GetValues(Proc: TGetStrProc); const - Cursors: array[ 0..16 ] of String = ( ' ', 'IDC_ARROW', 'IDC_IBEAM', 'IDC_WAIT', - 'IDC_CROSS', 'IDC_UPARROW', 'IDC_SIZE', 'IDC_ICON', 'IDC_SIZENWSE', 'IDC_SIZENESW', - 'IDC_SIZEWE', 'IDC_SIZENS', 'IDC_SIZEALL', 'IDC_NO', 'IDC_HAND', 'IDC_APPSTARTING', - 'IDC_HELP' ); -var I: Integer; - Found: Boolean; + Cursors: array[0..16] of string = (' ', 'IDC_ARROW', 'IDC_IBEAM', 'IDC_WAIT', + 'IDC_CROSS', 'IDC_UPARROW', 'IDC_SIZE', 'IDC_ICON', 'IDC_SIZENWSE', 'IDC_SIZENESW', + 'IDC_SIZEWE', 'IDC_SIZENS', 'IDC_SIZEALL', 'IDC_NO', 'IDC_HAND', 'IDC_APPSTARTING', + 'IDC_HELP'); +var + I: Integer; + Found: Boolean; begin asm jmp @@e_signature @@ -22886,17 +18406,16 @@ begin DB 'TCursorPropEditor.GetValues', 0 @@e_signature: end; - Found := FALSE; - for I := 0 to High( Cursors ) do - if Trim( Value ) = Trim( Cursors[ I ] ) then - begin - Found := TRUE; - break; + Found := False; + for I := 0 to High(Cursors) do + if Trim(Value) = Trim(Cursors[I]) then begin + Found := True; + Break; end; if not Found then - Proc( Value ); - for I := 0 to High( Cursors ) do - Proc( Cursors[ I ] ); + Proc(Value); + for I := 0 to High(Cursors) do + Proc(Cursors[I]); end; procedure TCursorPropEditor.SetValue(const Value: string); @@ -22907,7 +18426,7 @@ begin DB 'TCursorPropEditor.SetValue', 0 @@e_signature: end; - SetStrValue( Trim( Value ) ); + SetStrValue(Trim(Value)); end; { TKOLFrame } @@ -22920,7 +18439,7 @@ begin DB 'TKOLFrame.AutoCaption', 0 @@e_signature: end; - Result := FALSE; + Result := False; end; constructor TKOLFrame.Create(AOwner: TComponent); @@ -22932,13 +18451,13 @@ begin @@e_signature: end; inherited; - edgeStyle := esNone; - FParentFont := TRUE; - FParentColor := TRUE; + EdgeStyle := esNone; + FParentFont := True; + FParentColor := True; end; procedure TKOLFrame.GenerateAdd2AutoFree(SL: TStringList; - const AName: String; AControl: Boolean; Add2AutoFreeProc: String; Obj: TObject); + const AName: string; AControl: Boolean; Add2AutoFreeProc: string; Obj: TObject); begin asm jmp @@e_signature @@ -22947,19 +18466,21 @@ begin @@e_signature: end; if Obj <> nil then - if Obj is TKOLObj then - if (Obj as TKOLObj).NotAutoFree then - Exit; + if Obj is TKOLObj then + if (Obj as TKOLObj).NotAutoFree then + Exit; if Add2AutoFreeProc = '' then Add2AutoFreeProc := 'Add2AutoFree'; if not AControl then - SL.Add( ' Result.Form.' + Add2AutoFreeProc + '( ' + AName + ' );' ); + SL.Add(' Result.Form.' + Add2AutoFreeProc + '( ' + AName + ' );'); end; procedure TKOLFrame.GenerateCreateForm(SL: TStringList); -const EdgeStyles: array[ TEdgeStyle ] of String = ( - 'esRaised', 'esLowered', 'esNone', 'esTransparent', 'esSolid' ); -var S: String; +const + EdgeStyles: array[TEdgeStyle] of string = ( + 'esRaised', 'esLowered', 'esNone', 'esTransparent', 'esSolid'); +var + s: string; begin asm jmp @@e_signature @@ -22967,23 +18488,20 @@ begin DB 'TKOLFrame.GenerateCreateForm', 0 @@e_signature: end; - S := GenerateTransparentInits; - SL.Add( ' Result.Form := NewPanel( AParent, ' + EdgeStyles[ edgeStyle ] + ' )' + - '.MarkPanelAsForm' + - S + ';' ); - SL.Add( ' Result.Form.DF.FormAddress := @ Result.Form;' ); - SL.Add( ' Result.Form.DF.FormObj := Result;' ); + s := GenerateTransparentInits; + SL.Add(' Result.Form := NewPanel( AParent, ' + EdgeStyles[EdgeStyle] + ' )' + + '.MarkPanelAsForm' + + s + ';'); + SL.Add(' Result.Form.DF.FormAddress := @ Result.Form;'); + SL.Add(' Result.Form.DF.FormObj := Result;'); if Caption <> '' then - if AssignTextToControls then - SL.Add( ' Result.Form.Caption := ' + StringConstant( 'Caption', Caption ) + ';' ); - if FormCompact then - SL.Add( ' //--< place to call FormCreateParameters >--//' ); - if FormCompact then - ClearBeforeGenerateForm( SL ); + if AssignTextToControls then + SL.Add(' Result.Form.Caption := ' + StringConstant('Caption', Caption) + ';'); end; -function TKOLFrame.GenerateTransparentInits: String; -var W, H: Integer; +function TKOLFrame.GenerateTransparentInits: string; +var + W, H: Integer; begin asm jmp @@e_signature @@ -22992,19 +18510,21 @@ begin @@e_signature: end; Result := ''; - if FLocked then Exit; + if FLocked then + Exit; if Align <> caNone then - Result := '.SetAlign( ' + AlignValues[ Align ] + ')'; + Result := '.SetAlign( ' + AlignValues[Align] + ')'; - if Align <> caNone then - begin + if Align <> caNone then begin W := Width; H := Height; - if Align in [ caLeft, caRight ] then H := 0; - if Align in [ caTop, caBottom ] then W := 0; - Result := Result + '.SetSize( ' + IntToStr( W ) + ', ' + - IntToStr( H ) + ' )'; + if Align in [caLeft, caRight] then + H := 0; + if Align in [caTop, caBottom] then + W := 0; + Result := Result + '.SetSize( ' + IntToStr(W) + ', ' + + IntToStr(H) + ' )'; end; if CenterOnParent and (Align = caNone) then @@ -23014,7 +18534,7 @@ begin Result := Result + '.BringToFront'; if HelpContext <> 0 then - Result := Result + '.AssignHelpContext( ' + IntToStr( HelpContext ) + ' )'; + Result := Result + '.AssignHelpContext( ' + IntToStr(HelpContext) + ' )'; end; @@ -23028,8 +18548,8 @@ begin end; Result := fFrameCaption; if Owner is TForm then - if (Owner as TForm).Caption <> Result then - (Owner as TForm).Caption := Result; + if (Owner as TForm).Caption <> Result then + (Owner as TForm).Caption := Result; end; function TKOLFrame.GetFrameHeight: Integer; @@ -23040,7 +18560,7 @@ begin DB 'TKOLFrame.GetFrameHeight', 0 @@e_signature: end; - Result := inherited Bounds.Height; + Result := inherited bounds.Height; end; function TKOLFrame.GetFrameWidth: Integer; @@ -23051,161 +18571,7 @@ begin DB 'TKOLFrame.GetFrameHeight', 0 @@e_signature: end; - Result := inherited Bounds.Width; -end; - -procedure TKOLFrame.P_GenerateAdd2AutoFree(SL: TStringList; - const AName: String; AControl: Boolean; Add2AutoFreeProc: String; - Obj: TObject); -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLFrame.P_GenerateAdd2AutoFree', 0 - @@e_signature: - end; - if Obj <> nil then - if Obj is TKOLObj then - if (Obj as TKOLObj).NotAutoFree then - Exit; - if Add2AutoFreeProc = '' then - Add2AutoFreeProc := 'Add2AutoFree'; - if not AControl then - //SL.Add( ' Result.Form.' + Add2AutoFreeProc + '( ' + AName + ' );' ); - {P}SL.Add( ' LoadSELF C1 TObj.Add2AutoFree<2>' ); -end; - -procedure TKOLFrame.P_GenerateCreateForm(SL: TStringList); -var S: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLFrame.P_GenerateCreateForm', 0 - @@e_signature: - end; - S := P_GenerateTransparentInits; - - //SL.Add( ' Result.Form := NewPanel( AParent, ' + EdgeStyles[ edgeStyle ] + ' )' + - // S + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( edgeStyle ) ) + ')' + - ' C3 NewPanel<2> RESULT DUP LoadSELF AddByte_Store #T' + - FormName + '.Form' + - #13#10 + S ); - if Caption <> '' then - //SL.Add( ' Result.Form.Caption := ' + StringConstant( 'Caption', Caption ) + ';' ); - {P}SL.Add( P_StringConstant( 'Caption', Caption ) + - ' C2 TControl_.SetCaption<2> DelAnsiStr' ); -end; - -function TKOLFrame.P_GenerateTransparentInits: String; -var W, H: Integer; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLFrame.P_GenerateTransparentInits', 0 - @@e_signature: - end; - Result := ''; - if FLocked then Exit; - - if Align <> caNone then - //Result := '.SetAlign( ' + AlignValues[ Align ] + ')'; - {P}Result := Result + #13#10' L(' + IntToStr( Integer( Align ) ) + ')' + - ' C1 TControl_.SetAlign<2>'; - - if Align <> caNone then - begin - W := Width; - H := Height; - if Align in [ caLeft, caRight ] then H := 0; - if Align in [ caTop, caBottom ] then W := 0; - //Result := Result + '.SetSize( ' + IntToStr( W ) + ', ' + IntToStr( H ) + ' )'; - {P}Result := Result + #13#10' L(' + IntToStr( H ) + ')' + - ' L(' + IntToStr( W ) + ')' + - ' C2 TControl_.SetSize<3>'; - end; - - if CenterOnParent and (Align = caNone) then - //Result := Result + '.CenterOnParent'; - {P}Result := Result + #13#10' DUP TControl_.CenterOnParent<1>'; - - if zOrderTopmost then - //Result := Result + '.BringToFront'; - {P}Result := Result + #13#10' DUP TControl_.BringToFront<1>'; - - if HelpContext <> 0 then - //Result := Result + '.AssignHelpContext( ' + IntToStr( HelpContext ) + ' )'; - {P}Result := Result + #13#10' L(' + IntToStr( HelpContext ) + ')' + - ' C1 TControl_.AssignHelpContext<2>'; - -end; - -procedure TKOLFrame.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - inherited; - if not ParentFont then - Font.P_GenerateCode( SL, AName, nil ); - if not ParentColor then - //SL.Add( Prefix + AName + '.Color := ' + ColorToString( Color ) + ';' ); - {P}SL.Add( ' L($' + Int2Hex( Color, 6 ) + ') C1 TControl_.SetCtlColor<2>' ); -end; - -procedure TKOLFrame.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var S: String; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLFrame.P_SetupLast', 0 - @@e_signature: - end; - if not FLocked then - begin - S := ''; - if CenterOnScreen then - //S := Prefix + AName + '.CenterOnParent'; - begin - {P}S := S + ' DUP TControl.CenterOnParent<1>'; - end; - if not CanResize then - begin - {if S = '' then - S := Prefix + AName; - S := S + '.CanResize := False';} - {P}S := S + ' L(0) C1 TControl_.SetCanResize<2>'; - end; - if S <> '' then - //SL.Add( S + ';' ); - {P}SL.Add( S ); - if Assigned( FpopupMenu ) then - //SL.Add( Prefix + AName + '.SetAutoPopupMenu( Result.' + FpopupMenu.Name + - // ' );' ); - begin - {P}SL.Add( ' LoadSELF AddWord_LoadRef ##T' + FormName + '.' + FpopupMenu.Name ); - {P}SL.Add( ' C1 TControl.SetAutoPopupMenu<2>' ); - end; - if @ OnFormCreate <> nil then - begin - //SL.Add( Prefix + 'Result.' + (Owner as TForm).MethodName( @ OnFormCreate ) + '( Result );' ); - {P}SL.Add( ' LoadSELF DUP T' + FormName + '.' + - (Owner as TForm).MethodName( @ OnFormCreate ) + '<2>' ); - end; - {YS} - if FborderStyle = fbsDialog then - //SL.Add( Prefix + AName + '.Icon := THandle(-1);' ); - {P}SL.Add( ' L(-1) C1 TControl_.SetIcon<2>' ); - {YS} - - //SL.Add( ' Result.Form.CreateWindow;' ); - {P}SL.Add( ' LoadSELF AddByte_LoadRef #T' + FormName + - '.Form TControl_.CreateWindow<1>' ); - - {P}SL.Add( ' DEL(4) EXIT' ); - end; + Result := inherited bounds.Width; end; procedure TKOLFrame.SetAlign(const Value: TKOLAlign); @@ -23216,8 +18582,8 @@ begin DB 'TKOLFrame.SetAlign', 0 @@e_signature: end; - FAlign := Value; - Change( Self ); + fAlign := Value; + Change(Self); end; procedure TKOLFrame.SetCenterOnParent(const Value: Boolean); @@ -23228,8 +18594,8 @@ begin DB 'TKOLFrame.SetCenterOnParent', 0 @@e_signature: end; - FCenterOnParent := Value; - Change( Self ); + fCenterOnParent := Value; + Change(Self); end; procedure TKOLFrame.SetEdgeStyle(const Value: TEdgeStyle); @@ -23241,10 +18607,10 @@ begin @@e_signature: end; FEdgeStyle := Value; - Change( Self ); + Change(Self); end; -procedure TKOLFrame.SetFrameCaption(const Value: String); +procedure TKOLFrame.SetFrameCaption(const Value: string); begin asm jmp @@e_signature @@ -23253,7 +18619,7 @@ begin @@e_signature: end; fFrameCaption := Value; - Change( Self ); + Change(Self); end; procedure TKOLFrame.SetFrameHeight(const Value: Integer); @@ -23264,7 +18630,7 @@ begin DB 'TKOLFrame.SetFrameHeight', 0 @@e_signature: end; - inherited Bounds.Height := Value; + inherited bounds.Height := Value; end; procedure TKOLFrame.SetFrameWidth(const Value: Integer); @@ -23275,33 +18641,33 @@ begin DB 'TKOLFrame.SetFrameWidth', 0 @@e_signature: end; - inherited Bounds.Width := Value; + inherited bounds.Width := Value; end; -procedure TKOLFrame.SetParentColor(const Value: Boolean); +procedure TKOLFrame.SetparentColor(const Value: Boolean); begin FParentColor := Value; - Change( Self ); + Change(Self); end; procedure TKOLFrame.SetParentFont(const Value: Boolean); begin FParentFont := Value; - Change( Self ); + Change(Self); end; procedure TKOLFrame.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); + Prefix: string); begin inherited; - if not ParentFont then - Font.GenerateCode( SL, AName, nil ); - if not ParentColor then - SL.Add( Prefix + AName + '.Color := TColor(' + ColorToString( Color ) + ');' ); + if not parentFont then + Font.GenerateCode(SL, AName, nil); + if not parentColor then + SL.Add(Prefix + AName + '.Color := TColor(' + ColorToString(Color) + ');'); end; procedure TKOLFrame.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); + Prefix: string); begin asm jmp @@e_signature @@ -23310,7 +18676,7 @@ begin @@e_signature: end; inherited; - SL.Add( ' Result.Form.CreateWindow;' ); + SL.Add(' Result.Form.CreateWindow;'); end; procedure TKOLFrame.SetzOrderTopmost(const Value: Boolean); @@ -23322,7 +18688,7 @@ begin @@e_signature: end; FzOrderTopmost := Value; - Change( Self ); + Change(Self); end; { TKOLMDIChild } @@ -23335,11 +18701,12 @@ begin DB 'TKOLMDIChild.DoNotGenerateSetPosition', 0 @@e_signature: end; - Result := TRUE; + Result := True; end; procedure TKOLMDIChild.GenerateCreateForm(SL: TStringList); -var S: String; +var + s: string; begin asm jmp @@e_signature @@ -23347,12 +18714,12 @@ begin DB 'TKOLMDIChild.GenerateCreateForm', 0 @@e_signature: end; - S := GenerateTransparentInits; - SL.Add( ' Result.Form := NewMDIChild( AParent, ' + StringConstant( 'Caption', Caption ) + - ' )' + S + ';' ); + s := GenerateTransparentInits; + SL.Add(' Result.Form := NewMDIChild( AParent, ' + StringConstant('Caption', Caption) + + ' )' + s + ';'); end; -procedure TKOLMDIChild.SetParentForm(const Value: String); +procedure TKOLMDIChild.SetParentForm(const Value: string); begin asm jmp @@e_signature @@ -23360,9 +18727,10 @@ begin DB 'TKOLMDIChild.SetParentForm', 0 @@e_signature: end; - if FParentForm = Value then Exit; + if FParentForm = Value then + Exit; FParentForm := Value; - Change( Self ); + Change(Self); end; { TParentMDIFormPropEditor } @@ -23375,7 +18743,7 @@ begin DB 'TKOLMDIFormPropEditor.GetAttributes', 0 @@e_signature: end; - Result := [ paValueList, paSortList ]; + Result := [paValueList, paSortList]; end; function TParentMDIFormPropEditor.GetValue: string; @@ -23390,12 +18758,13 @@ begin end; procedure TParentMDIFormPropEditor.GetValues(Proc: TGetStrProc); -var I, J: Integer; - UN, FormName: String; - MI: TIModuleInterface; - FI: TIFormInterface; - CI, ChI: TIComponentInterface; - IsMDIForm: Boolean; +var + I, j: Integer; + UN, formName: string; + MI: TIModuleInterface; + FI: TIFormInterface; + CI, ChI: TIComponentInterface; + IsMDIForm: Boolean; begin asm jmp @@e_signature @@ -23403,42 +18772,36 @@ begin DB 'TKOLMDIFormPropEditor.GetValues', 0 @@e_signature: end; - for I := 0 to ToolServices.GetUnitCount-1 do - begin - UN := ToolServices.GetUnitName( I ); - MI := ToolServices.GetModuleInterface( UN ); - if MI <> nil then - TRY - FI := MI.GetFormInterface; - if FI <> nil then - TRY - CI := FI.GetFormComponent; - if CI <> nil then - TRY - IsMDIForm := FALSE; - FormName := ''; - for J := 0 to CI.GetComponentCount-1 do - begin - ChI := CI.GetComponent( J ); - if ChI.GetComponentType = 'TKOLForm' then - CI.GetPropValueByName( 'Name', FormName ) - else - if ChI.GetComponentType = 'TKOLMDIClient' then - IsMDIForm := TRUE; - if IsMDIForm and (FormName <> '') then - break; - end; - if IsMDIForm and (FormName <> '') then - Proc( FormName ); - FINALLY - CI.Free; - END; - FINALLY - FI.Free; - END; - FINALLY - MI.Free; - END; + for I := 0 to ToolServices.GetUnitCount - 1 do begin + UN := ToolServices.GetUnitName(I); + MI := ToolServices.GetModuleInterface(UN); + if MI <> nil then try + FI := MI.GetFormInterface; + if FI <> nil then try + CI := FI.GetFormComponent; + if CI <> nil then try + IsMDIForm := False; + formName := ''; + for j := 0 to CI.GetComponentCount - 1 do begin + ChI := CI.GetComponent(j); + if ChI.GetComponentType = 'TKOLForm' then + CI.GetPropValueByName('Name', formName) + else if ChI.GetComponentType = 'TKOLMDIClient' then + IsMDIForm := True; + if IsMDIForm and (formName <> '') then + Break; + end; + if IsMDIForm and (formName <> '') then + Proc(formName); + finally + CI.free; + end; + finally + FI.free; + end; + finally + MI.free; + end; end; end; @@ -23450,12 +18813,12 @@ begin DB 'TParentMDIFormPropEditor.SetValue', 0 @@e_signature: end; - SetStrValue( Trim( Value ) ); + SetStrValue(Trim(Value)); end; { TKOLMenu } -procedure TKOLMenu.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLMenu.AssignEvents(SL: TStringList; const AName: string); begin asm jmp @@e_signature @@ -23464,8 +18827,8 @@ begin @@e_signature: end; inherited; - DoAssignEvents( SL, AName, [ 'OnUncheckRadioItem', 'OnMeasureItem', 'OnDrawItem' ], - [ @ OnUncheckRadioItem, @ OnMeasureItem, @ OnDrawItem ] ); + DoAssignEvents(SL, AName, ['OnUncheckRadioItem', 'OnMeasureItem', 'OnDrawItem'], + [@OnUncheckRadioItem, @OnMeasureItem, @OnDrawItem]); end; procedure TKOLMenu.Change; @@ -23479,7 +18842,7 @@ begin inherited; UpdateDesign; if (Owner <> nil) and (Owner is TKOLForm) then - (Owner as TKOLForm).Change( Owner ); + (Owner as TKOLForm).Change(Owner); end; constructor TKOLMenu.Create(AOwner: TComponent); @@ -23491,7 +18854,7 @@ begin @@e_signature: end; inherited; - FgenerateConstants := TRUE; + FgenerateConstants := True; FItems := TList.Create; NeedFree := False; Fshowshortcuts := True; @@ -23499,8 +18862,9 @@ begin end; procedure TKOLMenu.DefineProperties(Filer: TFiler); -var I: Integer; - MI: TKOLMenuItem; +var + I: Integer; + MI: TKOLMenuItem; begin asm jmp @@e_signature @@ -23510,22 +18874,22 @@ begin end; inherited; //--Filer.DefineProperty( 'Items', LoadItems, SaveItems, Count > 0 ); - Filer.DefineProperty( 'ItemCount', LoadItemCount, SaveItemCount, True ); + Filer.DefineProperty('ItemCount', LoadItemCount, SaveItemCount, True); UpdateDisable; - for I := 0 to FItemCount - 1 do - begin + for I := 0 to FItemCount - 1 do begin if FItems.Count <= I then - MI := TKOLMenuItem.Create( Self, nil, nil ) + MI := TKOLMenuItem.Create(Self, nil, nil) else - MI := FItems[ I ]; - MI.DefProps( 'Item' + IntToStr( I ), Filer ); + MI := FItems[I]; + MI.DefProps('Item' + IntToStr(I), Filer); end; if not (csDestroying in ComponentState) then UpdateEnable; end; destructor TKOLMenu.Destroy; -var I: Integer; +var + I: Integer; begin asm jmp @@e_signature @@ -23535,45 +18899,47 @@ begin end; //ShowMessage( 'enter: KOLMenu.Destroy' ); //!!!//OnMenuItem := nil; - ActiveDesign.Free; + ActiveDesign.free; //ShowMessage( 'AD freed' ); - for I := FItems.Count - 1 downto 0 do - begin - TObject( FItems[ I ] ).Free; + for I := FItems.Count - 1 downto 0 do begin + TObject(FItems[I]).free; end; //ShowMessage( 'Items freed' ); - FItems.Free; + FItems.free; //ShowMessage( 'FItems freed' ); inherited; //ShowMessage( 'leave: KOLMenu.Destroy' ); end; procedure TKOLMenu.DoGenerateConstants(SL: TStringList); -var N: Integer; +var + N: Integer; - procedure GenItemConst( MI: TKOLMenuItem ); - var J: Integer; + procedure GenItemConst(MI: TKOLMenuItem); + var + j: Integer; begin - if MI.Name <> '' then - if MI.itemindex >= 0 then - begin - if not MI.separator or generateSeparatorConstants then - //SL.Add( 'const ' + MI.Name + ': Integer = ' + IntToStr( MI.itemindex ) + ';' ); - SL.Add( 'const ' + MI.Name + ' = ' + IntToStr( MI.itemindex ) + ';' ); - Inc( N ); - end; - for J := 0 to MI.Count-1 do - GenItemConst( MI.SubItems[ J ] ); + if MI.name <> '' then + if MI.itemindex >= 0 then begin + if not MI.separator or generateSeparatorConstants then + //SL.Add( 'const ' + MI.Name + ': Integer = ' + IntToStr( MI.itemindex ) + ';' ); + SL.Add('const ' + MI.name + ' = ' + IntToStr(MI.itemindex) + ';'); + Inc(N); + end; + for j := 0 to MI.Count - 1 do + GenItemConst(MI.SubItems[j]); end; -var I: Integer; +var + I: Integer; begin - if not generateConstants then Exit; + if not generateConstants then + Exit; N := 0; - for I := 0 to Count-1 do - GenItemConst( Items[ I ] ); + for I := 0 to Count - 1 do + GenItemConst(Items[I]); if N > 0 then - SL.Add( '' ); + SL.Add(''); end; function TKOLMenu.GetCount: Integer; @@ -23597,7 +18963,7 @@ begin end; Result := nil; if (FItems <> nil) and (Idx >= 0) and (Idx < FItems.Count) then - Result := FItems[ Idx ]; + Result := FItems[Idx]; end; procedure TKOLMenu.LoadItemCount(R: TReader); @@ -23611,25 +18977,29 @@ begin FItemCount := R.ReadInteger; end; -function TKOLMenu.NameAlreadyUsed(const ItemName: String): Boolean; - function NameUsed1( MI: TKOLMenuItem ): Boolean; - var I: Integer; - SI: TKOLMenuItem; +function TKOLMenu.NameAlreadyUsed(const ItemName: string): Boolean; + +function NameUsed1(MI: TKOLMenuItem): Boolean; + var + I: Integer; + SI: TKOLMenuItem; begin - Result := MI.Name = ItemName; - if Result then Exit; - for I := 0 to MI.Count - 1 do - begin - SI := MI.FSubItems[ I ]; - Result := NameUsed1( SI ); - if Result then Exit; + Result := MI.name = ItemName; + if Result then + Exit; + for I := 0 to MI.Count - 1 do begin + SI := MI.FSubitems[I]; + Result := NameUsed1(SI); + if Result then + Exit; end; end; -var I, J: Integer; - MI: TKOLMenuItem; - F: TForm; - C: TComponent; - MC: TKOLMenu; +var + I, j: Integer; + MI: TKOLMenuItem; + F: TForm; + c: TComponent; + MC: TKOLMenu; begin asm jmp @@e_signature @@ -23638,30 +19008,28 @@ begin @@e_signature: end; F := ParentForm; - if F = nil then - begin - for I := 0 to FItems.Count - 1 do - begin - MI := FItems[ I ]; - Result := NameUsed1( MI ); - if Result then Exit; + if F = nil then begin + for I := 0 to FItems.Count - 1 do begin + MI := FItems[I]; + Result := NameUsed1(MI); + if Result then + Exit; end; Result := False; Exit; end; - Result := F.FindComponent( ItemName ) <> nil; - if Result then Exit; - for I := 0 to F.ComponentCount - 1 do - begin - C := F.Components[ I ]; - if C is TKOLMenu then - begin - MC := C as TKOLMenu; - for J := 0 to MC.Count - 1 do - begin - MI := MC.FItems[ J ]; - Result := NameUsed1( MI ); - if Result then Exit; + Result := F.FindComponent(ItemName) <> nil; + if Result then + Exit; + for I := 0 to F.ComponentCount - 1 do begin + c := F.Components[I]; + if c is TKOLMenu then begin + MC := c as TKOLMenu; + for j := 0 to MC.Count - 1 do begin + MI := MC.FItems[j]; + Result := NameUsed1(MI); + if Result then + Exit; end; end; end; @@ -23676,11 +19044,12 @@ begin DB 'TKOLMenu.NotAutoFree', 0 @@e_signature: end; - Result := TRUE; + Result := True; end; -function TKOLMenu.OnMenuItemMethodName( for_pcode: Boolean ): String; -var F: TForm; +function TKOLMenu.OnMenuItemMethodName: string; +var + F: TForm; begin asm jmp @@e_signature @@ -23689,18 +19058,16 @@ begin @@e_signature: end; Result := ''; - if TMethod( OnMenuItem ).Code <> nil then - begin + if TMethod(OnMenuItem).Code <> nil then begin F := ParentForm; if F <> nil then - Result := F.MethodName( TMethod( OnMenuItem ).Code ); + Result := F.MethodName(TMethod(OnMenuItem).Code); end; if Result = '' then Result := 'nil' - else - if not for_pcode then + else Result := 'Result.' + Result; - RptDetailed( 'MenuItem ' + Name + ' OnMenuItemName = ' + Result, YELLOW ); + RptDetailed('MenuItem ' + name + ' OnMenuItemName = ' + Result, YELLOW); end; procedure TKOLMenu.SaveItemCount(W: TWriter); @@ -23712,7 +19079,7 @@ begin @@e_signature: end; FItemCount := FItems.Count; - W.WriteInteger( FItemCount ); + W.WriteInteger(FItemCount); end; procedure TKOLMenu.SaveTo(WR: TWriter); @@ -23723,25 +19090,28 @@ begin DB 'TKOLMenu.SaveTo', 0 @@e_signature: end; - Writestate( WR ); + Writestate(WR); end; procedure TKOLMenu.SetgenerateSeparatorConstants(const Value: Boolean); begin - if FgenerateSeparatorConstants = Value then Exit; + if FgenerateSeparatorConstants = Value then + Exit; FgenerateSeparatorConstants := Value; Change; end; procedure TKOLMenu.SetgenerateConstants(const Value: Boolean); begin - if FgenerateConstants = Value then Exit; + if FgenerateConstants = Value then + Exit; FgenerateConstants := Value; Change; end; procedure TKOLMenu.SetName(const NewName: TComponentName); -var S: String; +var + s: string; begin asm jmp @@e_signature @@ -23750,25 +19120,26 @@ begin @@e_signature: end; inherited; - if ActiveDesign <> nil then - begin - S := NewName; + if ActiveDesign <> nil then begin + s := NewName; if ParentForm <> nil then - S := ParentForm.Name + '.' + S; - ActiveDesign.Caption := S; + s := ParentForm.name + '.' + s; + ActiveDesign.Caption := s; end; end; procedure TKOLMenu.SetOnDrawItem(const Value: TOnDrawItem); begin - if @ FOnDrawItem = @ Value then Exit; + if @FOnDrawItem = @Value then + Exit; FOnDrawItem := Value; Change; end; procedure TKOLMenu.SetOnMeasureItem(const Value: TOnMeasureItem); begin - if @ FOnMeasureItem = @ Value then Exit; + if @FOnMeasureItem = @Value then + Exit; FOnMeasureItem := Value; Change; end; @@ -23781,7 +19152,8 @@ begin DB 'TKOLMenu.SetOnMenuItem', 0 @@e_signature: end; - if @ FOnMenuItem = @ Value then Exit; + if @FOnMenuItem = @Value then + Exit; FOnMenuItem := Value; Change; end; @@ -23794,7 +19166,8 @@ begin DB 'TKOLMenu.SetOnUncheckRadioItem', 0 @@e_signature: end; - if @ FOnUncheckRadioItem = @ Value then Exit; + if @FOnUncheckRadioItem = @Value then + Exit; FOnUncheckRadioItem := Value; Change; end; @@ -23807,16 +19180,17 @@ begin DB 'TKOLMenu.Setshowshortcuts', 0 @@e_signature: end; - if @ Fshowshortcuts = @ Value then Exit; + if @Fshowshortcuts = @Value then + Exit; Fshowshortcuts := Value; Change; end; -procedure TKOLMenu.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -var I: Integer; - S: String; - MI: TKOLMenuItem; +procedure TKOLMenu.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); +var + I: Integer; + s: string; + MI: TKOLMenuItem; begin asm jmp @@e_signature @@ -23824,28 +19198,27 @@ begin DB 'TKOLMenu.SetupFirst', 0 @@e_signature: end; - RptDetailed( '-> ' + Name + ':TKOLMenu.SetupFirst', RED ); - if Count = 0 then Exit; - SL.Add( Prefix + AName + ' := NewMenu( ' + AParent + ', 0, [ ' ); - for I := 0 to FItems.Count - 1 do - begin - MI := FItems[ I ]; - MI.SetupTemplate( SL, I = 0, ParentKOLForm ); - end; - S := ''''' ], ' + OnMenuItemMethodName( FALSE ) + ' );'; - if FItems.Count <> 0 then - S := ', ' + S; - if Length( S ) + Length( SL[ SL.Count - 1 ] ) > 64 then - SL.Add( Prefix + ' ' + S ) - else - SL[ SL.Count - 1 ] := SL[ SL.Count - 1 ] + S; - SetupName( SL, AName, AParent, Prefix ); - for I := 0 to FItems.Count - 1 do - begin - MI := FItems[ I ]; - MI.SetupAttributes( SL, AName ); + RptDetailed('-> ' + name + ':TKOLMenu.SetupFirst', RED); + if Count = 0 then + Exit; + SL.Add(Prefix + AName + ' := NewMenu( ' + AParent + ', 0, [ '); + for I := 0 to FItems.Count - 1 do begin + MI := FItems[I]; + MI.SetupTemplate(SL, I = 0, ParentKOLForm); end; - GenerateTag( SL, AName, Prefix ); + s := ''''' ], ' + OnMenuItemMethodName() + ' );'; + if FItems.Count <> 0 then + s := ', ' + s; + if Length(s) + Length(SL[SL.Count - 1]) > 64 then + SL.Add(Prefix + ' ' + s) + else + SL[SL.Count - 1] := SL[SL.Count - 1] + s; + SetupName(SL, AName, AParent, Prefix); + for I := 0 to FItems.Count - 1 do begin + MI := FItems[I]; + MI.SetupAttributes(SL, AName); + end; + GenerateTag(SL, AName, Prefix); end; procedure TKOLMenu.UpdateDisable; @@ -23856,7 +19229,7 @@ begin DB 'TKOLMenu.UpdateDisable', 0 @@e_signature: end; - FUpdateDisabled := TRUE; + FUpdateDisabled := True; end; procedure TKOLMenu.UpdateEnable; @@ -23867,11 +19240,11 @@ begin DB 'TKOLMenu.UpdateEnable', 0 @@e_signature: end; - if not FUpdateDisabled then Exit; - FUpdateDisabled := FALSE; - if FUpdateNeeded then - begin - FUpdateNeeded := FALSE; + if not FUpdateDisabled then + Exit; + FUpdateDisabled := False; + if FUpdateNeeded then begin + FUpdateNeeded := False; UpdateMenu; end; end; @@ -23887,172 +19260,84 @@ begin // end; -procedure TKOLMenu.P_SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var I, N: Integer; - //S: String; - MI: TKOLMenuItem; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMenu.SetupFirst', 0 - @@e_signature: - end; - if Count = 0 then Exit; - (*SL.Add( Prefix + AName + ' := NewMenu( ' + AParent + ', 0, [ ' ); - for I := 0 to FItems.Count - 1 do - begin - MI := FItems[ I ]; - MI.SetupTemplate( SL, I = 0 ); - end; - S := ''''' ], ' + OnMenuItemMethodName + ' );'; - if FItems.Count <> 0 then - S := ', ' + S; - if Length( S ) + Length( SL[ SL.Count - 1 ] ) > 64 then - SL.Add( Prefix + ' ' + S ) - else - SL[ SL.Count - 1 ] := SL[ SL.Count - 1 ] + S; - if Name <> '' then - begin - SL.Add( ' {$IFDEF USE_NAMES}' ); - SL.Add( Prefix + AName + '.Name := ''' + Name + ''';' ); - SL.Add( ' {$ENDIF}' ); - end; - for I := 0 to FItems.Count - 1 do - begin - MI := FItems[ I ]; - MI.SetupAttributes( SL, AName ); - end; - GenerateTag( SL, AName, Prefix );*) - //---------------------------------------------------------------------------- - N := 1; - for I := FItems.Count - 1 downto 0 do - begin - MI := FItems[ I ]; - N := N + MI.P_SetupTemplate( SL, FALSE ); - end; - ItemsInStack := N; - {P}SL.Add( ' L(' + IntToStr( N ) + ') LoadPCharArray #0' ); - for I := FItems.Count - 1 downto 0 do - begin - MI := FItems[ I ]; - MI.P_SetupTemplate( SL, TRUE ); - end; - {P}SL.Add( ' L(' + IntToStr( N-1 ) + ')' ); - {P}if TMethod( OnMenuItem ).Code <> nil then - begin - SL.Add( ' LoadSELF Load4 ####T' + - ParentKOLForm.FormName + '.' + OnMenuItemMethodName( TRUE ) ); - end else SL.Add( ' L(0) L(0)' ); - {P}SL.Add( ' LoadStack L(12) xyAdd' ); - {P}SL.Add( ' L(0) LoadSELF AddByte_LoadRef #T' + ParentKOLForm.FormName + '.Form' + - ' NewMenu<3> RESULT DUP LoadSELF AddWord_Store ##T' + - ParentKOLForm.FormName + '.' + Name ); - for I := 0 to FItems.Count - 1 do - begin - MI := FItems[ I ]; - MI.P_SetupAttributes( SL, AName ); - end; - P_GenerateTag( SL, AName, Prefix ); -end; - -procedure TKOLMenu.P_SetupFirstFinalizy(SL: TStringList); -begin - if ItemsInStack > 1 then - {P}SL.Add( ' L(' + IntToStr( ItemsInStack ) + ') DELN' ) // удаляется массив PChar-указателей на строки Template - else - if ItemsInStack = 1 then - {P}SL.Add( ' DEL // 1 item in stack' ); -end; - -function TKOLMenu.Pcode_Generate: Boolean; -begin - Result := TRUE; -end; - procedure TKOLMenu.UpdateDesign; begin {if ActiveDesign = nil then ActiveDesign := TKOLMenuDesign.Create( Application );} if ActiveDesign <> nil then - ActiveDesign.RefreshItems; + ActiveDesign.RefreshItems; //if not FReading then //begin - if ParentForm <> nil then -//////////////////////////////////////////// - if ParentForm.Designer <> nil then // иногда может быть NIL ... -//////////////////////////////////////////// + if ParentForm <> nil then + //////////////////////////////////////////// + if ParentForm.Designer <> nil then // иногда может быть NIL ... + //////////////////////////////////////////// ParentForm.Designer.Modified; //end; end; -procedure TKOLMenu.SetOwnerDraw(const Value: Boolean); -var i: Integer; - procedure SetOwnerDrawForAllItems( Item: TKOLMenuItem; od: Boolean ); - var j: Integer; - begin - Item.OwnerDraw := od; - for j := 0 to Item.Count-1 do - SetOwnerDrawForAllItems( Item.SubItems[ j ], od ); - end; +procedure TKOLMenu.SetownerDraw(const Value: Boolean); +var + I: Integer; + + procedure SetOwnerDrawForAllItems(Item: TKOLMenuItem; od: Boolean); + var + j: Integer; + begin + Item.ownerDraw := od; + for j := 0 to Item.Count - 1 do + SetOwnerDrawForAllItems(Item.SubItems[j], od); + end; begin - FOwnerDraw := Value; + FownerDraw := Value; if Value and not AllItemsAreOwnerDraw or - not Value and AllItemsAreOwnerDraw then - for i := 0 to Count-1 do - SetOwnerDrawForAllItems( Items[ i ], Value ); + not Value and AllItemsAreOwnerDraw then + for I := 0 to Count - 1 do + SetOwnerDrawForAllItems(Items[I], Value); end; function TKOLMenu.AllItemsAreOwnerDraw: Boolean; -var i: Integer; - function AllSubitemsAreOwnerDraw( Item: TKOLMenuItem ): Boolean; - var j: Integer; - begin - Result := FALSE; - for j := 0 to Item.Count-1 do - if not Item.SubItems[ j ].FownerDraw or - not AllSubitemsAreOwnerDraw( Item.SubItems[ j ] ) then Exit; - Result := TRUE; - end; +var + I: Integer; + + function AllSubitemsAreOwnerDraw(Item: TKOLMenuItem): Boolean; + var + j: Integer; + begin + Result := False; + for j := 0 to Item.Count - 1 do + if not Item.SubItems[j].FownerDraw or + not AllSubitemsAreOwnerDraw(Item.SubItems[j]) then + Exit; + Result := True; + end; begin - Result := FALSE; - for i := 0 to Count-1 do - if not Items[ i ].FownerDraw or - not AllSubitemsAreOwnerDraw( Items[ i ] ) then Exit; - Result := TRUE; + Result := False; + for I := 0 to Count - 1 do + if not Items[I].FownerDraw or + not AllSubitemsAreOwnerDraw(Items[I]) then + Exit; + Result := True; end; procedure TKOLMenu.SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var I: Integer; - MI: TKOLMenuItem; + Prefix: string); +var + I: Integer; + MI: TKOLMenuItem; begin inherited; - for I := 0 to FItems.Count - 1 do - begin - MI := FItems[ I ]; - MI.SetupAttributesLast( SL, AName ); - end; -end; - -procedure TKOLMenu.P_SetupLast(SL: TStringList; const AName, AParent, - Prefix: String); -var I: Integer; - MI: TKOLMenuItem; -begin - inherited; - for I := 0 to FItems.Count - 1 do - begin - MI := FItems[ I ]; - MI.P_SetupAttributesLast( SL, AName ); + for I := 0 to FItems.Count - 1 do begin + MI := FItems[I]; + MI.SetupAttributesLast(SL, AName); end; end; { TKOLMenuItem } procedure TKOLMenuItem.Change; -var Menu: TKOLMenu; +var + Menu: TKOLMenu; begin asm jmp @@e_signature @@ -24060,17 +19345,19 @@ begin DB 'TKOLMenuItem.Change', 0 @@e_signature: end; - RptDetailed( Name + ': TKOLMenuItem CHANGED', RED ); - if csLoading in ComponentState then Exit; + RptDetailed(name + ': TKOLMenuItem CHANGED', RED); + if csLoading in ComponentState then + Exit; Menu := MenuComponent; if Menu <> nil then Menu.Change; end; constructor TKOLMenuItem.Create(AOwner: TComponent; AParent, Before: TKOLMenuItem); -var Items: TList; - I: Integer; - S: String; +var + Items: TList; + I: Integer; + s: string; begin asm jmp @@e_signature @@ -24078,49 +19365,50 @@ begin DB 'TKOLMenuItem.Create', 0 @@e_signature: end; - S := ''; + s := ''; if Before <> nil then - S := Before.Name + s := Before.name else - S := 'nil'; + s := 'nil'; if AOwner <> nil then - S := AOwner.Name + ', ' + S + s := AOwner.name + ', ' + s else - S := 'nil, ' + S; + s := 'nil, ' + s; //Rpt( 'TKOLMenuItem.Create( ' + S + ' );', WHITE ); - inherited Create( AOwner ); + inherited Create(AOwner); FParent := AParent; if FParent = nil then FParent := AOwner; FAccelerator := TKOLAccelerator.Create; - FAccelerator.FOwner := Self; + FAccelerator.fOwner := Self; FBitmap := TBitmap.Create; FSubitems := TList.Create; - FEnabled := True; - FVisible := True; - if AOwner = nil then Exit; + fEnabled := True; + fVisible := True; + if AOwner = nil then + Exit; if AParent = nil then Items := (AOwner as TKOLMenu).FItems else - Items := AParent.FSubItems; + Items := AParent.FSubitems; if Before = nil then - Items.Add( Self ) - else - begin - I := Items.IndexOf( Before ); + Items.Add(Self) + else begin + I := Items.IndexOf(Before); if I < 0 then - Items.Add( Self ) + Items.Add(Self) else - Items.Insert( I, Self ); + Items.Insert(I, Self); end; - FAllowBitmapCompression := TRUE; + FAllowBitmapCompression := True; end; destructor TKOLMenuItem.Destroy; -var I: Integer; - Sub: TKOLMenuItem; - Items: TList; - S: String; +var + I: Integer; + Sub: TKOLMenuItem; + Items: TList; + s: string; begin asm jmp @@e_signature @@ -24128,36 +19416,32 @@ begin DB 'TKOLMenuItem.Destroy', 0 @@e_signature: end; - Rpt( 'Destroying: ' + Name, WHITE ); + Rpt('Destroying: ' + name, WHITE); FDestroying := True; //!!!///OnMenu := nil; - for I := FSubitems.Count - 1 downto 0 do - begin - Sub := FSubitems[ I ]; - Sub.Free; + for I := FSubitems.Count - 1 downto 0 do begin + Sub := FSubitems[I]; + Sub.free; end; - FSubitems.Free; - Rpt( 'destoying ' + Name + ': subitems freeed', WHITE ); - FBitmap.Free; - if Parent <> nil then - begin + FSubitems.free; + Rpt('destoying ' + name + ': subitems freeed', WHITE); + FBitmap.free; + if Parent <> nil then begin Items := nil; if Parent is TKOLMenu then Items := MenuComponent.FItems - else - if Parent is TKOLMenuItem then - Items := (Parent as TKOLMenuItem).FSubItems; - if Items <> nil then - begin - I := Items.IndexOf( Self ); + else if Parent is TKOLMenuItem then + Items := (Parent as TKOLMenuItem).FSubitems; + if Items <> nil then begin + I := Items.IndexOf(Self); if I >= 0 then - Items.Delete( I ); + Items.Delete(I); end; end; - S := Name; - FAccelerator.Free; + s := name; + FAccelerator.free; inherited; - Rpt( 'Desroyed ' + S, WHITE ); + Rpt('Desroyed ' + s, WHITE); end; function TKOLMenuItem.GetCount: Integer; @@ -24172,7 +19456,8 @@ begin end; function TKOLMenuItem.GetMenuComponent: TKOLMenu; -var C: TComponent; +var + c: TComponent; begin asm jmp @@e_signature @@ -24180,12 +19465,11 @@ begin DB 'TKOLMenuItem.GetMenuComponent', 0 @@e_signature: end; - C := Owner; - if C is TKOLMenuItem then - Result := (C as TKOLMenuItem).GetMenuComponent - else - if C is TKOLMenu then - Result := C as TKOLMenu + c := Owner; + if c is TKOLMenuItem then + Result := (c as TKOLMenuItem).GetMenuComponent + else if c is TKOLMenu then + Result := c as TKOLMenu else Result := nil; end; @@ -24198,11 +19482,12 @@ begin DB 'TKOLMenuItem.GetSubItems', 0 @@e_signature: end; - Result := FSubitems[ Idx ]; + Result := FSubitems[Idx]; end; function TKOLMenuItem.GetUplevel: TKOLMenuItem; -var C: TComponent; +var + c: TComponent; begin asm jmp @@e_signature @@ -24210,18 +19495,19 @@ begin DB 'TKOLMenuItem.GetUplevel', 0 @@e_signature: end; - C := Parent; - if C is TKOLMenuItem then - Result := C as TKOLMenuItem + c := Parent; + if c is TKOLMenuItem then + Result := c as TKOLMenuItem else Result := nil; end; -procedure StrList2Binary( SL: TStringList; Data: TStream ); -var I: Integer; - S: String; - J: Integer; - C: Byte; +procedure StrList2Binary(SL: TStringList; Data: TStream); +var + I: Integer; + s: string; + j: Integer; + c: Byte; begin asm jmp @@e_signature @@ -24229,23 +19515,22 @@ begin DB 'StrList2Binary', 0 @@e_signature: end; - for I := 0 to SL.Count - 1 do - begin - S := SL[ I ]; - J := 1; - while J < Length( S ) do - begin - C := Hex2Int( Copy( S, J, 2 ) ); - Data.Write( C, 1 ); - Inc( J, 2 ); + for I := 0 to SL.Count - 1 do begin + s := SL[I]; + j := 1; + while j < Length(s) do begin + c := Hex2Int(Copy(s, j, 2)); + Data.Write(c, 1); + Inc(j, 2); end; end; end; -procedure Binary2StrList( Data: TStream; SL: TStringList ); -var S: String; - C: Byte; - V: String; +procedure Binary2StrList(Data: TStream; SL: TStringList); +var + s: string; + c: Byte; + V: string; begin asm jmp @@e_signature @@ -24253,18 +19538,16 @@ begin DB 'Binary2StrList', 0 @@e_signature: end; - while Data.Position < Data.Size do - begin - S := ''; - while (Data.Position < Data.Size) and (Length( S ) < 56) do - begin - Data.Read( C, 1 ); - V := Copy( Int2Hex( C, 2 ), 1, 2 ); - while Length( V ) < 2 do + while Data.Position < Data.Size do begin + s := ''; + while (Data.Position < Data.Size) and (Length(s) < 56) do begin + Data.Read(c, 1); + V := Copy(Int2Hex(c, 2), 1, 2); + while Length(V) < 2 do V := '0' + V; - S := S + V; + s := s + V; end; - SL.Add( S ); + SL.Add(s); end; end; @@ -24279,24 +19562,20 @@ begin if Value <> nil then if Value.Width * Value.Height = 0 then Value := nil; - if Value <> nil then - begin - if Parent is TKOLMainMenu then - begin - ShowMessage( 'Menu item in the menu bar can not be checked, so it is ' + - 'not possible to assign bitmap to upper level items in ' + - 'the main menu.' ); + if Value <> nil then begin + if Parent is TKOLMainMenu then begin + Showmessage('Menu item in the menu bar can not be checked, so it is ' + + 'not possible to assign bitmap to upper level items in ' + + 'the main menu.'); Value := nil; end; end; - if Value = nil then - begin + if Value = nil then begin FBitmap.Width := 0; FBitmap.Height := 0; end - else - begin - FBitmap.Assign( Value ); + else begin + FBitmap.Assign(Value); FSeparator := False; end; Change; @@ -24311,23 +19590,22 @@ begin @@e_signature: end; - if (Value <> '') and (AnsiChar(Value[ 1 ]) in ['-','+']) then - begin - if not( (Length( Value ) > 1) and (Value[ 1 ] = '-') and (AnsiChar(Value[ 2 ]) in ['-','+']) ) then - ShowMessage( 'Please do not start menu caption with ''-'' or ''+'' characters, ' + - 'such prefixes are reserved for internal use only. Or, at least ' + - 'insert once more leading ''-'' character. This is by design ' + - 'reasons, sorry.' ); + if (Value <> '') and (AnsiChar(Value[1]) in ['-', '+']) then begin + if not ((Length(Value) > 1) and (Value[1] = '-') and (AnsiChar(Value[2]) in ['-', '+'])) then + Showmessage('Please do not start menu caption with ''-'' or ''+'' characters, ' + + 'such prefixes are reserved for internal use only. Or, at least ' + + 'insert once more leading ''-'' character. This is by design ' + + 'reasons, sorry.'); end; - if Faction = nil then - begin - if FCaption = Value then Exit; - FCaption := Value; + if Faction = nil then begin + if fCaption = Value then + Exit; + fCaption := Value; end else - FCaption:=Faction.Caption; + fCaption := Faction.Caption; - if FCaption <> '' then + if fCaption <> '' then FSeparator := False; Change; @@ -24341,13 +19619,13 @@ begin DB 'TKOLMenuItem.SetChecked', 0 @@e_signature: end; - if Faction = nil then - begin - if FChecked = Value then Exit; + if Faction = nil then begin + if FChecked = Value then + Exit; FChecked := Value; end else - FChecked := Faction.Checked; + FChecked := Faction.checked; if FChecked then FSeparator := False; Change; @@ -24361,19 +19639,19 @@ begin DB 'TKOLMenuItem.SetEnabled', 0 @@e_signature: end; - if Faction = nil then - begin - if FEnabled = Value then Exit; - FEnabled := Value; + if Faction = nil then begin + if fEnabled = Value then + Exit; + fEnabled := Value; end else - FEnabled := Faction.Enabled; - if FEnabled then + fEnabled := Faction.Enabled; + if fEnabled then FSeparator := False; Change; end; -function QueryFormDesigner( D: IDesigner; var FD: IFormDesigner ): Boolean; +function QueryFormDesigner(D: IDesigner; var FD: IFormDesigner): Boolean; begin asm jmp @@e_signature @@ -24381,15 +19659,16 @@ begin DB 'QueryFormDesigner', 0 @@e_signature: end; - Result := D.QueryInterface( IFormDesigner, FD ) = 0; + Result := D.QueryInterface(IFormDesigner, FD) = 0; end; procedure TKOLMenuItem.SetName(const NewName: TComponentName); -var OldName, NewMethodName: String; - L: Integer; - F: TForm; - D: IDesigner; - FD: IFormDesigner; +var + OldName, NewMethodName: string; + L: Integer; + F: TForm; + D: IDesigner; + FD: IFormDesigner; begin asm jmp @@e_signature @@ -24397,63 +19676,59 @@ begin DB 'TKOLMenuItem.SetName', 0 @@e_signature: end; - OldName := Name; - if OldName = NewName then Exit; + OldName := name; + if OldName = NewName then + Exit; //Rpt( 'Renaming ' + OldName + ' to ' + NewName, WHITE ); if (MenuComponent <> nil) and (OldName <> '') and - MenuComponent.NameAlreadyUsed( NewName ) then - begin - ShowMessage( 'Can not rename to ' + NewName + ' - such name is already used.' ); + MenuComponent.NameAlreadyUsed(NewName) then begin + Showmessage('Can not rename to ' + NewName + ' - such name is already used.'); Exit; end; - if (OldName <> '') and (NewName = '') then - begin - ShowMessage( 'Can not rename to '''' - name must not be empty.' ); + if (OldName <> '') and (NewName = '') then begin + Showmessage('Can not rename to '''' - name must not be empty.'); Exit; end; inherited; - if OldName = '' then Exit; + if OldName = '' then + Exit; if FOnMenuMethodName <> '' then - if MenuComponent <> nil then - begin - L := Length( OldName ) + 4; - if LowerCase( Copy( FOnMenuMethodName, Length( FOnMenuMethodName ) - L + 1, L ) ) - = LowerCase( OldName + 'Menu' ) then - begin - // rename event handler also here: - F := MenuComponent.ParentForm; - NewMethodName := MenuComponent.Name + NewName + 'Menu'; - if F <> nil then - begin -//*/////////////////////////////////////////////////////// - {$IFDEF _D6orhigher} // - F.Designer.QueryInterface(IFormDesigner,D); // - {$ELSE} // -//*/////////////////////////////////////////////////////// - D := F.Designer; -//*/////////////////////////////////////////////////////// - {$ENDIF} // -//*/////////////////////////////////////////////////////// - if D <> nil then - if QueryFormDesigner( D, FD ) then - //if D.QueryInterface( IFormDesigner, FD ) = 0 then - begin - if not FD.MethodExists( NewMethodName ) then - begin - FD.RenameMethod( FOnMenuMethodName, NewMethodName ); - if FD.MethodExists( NewMethodName ) then - FOnMenuMethodName := NewMethodName; - end; + if MenuComponent <> nil then begin + L := Length(OldName) + 4; + if LowerCase(Copy(FOnMenuMethodName, Length(FOnMenuMethodName) - L + 1, L)) + = LowerCase(OldName + 'Menu') then begin + // rename event handler also here: + F := MenuComponent.ParentForm; + NewMethodName := MenuComponent.name + NewName + 'Menu'; + if F <> nil then begin + //*/////////////////////////////////////////////////////// +{$IFDEF _D6orhigher} // + F.Designer.QueryInterface(IFormDesigner, D); // +{$ELSE} // + //*/////////////////////////////////////////////////////// + D := F.Designer; + //*/////////////////////////////////////////////////////// +{$ENDIF} // + //*/////////////////////////////////////////////////////// + if D <> nil then + if QueryFormDesigner(D, FD) then + {//if D.QueryInterface( IFormDesigner, FD ) = 0 then} begin + if not FD.MethodExists(NewMethodName) then begin + FD.RenameMethod(FOnMenuMethodName, NewMethodName); + if FD.MethodExists(NewMethodName) then + FOnMenuMethodName := NewMethodName; + end; + end; end; end; end; - end; Change; end; procedure TKOLMenuItem.SetOnMenu(const Value: TOnMenuItem); -var F: TForm; - S: String; +var + F: TForm; + s: string; begin asm jmp @@e_signature @@ -24461,23 +19736,22 @@ begin DB 'TKOLMenuItem.SetOnMenu', 0 @@e_signature: end; - if @ FOnMenu = @ Value then Exit; + if @FOnMenu = @Value then + Exit; FOnMenu := Value; - if TMethod( Value ).Code <> nil then - begin - if MenuComponent <> nil then - begin + if TMethod(Value).Code <> nil then begin + if MenuComponent <> nil then begin F := (MenuComponent as TKOLMenu).ParentForm; - S := F.MethodName( TMethod( Value ).Code ); + s := F.MethodName(TMethod(Value).Code); //Rpt( 'Assigned method: ' + S + ' (' + // IntToStr( Integer( TMethod( Value ).Code ) ) + ')' ); - FOnMenuMethodName := S; + FOnMenuMethodName := s; //FOnMenuMethodNum := Integer( TMethod( Value ).Code ); //if TMethod( Value ).Data = F then // Rpt( 'Assigned method is of form object!' ); end; end - else + else FOnMenuMethodName := ''; Change; end; @@ -24490,20 +19764,21 @@ begin DB 'TKOLMenuItem.SetVisible', 0 @@e_signature: end; - if Faction = nil then - begin - if FVisible = Value then Exit; - FVisible := Value; + if Faction = nil then begin + if fVisible = Value then + Exit; + fVisible := Value; end else - FVisible := Faction.Visible; + fVisible := Faction.Visible; Change; end; procedure TKOLMenuItem.MoveUp; -var ParentItems: TList; - I: Integer; - Tmp: Pointer; +var + ParentItems: TList; + I: Integer; + Tmp: Pointer; begin asm jmp @@e_signature @@ -24515,20 +19790,20 @@ begin ParentItems := MenuComponent.FItems else ParentItems := (Parent as TKOLMenuItem).FSubitems; - I := ParentItems.IndexOf( Self ); - if I > 0 then - begin - Tmp := ParentItems[ I - 1 ]; - ParentItems[ I - 1 ] := Self; - ParentItems[ I ] := Tmp; + I := ParentItems.IndexOf(Self); + if I > 0 then begin + Tmp := ParentItems[I - 1]; + ParentItems[I - 1] := Self; + ParentItems[I] := Tmp; Change; end; end; procedure TKOLMenuItem.MoveDown; -var ParentItems: TList; - I: Integer; - Tmp: Pointer; +var + ParentItems: TList; + I: Integer; + Tmp: Pointer; begin asm jmp @@e_signature @@ -24540,19 +19815,19 @@ begin ParentItems := MenuComponent.FItems else ParentItems := (Parent as TKOLMenuItem).FSubitems; - I := ParentItems.IndexOf( Self ); - if I < ParentItems.Count - 1 then - begin - Tmp := ParentItems[ I + 1 ]; - ParentItems[ I + 1 ] := Self; - ParentItems[ I ] := Tmp; + I := ParentItems.IndexOf(Self); + if I < ParentItems.Count - 1 then begin + Tmp := ParentItems[I + 1]; + ParentItems[I + 1] := Self; + ParentItems[I] := Tmp; Change; end; end; -procedure TKOLMenuItem.DefProps(const Prefix: String; Filer: TFiler); -var I: Integer; - MI: TKOLMenuItem; +procedure TKOLMenuItem.DefProps(const Prefix: string; Filer: TFiler); +var + I: Integer; + MI: TKOLMenuItem; begin asm jmp @@e_signature @@ -24560,32 +19835,31 @@ begin DB 'TKOLMenuItem.DefProps', 0 @@e_signature: end; - Filer.DefineProperty( Prefix + 'Name', LoadName, SaveName, True ); - Filer.DefineProperty( Prefix + 'Caption', LoadCaption, SaveCaption, Caption <> '' ); - Filer.DefineProperty( Prefix + 'Enabled', LoadEnabled, SaveEnabled, True ); - Filer.DefineProperty( Prefix + 'Visible', LoadVisible, SaveVisible, True ); - Filer.DefineProperty( Prefix + 'Checked', LoadChecked, SaveChecked, True ); - Filer.DefineProperty( Prefix + 'RadioGroup', LoadRadioGroup, SaveRadioGroup, True ); - Filer.DefineProperty( Prefix + 'Separator', LoadSeparator, SaveSeparator, True ); - Filer.DefineProperty( Prefix + 'Accelerator', LoadAccel, SaveAccel, True ); - Filer.DefineProperty( Prefix + 'Bitmap', LoadBitmap, SaveBitmap, True ); - Filer.DefineProperty( Prefix + 'OnMenu', LoadOnMenu, SaveOnMenu, FOnMenuMethodName <> '' ); - Filer.DefineProperty( Prefix + 'SubItemCount', LoadSubItemCount, SaveSubItemCount, True ); - Filer.DefineProperty( Prefix + 'WindowMenu', LoadWindowMenu, SaveWindowMenu, True ); - Filer.DefineProperty( Prefix + 'HelpContext', LoadHelpContext, SaveHelpContext, HelpContext <> 0 ); - Filer.DefineProperty( Prefix + 'OwnerDraw', LoadOwnerDraw, SaveOwnerDraw, ownerDraw ); - Filer.DefineProperty( Prefix + 'MenuBreak', LoadMenuBreak, SaveMenuBreak, MenuBreak <> mbrNone ); - for I := 0 to FSubItemCount - 1 do - begin - if FSubItems.Count <= I then - MI := TKOLMenuItem.Create( MenuComponent, Self, nil ) + Filer.DefineProperty(Prefix + 'Name', LoadName, SaveName, True); + Filer.DefineProperty(Prefix + 'Caption', LoadCaption, SaveCaption, Caption <> ''); + Filer.DefineProperty(Prefix + 'Enabled', LoadEnabled, SaveEnabled, True); + Filer.DefineProperty(Prefix + 'Visible', LoadVisible, SaveVisible, True); + Filer.DefineProperty(Prefix + 'Checked', LoadChecked, SaveChecked, True); + Filer.DefineProperty(Prefix + 'RadioGroup', LoadRadioGroup, SaveRadioGroup, True); + Filer.DefineProperty(Prefix + 'Separator', LoadSeparator, SaveSeparator, True); + Filer.DefineProperty(Prefix + 'Accelerator', LoadAccel, SaveAccel, True); + Filer.DefineProperty(Prefix + 'Bitmap', LoadBitmap, SaveBitmap, True); + Filer.DefineProperty(Prefix + 'OnMenu', LoadOnMenu, SaveOnMenu, FOnMenuMethodName <> ''); + Filer.DefineProperty(Prefix + 'SubItemCount', LoadSubItemCount, SaveSubItemCount, True); + Filer.DefineProperty(Prefix + 'WindowMenu', LoadWindowMenu, SaveWindowMenu, True); + Filer.DefineProperty(Prefix + 'HelpContext', LoadHelpContext, SaveHelpContext, HelpContext <> 0); + Filer.DefineProperty(Prefix + 'OwnerDraw', LoadOwnerDraw, SaveOwnerDraw, ownerDraw); + Filer.DefineProperty(Prefix + 'MenuBreak', LoadMenuBreak, SaveMenuBreak, MenuBreak <> mbrNone); + for I := 0 to FSubItemCount - 1 do begin + if FSubitems.Count <= I then + MI := TKOLMenuItem.Create(MenuComponent, Self, nil) else - MI := FSubItems[ I ]; - MI.DefProps( Prefix + 'SubItem' + IntToStr( I ), Filer ); + MI := FSubitems[I]; + MI.DefProps(Prefix + 'SubItem' + IntToStr(I), Filer); end; - Filer.DefineProperty( Prefix + 'Tag', LoadTag, SaveTag, Tag <> 0 ); - Filer.DefineProperty( Prefix + 'Default', LoadDefault, SaveDefault, Default ); -// Filer.DefineProperty( Prefix + 'Action', LoadAction, SaveAction, FActionComponentName <> ''); + Filer.DefineProperty(Prefix + 'Tag', LoadTag, SaveTag, Tag <> 0); + Filer.DefineProperty(Prefix + 'Default', LoadDefault, SaveDefault, default); + // Filer.DefineProperty( Prefix + 'Action', LoadAction, SaveAction, FActionComponentName <> ''); end; procedure TKOLMenuItem.LoadCaption(R: TReader); @@ -24596,7 +19870,7 @@ begin DB 'TKOLMenuItem.LoadCaption', 0 @@e_signature: end; - FCaption := R.ReadString; + fCaption := R.ReadString; end; procedure TKOLMenuItem.LoadChecked(R: TReader); @@ -24618,7 +19892,7 @@ begin DB 'TKOLMenuItem.LoadEnabled', 0 @@e_signature: end; - FEnabled := R.ReadBoolean; + fEnabled := R.ReadBoolean; end; procedure TKOLMenuItem.LoadName(R: TReader); @@ -24629,7 +19903,7 @@ begin DB 'TKOLMenuItem.LoadName', 0 @@e_signature: end; - Name := R.ReadString; + name := R.ReadString; end; procedure TKOLMenuItem.LoadOnMenu(R: TReader); @@ -24673,7 +19947,7 @@ begin DB 'TKOLMenuItem.LoadVisible', 0 @@e_signature: end; - FVisible := R.ReadBoolean; + fVisible := R.ReadBoolean; end; procedure TKOLMenuItem.SaveCaption(W: TWriter); @@ -24684,7 +19958,7 @@ begin DB 'TKOLMenuItem.SaveCaption', 0 @@e_signature: end; - W.WriteString( Caption ); + W.WriteString(Caption); end; procedure TKOLMenuItem.SaveChecked(W: TWriter); @@ -24695,7 +19969,7 @@ begin DB 'TKOLMenuItem.SaveChecked', 0 @@e_signature: end; - W.WriteBoolean( Checked ); + W.WriteBoolean(checked); end; procedure TKOLMenuItem.SaveEnabled(W: TWriter); @@ -24706,7 +19980,7 @@ begin DB 'TKOLMenuItem.SaveEnabled', 0 @@e_signature: end; - W.WriteBoolean( Enabled ); + W.WriteBoolean(Enabled); end; procedure TKOLMenuItem.SaveName(W: TWriter); @@ -24717,7 +19991,7 @@ begin DB 'TKOLMenuItem.SaveName', 0 @@e_signature: end; - W.WriteString( Name ); + W.WriteString(name); end; procedure TKOLMenuItem.SaveOnMenu(W: TWriter); @@ -24728,7 +20002,7 @@ begin DB 'TKOLMenuItem.SaveOnMenu', 0 @@e_signature: end; - W.WriteString( FOnMenuMethodName ); + W.WriteString(FOnMenuMethodName); end; {procedure TKOLMenuItem.SaveRadioItem(W: TWriter); @@ -24750,8 +20024,8 @@ begin DB 'TKOLMenuItem.SaveSubItemCount', 0 @@e_signature: end; - FSubItemCount := FSubItems.Count; - W.WriteInteger( FSubItemCount ); + FSubItemCount := FSubitems.Count; + W.WriteInteger(FSubItemCount); end; procedure TKOLMenuItem.SaveVisible(W: TWriter); @@ -24762,13 +20036,14 @@ begin DB 'TKOLMenuItem.SaveVisible', 0 @@e_signature: end; - W.WriteBoolean( Visible ); + W.WriteBoolean(Visible); end; procedure TKOLMenuItem.LoadBitmap(R: TReader); -var MS: TMemoryStream; - SL: TStringList; - S: String; +var + MS: TMemoryStream; + SL: TStringList; + s: string; begin asm jmp @@e_signature @@ -24780,34 +20055,32 @@ begin SL := TStringList.Create; try R.ReadListBegin; - while not R.EndOfList do - begin - S := R.ReadString; - if Trim( S ) <> '' then - SL.Add( Trim( S ) ); + while not R.EndOfList do begin + s := R.ReadString; + if Trim(s) <> '' then + SL.Add(Trim(s)); end; R.ReadListEnd; - if SL.Count = 0 then - begin + if SL.Count = 0 then begin FBitmap.Width := 0; FBitmap.Height := 0; end - else - begin - StrList2Binary( SL, MS ); + else begin + StrList2Binary(SL, MS); MS.Position := 0; - FBitmap.LoadFromStream( MS ); + FBitmap.LoadFromStream(MS); end; finally - MS.Free; - SL.Free; + MS.free; + SL.free; end; end; procedure TKOLMenuItem.SaveBitmap(W: TWriter); -var MS: TMemoryStream; - SL: TStringList; - I: Integer; +var + MS: TMemoryStream; + SL: TStringList; + I: Integer; begin asm jmp @@e_signature @@ -24818,38 +20091,39 @@ begin MS := TMemoryStream.Create; SL := TStringList.Create; try - Bitmap.SaveToStream( MS ); + Bitmap.SaveToStream(MS); MS.Position := 0; if Bitmap.Width * Bitmap.Height > 0 then - Binary2StrList( MS, SL ); + Binary2StrList(MS, SL); W.WriteListBegin; for I := 0 to SL.Count - 1 do - W.WriteString( SL[ I ] ); + W.WriteString(SL[I]); W.WriteListEnd; finally - MS.Free; - SL.Free; + MS.free; + SL.free; end; end; procedure TKOLMenuItem.SetupTemplate(SL: TStringList; FirstItem: Boolean; KF: TKOLForm); - procedure Add2SL( const S: TDelphiString ); - begin - if Length( SL[ SL.Count - 1 ] + S ) > 64 then - SL.Add( ' ' + S ) - else - SL[ SL.Count - 1 ] := SL[ SL.Count - 1 ] + S; - end; + +procedure Add2SL(const s: TDelphiString); + begin + if Length(SL[SL.Count - 1] + s) > 64 then + SL.Add(' ' + s) + else + SL[SL.Count - 1] := SL[SL.Count - 1] + s; + end; var {$IFDEF _D2009orHigher} - C2: WideString; - S, U: WideString; - J : integer; + C2: WideString; + s, U: WideString; + j: Integer; {$ELSE} - S, U: String; + s, U: string; {$ENDIF} - I: Integer; - MI: TKOLMenuItem; + I: Integer; + MI: TKOLMenuItem; begin asm jmp @@e_signature @@ -24857,95 +20131,88 @@ begin DB 'TKOLMenuItem.SetupTemplate', 0 @@e_signature: end; - if Separator then - S := '-' - else - begin + if separator then + s := '-' + else begin U := Caption; - if (KF <> nil) and not KF.AssignTextToControls then - U := ''; - {$IFDEF _D2009orHigher} - C2 := ''; - for j := 1 to Length(U) do C2 := C2 + '#'+IntToStr(ord(U[j])); - U := C2; - {$ENDIF} + if (KF <> nil) and not KF.AssignTextToControls then + U := ''; +{$IFDEF _D2009orHigher} + C2 := ''; + for j := 1 to Length(U) do + C2 := C2 + '#' + IntToStr(Ord(U[j])); + U := C2; +{$ENDIF} if (U = '') or (Faction <> nil) then U := ' '; - S := ''; - if FradioGroup <> 0 then - begin - S := '!' + S; - if (FParent <> nil) and (FParent is TKOLMenuItem) then - begin - I := (FParent as TKOLMenuItem).FSubitems.IndexOf( Self ); - if I > 0 then - begin - MI := (FParent as TKOLMenuItem).FSubItems[ I - 1 ]; - if (MI.FradioGroup <> 0) and (MI.FradioGroup <> FradioGroup) then - S := '!' + S; + s := ''; + if FRadioGroup <> 0 then begin + s := '!' + s; + if (FParent <> nil) and (FParent is TKOLMenuItem) then begin + I := (FParent as TKOLMenuItem).FSubitems.IndexOf(Self); + if I > 0 then begin + MI := (FParent as TKOLMenuItem).FSubitems[I - 1]; + if (MI.FRadioGroup <> 0) and (MI.FRadioGroup <> FRadioGroup) then + s := '!' + s; end; end; - if not Checked then - S := '-' + S; + if not checked then + s := '-' + s; end; - if Checked and (Faction = nil) then - S := '+' + S; + if checked and (Faction = nil) then + s := '+' + s; end; - if Accelerator.Key <> vkNotPresent then - if MenuComponent.showshortcuts and (Faction = nil) - and (KF <> nil) and KF.AssignTextToControls then - {$IFDEF _D2009orHigher} - U := U + '''' + #9 + Accelerator.AsText + ''''; - {$ELSE} - U := U + #9 + Accelerator.AsText; - {$ENDIF} - if S = '' then - begin + if accelerator.Key <> vkNotPresent then + if MenuComponent.showShortcuts and (Faction = nil) + and (KF <> nil) and KF.AssignTextToControls then +{$IFDEF _D2009orHigher} + U := U + '''' + #9 + accelerator.AsText + ''''; +{$ELSE} + U := U + #9 + accelerator.AsText; +{$ENDIF} + if s = '' then begin if Faction = nil then - {$IFDEF _D2009orHigher} - S := U - {$ELSE} - S := PCharStringConstant( MenuComponent, Name, U ) - {$ENDIF} - else - {$IFDEF _D2009orHigher} - S := U; - {$ELSE} - S := '''' + U + ''''; - {$ENDIF} +{$IFDEF _D2009orHigher} + s := U +{$ELSE} + s := PCharStringConstant(MenuComponent, name, U) +{$ENDIF} + else +{$IFDEF _D2009orHigher} + s := U; +{$ELSE} + s := '''' + U + ''''; +{$ENDIF} end - else - begin - {$IFDEF _D2009orHigher} - if S = '-' then - S := '''' + S + '''' - else - S := '''' + S + ''' + '; - if (U <> '') and (U[ 1 ] <> '''') then - S := 'PWideChar( ' + S + U + ')' + else begin +{$IFDEF _D2009orHigher} + if s = '-' then + s := '''' + s + '''' else - S := S + U; - {$ELSE} - S := '''' + S + ''' + '; - U := MenuComponent.StringConstant( Name, U ); - if (U <> '') and (U[ 1 ] <> '''') then - S := 'PChar( ' + S + U + ')' + s := '''' + s + ''' + '; + if (U <> '') and (U[1] <> '''') then + s := 'PWideChar( ' + s + U + ')' else - S := S + U; - {$ENDIF} + s := s + U; +{$ELSE} + s := '''' + s + ''' + '; + U := MenuComponent.StringConstant(name, U); + if (U <> '') and (U[1] <> '''') then + s := 'PChar( ' + s + U + ')' + else + s := s + U; +{$ENDIF} end; if not FirstItem then - S := ', ' + S; - Add2SL( S ); - if Count > 0 then - begin - Add2SL( ', ''(''' ); - for I := 0 to Count - 1 do - begin - MI := FSubItems[ I ]; - MI.SetupTemplate( SL, False, KF ); + s := ', ' + s; + Add2SL(s); + if Count > 0 then begin + Add2SL(', ''('''); + for I := 0 to Count - 1 do begin + MI := FSubitems[I]; + MI.SetupTemplate(SL, False, KF); end; - Add2SL( ', '')''' ); + Add2SL(', '')'''); end; end; @@ -24957,7 +20224,8 @@ begin DB 'TKOLMenuItem.SetSeparator', 0 @@e_signature: end; - if FSeparator = Value then Exit; + if FSeparator = Value then + Exit; FSeparator := Value; Change; end; @@ -24981,27 +20249,30 @@ begin DB 'TKOLMenuItem.SaveSeparator', 0 @@e_signature: end; - W.WriteBoolean( Separator ); + W.WriteBoolean(separator); end; function TKOLMenuItem.GetItemIndex: Integer; -var N: Integer; - procedure IterateThroughSubItems( MI: TKOLMenuItem ); - var I: Integer; +var + N: Integer; + + procedure IterateThroughSubItems(MI: TKOLMenuItem); + var + I: Integer; begin - if MI = Self then - begin + if MI = Self then begin Result := N; Exit; end; - Inc( N ); - for I := 0 to MI.Count - 1 do - begin - IterateThroughSubItems( MI.FSubItems[ I ] ); - if Result >= 0 then break; + Inc(N); + for I := 0 to MI.Count - 1 do begin + IterateThroughSubItems(MI.FSubitems[I]); + if Result >= 0 then + Break; end; end; -var I: Integer; +var + I: Integer; begin asm jmp @@e_signature @@ -25012,11 +20283,11 @@ begin Result := -1; N := 0; if MenuComponent <> nil then - for I := 0 to MenuComponent.Count - 1 do - begin - IterateThroughSubItems( MenuComponent.FItems[ I ] ); - if Result >= 0 then break; - end; + for I := 0 to MenuComponent.Count - 1 do begin + IterateThroughSubItems(MenuComponent.FItems[I]); + if Result >= 0 then + Break; + end; end; procedure TKOLMenuItem.SetItemIndex_Dummy(const Value: Integer); @@ -25030,65 +20301,69 @@ begin // dummy method - nothing to set end; -const VirtKeys: array[ TVirtualKey ] of String = ( - '0', 'VK_BACK', 'VK_TAB', 'VK_CLEAR', 'VK_RETURN', 'VK_PAUSE', 'VK_CAPITAL', - 'VK_ESCAPE', 'VK_SPACE', 'VK_PRIOR', 'VK_NEXT', 'VK_END', 'VK_HOME', 'VK_LEFT', - 'VK_UP', 'VK_RIGHT', 'VK_DOWN', 'VK_SELECT', 'VK_EXECUTE', 'VK_SNAPSHOT', - 'VK_INSERT', 'VK_DELETE', 'VK_HELP', '$30', '$31', '$32', '$33', '$34', '$35', - '$36', '$37', '$38', '$39', '$41', '$42', '$43', '$44', '$45', '$46', '$47', - '$48', '$49', '$4A', '$4B', '$4C', '$4D', '$4E', '$4F', '$50', '$51', '$52', - '$53', '$54', '$55', '$56', '$57', '$58', '$59', '$5A', 'VK_LWIN', 'VK_RWIN', 'VK_APPS', - 'VK_NUMPAD0', 'VK_NUMPAD1', 'VK_NUMPAD2', 'VK_NUMPAD3', 'VK_NUMPAD4', 'VK_NUMPAD5', - 'VK_NUMPAD6', 'VK_NUMPAD7', 'VK_NUMPAD8', 'VK_NUMPAD9', 'VK_MULTIPLY', 'VK_ADD', - 'VK_SEPARATOR', 'VK_SUBTRACT', 'VK_DECIMAL', 'VK_DIVIDE', 'VK_F1', 'VK_F2', 'VK_F3', - 'VK_F4', 'VK_F5', 'VK_F6', 'VK_F7', 'VK_F8', 'VK_F9', 'VK_F10', 'VK_F11', 'VK_F12', - 'VK_F13', 'VK_F14', 'VK_F15', 'VK_F16', 'VK_F17', 'VK_F18', 'VK_F19', 'VK_F20', - 'VK_F21', 'VK_F22', 'VK_F23', 'VK_F24', 'VK_NUMLOCK', 'VK_SCROLL', 'VK_ATTN', - 'VK_CRSEL', 'VK_EXSEL', 'VK_EREOF', 'VK_PLAY', 'VK_ZOOM', 'VK_PA1', 'VK_OEM_CLEAR' ); +const + VirtKeys: array[TVirtualKey] of string = ( + '0', 'VK_BACK', 'VK_TAB', 'VK_CLEAR', 'VK_RETURN', 'VK_PAUSE', 'VK_CAPITAL', + 'VK_ESCAPE', 'VK_SPACE', 'VK_PRIOR', 'VK_NEXT', 'VK_END', 'VK_HOME', 'VK_LEFT', + 'VK_UP', 'VK_RIGHT', 'VK_DOWN', 'VK_SELECT', 'VK_EXECUTE', 'VK_SNAPSHOT', + 'VK_INSERT', 'VK_DELETE', 'VK_HELP', '$30', '$31', '$32', '$33', '$34', '$35', + '$36', '$37', '$38', '$39', '$41', '$42', '$43', '$44', '$45', '$46', '$47', + '$48', '$49', '$4A', '$4B', '$4C', '$4D', '$4E', '$4F', '$50', '$51', '$52', + '$53', '$54', '$55', '$56', '$57', '$58', '$59', '$5A', 'VK_LWIN', 'VK_RWIN', 'VK_APPS', + 'VK_NUMPAD0', 'VK_NUMPAD1', 'VK_NUMPAD2', 'VK_NUMPAD3', 'VK_NUMPAD4', 'VK_NUMPAD5', + 'VK_NUMPAD6', 'VK_NUMPAD7', 'VK_NUMPAD8', 'VK_NUMPAD9', 'VK_MULTIPLY', 'VK_ADD', + 'VK_SEPARATOR', 'VK_SUBTRACT', 'VK_DECIMAL', 'VK_DIVIDE', 'VK_F1', 'VK_F2', 'VK_F3', + 'VK_F4', 'VK_F5', 'VK_F6', 'VK_F7', 'VK_F8', 'VK_F9', 'VK_F10', 'VK_F11', 'VK_F12', + 'VK_F13', 'VK_F14', 'VK_F15', 'VK_F16', 'VK_F17', 'VK_F18', 'VK_F19', 'VK_F20', + 'VK_F21', 'VK_F22', 'VK_F23', 'VK_F24', 'VK_NUMLOCK', 'VK_SCROLL', 'VK_ATTN', + 'VK_CRSEL', 'VK_EXSEL', 'VK_EREOF', 'VK_PLAY', 'VK_ZOOM', 'VK_PA1', 'VK_OEM_CLEAR'); -const VrtKeyVals: array[ TVirtualKey ] of DWORD = ( - 0, VK_BACK, VK_TAB, VK_CLEAR, VK_RETURN, VK_PAUSE, VK_CAPITAL, - VK_ESCAPE, VK_SPACE, VK_PRIOR, VK_NEXT, VK_END, VK_HOME, VK_LEFT, - VK_UP, VK_RIGHT, VK_DOWN, VK_SELECT, VK_EXECUTE, VK_SNAPSHOT, - VK_INSERT, VK_DELETE, VK_HELP, $30, $31, $32, $33, $34, $35, - $36, $37, $38, $39, $41, $42, $43, $44, $45, $46, $47, - $48, $49, $4A, $4B, $4C, $4D, $4E, $4F, $50, $51, $52, - $53, $54, $55, $56, $57, $58, $59, $5A, VK_LWIN, VK_RWIN, VK_APPS, - VK_NUMPAD0, VK_NUMPAD1, VK_NUMPAD2, VK_NUMPAD3, VK_NUMPAD4, VK_NUMPAD5, - VK_NUMPAD6, VK_NUMPAD7, VK_NUMPAD8, VK_NUMPAD9, VK_MULTIPLY, VK_ADD, - VK_SEPARATOR, VK_SUBTRACT, VK_DECIMAL, VK_DIVIDE, VK_F1, VK_F2, VK_F3, - VK_F4, VK_F5, VK_F6, VK_F7, VK_F8, VK_F9, VK_F10, VK_F11, VK_F12, - VK_F13, VK_F14, VK_F15, VK_F16, VK_F17, VK_F18, VK_F19, VK_F20, - VK_F21, VK_F22, VK_F23, VK_F24, VK_NUMLOCK, VK_SCROLL, VK_ATTN, - VK_CRSEL, VK_EXSEL, VK_EREOF, VK_PLAY, VK_ZOOM, VK_PA1, VK_OEM_CLEAR ); - -// Maxim Pushkar: -const VirtualKeyNames: array [TVirtualKey] of string = - ( '', 'Back'{'BackSpace'}, 'Tab', 'CLEAR', 'Enter', 'Pause', 'CapsLock', - 'Escape'{'Esc'}, 'Space', 'PageUp', 'PageDown', 'End', 'Home', 'Left', - 'Up', 'Right', 'Down', 'SELECT', 'EXECUTE', 'PrintScreen', - 'Ins', 'Delete'{'Del'}, 'Help'{'?'}, '0', '1', '2', '3', '4', '5', - '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', - 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', - 'U', 'V', 'W', 'X', 'Y', 'Z', 'LWin', 'RWin', 'APPS', - 'Numpad0', 'Numpad1', 'Numpad2', 'Numpad3', 'Numpad4', - 'Numpad5', 'Numpad6', 'Numpad7', 'Numpad8', 'Numpad9', - '*', '+', '|', '-', '.', '/', 'F1', 'F2', 'F3', 'F4', - 'F5', 'F6', 'F7', 'F8', 'F9', 'F10', 'F11', 'F12', 'F13', - 'F14', 'F15', 'F16', 'F17', 'F18', 'F19', 'F20', 'F21', - 'F22', 'F23', 'F24', 'NumLock', 'ScrollLock', 'ATTN', 'CRSEL', - 'EXSEL', 'EREOF', 'PLAY', 'ZOOM', 'PA1', 'OEMCLEAR'); +const + VrtKeyVals: array[TVirtualKey] of DWORD = ( + 0, VK_BACK, VK_TAB, VK_CLEAR, VK_RETURN, VK_PAUSE, VK_CAPITAL, + VK_ESCAPE, VK_SPACE, VK_PRIOR, VK_NEXT, VK_END, VK_HOME, VK_LEFT, + VK_UP, VK_RIGHT, VK_DOWN, VK_SELECT, VK_EXECUTE, VK_SNAPSHOT, + VK_INSERT, VK_DELETE, VK_HELP, $30, $31, $32, $33, $34, $35, + $36, $37, $38, $39, $41, $42, $43, $44, $45, $46, $47, + $48, $49, $4A, $4B, $4C, $4D, $4E, $4F, $50, $51, $52, + $53, $54, $55, $56, $57, $58, $59, $5A, VK_LWIN, VK_RWIN, VK_APPS, + VK_NUMPAD0, VK_NUMPAD1, VK_NUMPAD2, VK_NUMPAD3, VK_NUMPAD4, VK_NUMPAD5, + VK_NUMPAD6, VK_NUMPAD7, VK_NUMPAD8, VK_NUMPAD9, VK_MULTIPLY, VK_ADD, + VK_SEPARATOR, VK_SUBTRACT, VK_DECIMAL, VK_DIVIDE, VK_F1, VK_F2, VK_F3, + VK_F4, VK_F5, VK_F6, VK_F7, VK_F8, VK_F9, VK_F10, VK_F11, VK_F12, + VK_F13, VK_F14, VK_F15, VK_F16, VK_F17, VK_F18, VK_F19, VK_F20, + VK_F21, VK_F22, VK_F23, VK_F24, VK_NUMLOCK, VK_SCROLL, VK_ATTN, + VK_CRSEL, VK_EXSEL, VK_EREOF, VK_PLAY, VK_ZOOM, VK_PA1, VK_OEM_CLEAR); + // Maxim Pushkar: +const + VirtualKeyNames: array[TVirtualKey] of string = + ('', 'Back' {'BackSpace'}, 'Tab', 'CLEAR', 'Enter', 'Pause', 'CapsLock', + 'Escape' {'Esc'}, 'Space', 'PageUp', 'PageDown', 'End', 'Home', 'Left', + 'Up', 'Right', 'Down', 'SELECT', 'EXECUTE', 'PrintScreen', + 'Ins', 'Delete' {'Del'}, 'Help' {'?'}, '0', '1', '2', '3', '4', '5', + '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', + 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', + 'U', 'V', 'W', 'X', 'Y', 'Z', 'LWin', 'RWin', 'APPS', + 'Numpad0', 'Numpad1', 'Numpad2', 'Numpad3', 'Numpad4', + 'Numpad5', 'Numpad6', 'Numpad7', 'Numpad8', 'Numpad9', + '*', '+', '|', '-', '.', '/', 'F1', 'F2', 'F3', 'F4', + 'F5', 'F6', 'F7', 'F8', 'F9', 'F10', 'F11', 'F12', 'F13', + 'F14', 'F15', 'F16', 'F17', 'F18', 'F19', 'F20', 'F21', + 'F22', 'F23', 'F24', 'NumLock', 'ScrollLock', 'ATTN', 'CRSEL', + 'EXSEL', 'EREOF', 'PLAY', 'ZOOM', 'PA1', 'OEMCLEAR'); procedure TKOLMenuItem.SetupAttributes(SL: TStringList; - const MenuName: String); -const Breaks: array[ TMenuBreak ] of String = ( 'mbrNone', 'mbrBreak', 'mbrBarBreak' ); -var I: Integer; - SI: TKOLMenuItem; - RsrcName: String; - S: String; - //F: TForm; - //FD: IFormDesigner; + const MenuName: string); +const + Breaks: array[TMenuBreak] of string = ('mbrNone', 'mbrBreak', 'mbrBarBreak'); +var + I: Integer; + SI: TKOLMenuItem; + RsrcName: string; + s: string; + //F: TForm; + //FD: IFormDesigner; begin asm jmp @@e_signature @@ -25096,90 +20371,83 @@ begin DB 'TKOLMenuItem.SetupAttributes', 0 @@e_signature: end; - RptDetailed( '->' + Name + ':TKOLMenuItem.SetupAttributes', RED ); + RptDetailed('->' + name + ':TKOLMenuItem.SetupAttributes', RED); if not Enabled and (Faction = nil) then - SL.Add( ' ' + MenuName + '.ItemEnabled[ ' + IntToStr( ItemIndex ) + ' ] := False;' ); + SL.Add(' ' + MenuName + '.ItemEnabled[ ' + IntToStr(itemindex) + ' ] := False;'); if not Visible and (Faction = nil) then - SL.Add( ' ' + MenuName + '.ItemVisible[ ' + IntToStr( ItemIndex ) + ' ] := False;' ); + SL.Add(' ' + MenuName + '.ItemVisible[ ' + IntToStr(itemindex) + ' ] := False;'); if (HelpContext <> 0) and (Faction = nil) then - SL.Add( ' ' + MenuName + '.ItemHelpContext[ ' + IntToStr( ItemIndex ) + ' ] := ' + - IntToStr( HelpContext ) + ';' ); - if (Bitmap <> nil) and (Bitmap.Width <> 0) and (Bitmap.Height <> 0) then - begin - RsrcName := MenuComponent.ParentForm.Name + '_' + Name + '_BMP'; - SL.Add( ' ' + MenuName + '.ItemBitmap[ ' + IntToStr( ItemIndex ) + - ' ] := LoadBmp( hInstance, ''' + UpperCase( RsrcName + '_BITMAP' ) + ''', ' + - MenuName + ' );' ); - SL.Add( ' {$R ' + RsrcName + '.res}' ); - GenerateBitmapResource( Bitmap, UPPERCASE( RsrcName + '_BITMAP' ), RsrcName, - MenuComponent.fUpdated, AllowBitmapCompression ); + SL.Add(' ' + MenuName + '.ItemHelpContext[ ' + IntToStr(itemindex) + ' ] := ' + + IntToStr(HelpContext) + ';'); + if (Bitmap <> nil) and (Bitmap.Width <> 0) and (Bitmap.Height <> 0) then begin + RsrcName := MenuComponent.ParentForm.name + '_' + name + '_BMP'; + SL.Add(' ' + MenuName + '.ItemBitmap[ ' + IntToStr(itemindex) + + ' ] := LoadBmp( hInstance, ''' + UpperCase(RsrcName + '_BITMAP') + ''', ' + + MenuName + ' );'); + SL.Add(' {$R ' + RsrcName + '.res}'); + GenerateBitmapResource(Bitmap, UpperCase(RsrcName + '_BITMAP'), RsrcName, + MenuComponent.fUpdated, AllowBitmapCompression); end; - if (BitmapChecked <> nil) and (bitmapChecked.Width <> 0) and (bitmapChecked.Height <> 0) then - begin - RsrcName := MenuComponent.ParentForm.Name + '_' + Name + '_BMPCHECKED'; - SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - ' ].BitmapChecked := LoadBmp( hInstance, ''' + UpperCase( RsrcName + '_BITMAP' ) + ''', ' + - MenuName + ' );' ); - SL.Add( ' {$R ' + RsrcName + '.res}' ); - GenerateBitmapResource( bitmapChecked, UPPERCASE( RsrcName ), RsrcName, - MenuComponent.fUpdated, AllowBitmapCompression ); + if (bitmapChecked <> nil) and (bitmapChecked.Width <> 0) and (bitmapChecked.Height <> 0) then begin + RsrcName := MenuComponent.ParentForm.name + '_' + name + '_BMPCHECKED'; + SL.Add(' ' + MenuName + '.Items[ ' + IntToStr(itemindex) + + ' ].BitmapChecked := LoadBmp( hInstance, ''' + UpperCase(RsrcName + '_BITMAP') + ''', ' + + MenuName + ' );'); + SL.Add(' {$R ' + RsrcName + '.res}'); + GenerateBitmapResource(bitmapChecked, UpperCase(RsrcName), RsrcName, + MenuComponent.fUpdated, AllowBitmapCompression); end; - if (BitmapItem <> nil) and (bitmapItem.Width <> 0) and (bitmapItem.Height <> 0) then - begin - RsrcName := MenuComponent.ParentForm.Name + '_' + Name + '_BMPITEM'; - SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - ' ].BitmapItem := LoadBmp( hInstance, ''' + UpperCase( RsrcName + '_BITMAP' ) + ''', ' + - MenuName + ' );' ); - SL.Add( ' {$R ' + RsrcName + '.res}' ); - GenerateBitmapResource( bitmapItem, UPPERCASE( RsrcName ), RsrcName, - MenuComponent.fUpdated, AllowBitmapCompression ); + if (bitmapItem <> nil) and (bitmapItem.Width <> 0) and (bitmapItem.Height <> 0) then begin + RsrcName := MenuComponent.ParentForm.name + '_' + name + '_BMPITEM'; + SL.Add(' ' + MenuName + '.Items[ ' + IntToStr(itemindex) + + ' ].BitmapItem := LoadBmp( hInstance, ''' + UpperCase(RsrcName + '_BITMAP') + ''', ' + + MenuName + ' );'); + SL.Add(' {$R ' + RsrcName + '.res}'); + GenerateBitmapResource(bitmapItem, UpperCase(RsrcName), RsrcName, + MenuComponent.fUpdated, AllowBitmapCompression); end; //-if FownerDraw then //- SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + //- ' ].OwnerDraw := TRUE;' ); if Fdefault then - SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - ' ].DefaultItem := TRUE;' ); - if FmenuBreak <> mbrNone then - SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - ' ].MenuBreak := ' + Breaks[ FmenuBreak ] + ';' ); + SL.Add(' ' + MenuName + '.Items[ ' + IntToStr(itemindex) + + ' ].DefaultItem := TRUE;'); + if FMenuBreak <> mbrNone then + SL.Add(' ' + MenuName + '.Items[ ' + IntToStr(itemindex) + + ' ].MenuBreak := ' + Breaks[FMenuBreak] + ';'); //if FOnMenuMethodName <> '' then begin - if CheckOnMenuMethodExists then - begin - RptDetailed( 'Menu ' + MenuName + '.AssignEvents: ' + - FOnMenuMethodName, RED ); - SL.Add( ' ' + MenuName + '.AssignEvents( ' + IntToStr( ItemIndex ) + // - ', [ Result.' + FOnMenuMethodName + ' ] );' ); // + if CheckOnMenuMethodExists then begin + RptDetailed('Menu ' + MenuName + '.AssignEvents: ' + + FOnMenuMethodName, RED); + SL.Add(' ' + MenuName + '.AssignEvents( ' + IntToStr(itemindex) + // + ', [ Result.' + FOnMenuMethodName + ' ] );'); // end - else - begin - RptDetailed( 'Menu ' + Name + ' has no event attached', RED ); + else begin + RptDetailed('Menu ' + name + ' has no event attached', RED); end; end; - if (Accelerator.Key <> vkNotPresent) and (Faction = nil) then - begin - S := 'FVIRTKEY'; - if kapShift in Accelerator.Prefix then - S := S + ' or FSHIFT'; - if kapControl in Accelerator.Prefix then - S := S + ' or FCONTROL'; - if kapAlt in Accelerator.Prefix then - S := S + ' or FALT'; - if kapNoinvert in Accelerator.Prefix then - S := S + ' or FNOINVERT'; - SL.Add( ' ' + MenuName + '.ItemAccelerator[ ' + IntToStr( ItemIndex ) + - ' ] := MakeAccelerator( ' + S + ', ' + VirtKeys[ Accelerator.Key ] + - ' );' ); + if (accelerator.Key <> vkNotPresent) and (Faction = nil) then begin + s := 'FVIRTKEY'; + if kapShift in accelerator.Prefix then + s := s + ' or FSHIFT'; + if kapControl in accelerator.Prefix then + s := s + ' or FCONTROL'; + if kapAlt in accelerator.Prefix then + s := s + ' or FALT'; + if kapNoinvert in accelerator.Prefix then + s := s + ' or FNOINVERT'; + SL.Add(' ' + MenuName + '.ItemAccelerator[ ' + IntToStr(itemindex) + + ' ] := MakeAccelerator( ' + s + ', ' + VirtKeys[accelerator.Key] + + ' );'); end; if Tag <> 0 then - SL.Add( ' ' + MenuName + '.Items[' + IntToStr( ItemIndex ) + - '].Tag := DWORD(' + IntToStr( Tag ) + ');' ); - for I := 0 to Count - 1 do - begin - SI := FSubItems[ I ]; - SI.SetupAttributes( SL, MenuName ); + SL.Add(' ' + MenuName + '.Items[' + IntToStr(itemindex) + + '].Tag := DWORD(' + IntToStr(Tag) + ');'); + for I := 0 to Count - 1 do begin + SI := FSubitems[I]; + SI.SetupAttributes(SL, MenuName); end; end; @@ -25191,13 +20459,15 @@ begin DB 'TKOLMenuItem.SetAccelerator', 0 @@e_signature: end; - if FAccelerator = Value then Exit; + if FAccelerator = Value then + Exit; FAccelerator := Value; Change; end; procedure TKOLMenuItem.LoadAccel(R: TReader); -var I: Integer; +var + I: Integer; begin asm jmp @@e_signature @@ -25206,16 +20476,16 @@ begin @@e_signature: end; I := R.ReadInteger; - FAccelerator.Prefix := [ ]; + FAccelerator.Prefix := []; if LongBool(I and $100) then - FAccelerator.Prefix := [ kapShift ]; + FAccelerator.Prefix := [kapShift]; if LongBool(I and $200) then - FAccelerator.Prefix := FAccelerator.Prefix + [ kapControl ]; + FAccelerator.Prefix := FAccelerator.Prefix + [kapControl]; if LongBool(I and $400) then - FAccelerator.Prefix := FAccelerator.Prefix + [ kapAlt ]; + FAccelerator.Prefix := FAccelerator.Prefix + [kapAlt]; if LongBool(I and $800) then - Faccelerator.Prefix := FAccelerator.Prefix + [ kapNoinvert ]; - FAccelerator.Key := TVirtualKey( I and $FF ); + FAccelerator.Prefix := FAccelerator.Prefix + [kapNoinvert]; + FAccelerator.Key := TVirtualKey(I and $FF); end; procedure TKOLMenuItem.LoadWindowMenu(R: TReader); @@ -25237,11 +20507,12 @@ begin DB 'TKOLMenuItem.SaveWindowMenu', 0 @@e_signature: end; - W.WriteBoolean( FWindowMenu ); + W.WriteBoolean(FWindowMenu); end; procedure TKOLMenuItem.SaveAccel(W: TWriter); -var I: Integer; +var + I: Integer; begin asm jmp @@e_signature @@ -25249,26 +20520,27 @@ begin DB 'TKOLMenuItem.SaveAccel', 0 @@e_signature: end; - I := Ord( Accelerator.Key ); - if kapShift in Accelerator.Prefix then + I := Ord(accelerator.Key); + if kapShift in accelerator.Prefix then I := I or $100; - if kapControl in Accelerator.Prefix then + if kapControl in accelerator.Prefix then I := I or $200; - if kapAlt in Accelerator.Prefix then + if kapAlt in accelerator.Prefix then I := I or $400; - if kapNoinvert in Accelerator.Prefix then + if kapNoinvert in accelerator.Prefix then I := I or $800; - W.WriteInteger( I ); + W.WriteInteger(I); end; procedure TKOLMenuItem.DesignTimeClick; -var F: TForm; - D: IDesigner; - FD: IFormDesigner; - EvntName: String; - TI: TTypeInfo; - TD: TTypeData; - Meth: TMethod; +var + F: TForm; + D: IDesigner; + FD: IFormDesigner; + EvntName: string; + TI: TTypeInfo; + TD: TTypeData; + Meth: TMethod; begin asm jmp @@e_signature @@ -25276,62 +20548,67 @@ begin DB 'TKOLMenuItem.DesignTimeClick', 0 @@e_signature: end; - Rpt( 'DesignTimeClick: ' + Caption, WHITE ); - if Count > 0 then Exit; + Rpt('DesignTimeClick: ' + Caption, WHITE); + if Count > 0 then + Exit; F := MenuComponent.ParentForm; - if F = nil then Exit; -//*/////////////////////////////////////////////////////// - {$IFDEF _D6orHigher} // - F.Designer.QueryInterface(IFormDesigner,D); // - {$ELSE} // -//*/////////////////////////////////////////////////////// - D := F.Designer; -//*/////////////////////////////////////////////////////// - {$ENDIF} // -//*/////////////////////////////////////////////////////// - if D = nil then Exit; - if not QueryFormDesigner( D, FD ) then Exit; + if F = nil then + Exit; + //*/////////////////////////////////////////////////////// +{$IFDEF _D6orHigher} // + F.Designer.QueryInterface(IFormDesigner, D); // +{$ELSE} // + //*/////////////////////////////////////////////////////// + D := F.Designer; + //*/////////////////////////////////////////////////////// +{$ENDIF} // + //*/////////////////////////////////////////////////////// + if D = nil then + Exit; + if not QueryFormDesigner(D, FD) then + Exit; //if D.QueryInterface( IFormDesigner, FD ) <> 0 then Exit; EvntName := FOnMenuMethodName; if EvntName = '' then - EvntName := MenuComponent.ParentKOLForm.Name + Name + 'Menu'; - if FD.MethodExists( EvntName ) then - begin + EvntName := MenuComponent.ParentKOLForm.name + name + 'Menu'; + if FD.MethodExists(EvntName) then begin FOnMenuMethodName := EvntName; - FD.ShowMethod( EvntName ); + FD.ShowMethod(EvntName); Change; Exit; end; TI.Kind := tkMethod; - TI.Name := 'TOnMenuItem'; + TI.name := 'TOnMenuItem'; TD.MethodKind := mkProcedure; TD.ParamCount := 2; TD.ParamList := 'Sender: PMenu; Item: Integer'#0#0; - Meth := FD.CreateMethod( EvntName, {@TD} GetTypeData( TypeInfo( TOnMenuItem ) ) ); - if Meth.Code <> nil then - begin + Meth := FD.CreateMethod(EvntName, {@TD} GetTypeData(TypeInfo(TOnMenuItem))); + if Meth.Code <> nil then begin FOnMenuMethodName := EvntName; - FD.ShowMethod( EvntName ); + FD.ShowMethod(EvntName); Change; end; end; procedure TKOLMenuItem.SetWindowMenu(Value: Boolean); - procedure ClearWindowMenuForSubMenus( MI: TKOLMenuItem ); - var I: Integer; - SMI: TKOLMenuItem; + +procedure ClearWindowMenuForSubMenus(MI: TKOLMenuItem); + var + I: Integer; + SMI: TKOLMenuItem; begin - for I := 0 to MI.Count-1 do - begin - SMI := MI.SubItems[ I ]; - if SMI = Self then continue; - SMI.WindowMenu := FALSE; - ClearWindowMenuForSubMenus( SMI ); + for I := 0 to MI.Count - 1 do begin + SMI := MI.SubItems[I]; + if SMI = Self then + Continue; + SMI.WindowMenu := False; + ClearWindowMenuForSubMenus(SMI); end; end; -var I: Integer; - Menu: TKOLMenu; - MI: TKOLMenuItem; +var + I: Integer; + Menu: TKOLMenu; + MI: TKOLMenuItem; begin asm jmp @@e_signature @@ -25341,19 +20618,19 @@ begin end; if csLoading in ComponentState then FWindowMenu := Value - else - begin + else begin Menu := MenuComponent; - if (Menu = nil) or not(Menu is TKOLMainMenu) then - Value := FALSE; - if FWindowMenu = Value then Exit; + if (Menu = nil) or not (Menu is TKOLMainMenu) then + Value := False; + if FWindowMenu = Value then + Exit; FWindowMenu := Value; - for I := 0 to Menu.Count-1 do - begin - MI := Menu.Items[ I ]; - if MI = Self then continue; - MI.WindowMenu := FALSE; - ClearWindowMenuForSubMenus( MI ); + for I := 0 to Menu.Count - 1 do begin + MI := Menu.Items[I]; + if MI = Self then + Continue; + MI.WindowMenu := False; + ClearWindowMenuForSubMenus(MI); end; Change; end; @@ -25361,9 +20638,9 @@ end; procedure TKOLMenuItem.SetHelpContext(const Value: Integer); begin - if Faction = nil then - begin - if FHelpContext = Value then Exit; + if Faction = nil then begin + if FHelpContext = Value then + Exit; FHelpContext := Value; end else @@ -25378,17 +20655,17 @@ end; procedure TKOLMenuItem.SaveHelpContext(W: TWriter); begin - W.WriteInteger( FHelpContext ); + W.WriteInteger(FHelpContext); end; procedure TKOLMenuItem.LoadRadioGroup(R: TReader); begin - FradioGroup := R.ReadInteger; + FRadioGroup := R.ReadInteger; end; procedure TKOLMenuItem.SaveRadioGroup(W: TWriter); begin - W.WriteInteger( FradioGroup ); + W.WriteInteger(FRadioGroup); end; procedure TKOLMenuItem.SetbitmapChecked(const Value: TBitmap); @@ -25405,21 +20682,24 @@ end; procedure TKOLMenuItem.Setdefault(const Value: Boolean); begin - if Fdefault = Value then Exit; + if Fdefault = Value then + Exit; Fdefault := Value; Change; end; procedure TKOLMenuItem.SetRadioGroup(const Value: Integer); begin - if FRadioGroup = Value then Exit; + if FRadioGroup = Value then + Exit; FRadioGroup := Value; Change; end; procedure TKOLMenuItem.SetownerDraw(const Value: Boolean); begin - if FownerDraw = Value then Exit; + if FownerDraw = Value then + Exit; FownerDraw := Value; Change; end; @@ -25431,29 +20711,31 @@ end; procedure TKOLMenuItem.SaveOwnerDraw(W: TWriter); begin - W.WriteBoolean( FownerDraw ); + W.WriteBoolean(FownerDraw); end; procedure TKOLMenuItem.SetMenuBreak(const Value: TMenuBreak); begin - if FMenuBreak = Value then Exit; + if FMenuBreak = Value then + Exit; FMenuBreak := Value; Change; end; procedure TKOLMenuItem.LoadMenuBreak(R: TReader); begin - FmenuBreak := TMenuBreak( R.ReadInteger ); + FMenuBreak := TMenuBreak(R.ReadInteger); end; procedure TKOLMenuItem.SaveMenuBreak(W: TWriter); begin - W.WriteInteger( Integer( FmenuBreak ) ); + W.WriteInteger(Integer(FMenuBreak)); end; procedure TKOLMenuItem.SetTag(const Value: Integer); begin - if Ftag = Value then Exit; + if FTag = Value then + Exit; FTag := Value; Change; end; @@ -25465,22 +20747,23 @@ end; procedure TKOLMenuItem.SaveTag(W: TWriter); begin - W.WriteInteger( FTag ); + W.WriteInteger(FTag); end; procedure TKOLMenuItem.LoadDefault(R: TReader); begin - Default := R.ReadBoolean; + default := R.ReadBoolean; end; procedure TKOLMenuItem.SaveDefault(W: TWriter); begin - W.WriteBoolean( Default ); + W.WriteBoolean(default); end; procedure TKOLMenuItem.Setaction(const Value: TKOLAction); begin - if Faction = Value then exit; + if Faction = Value then + Exit; if Faction <> nil then Faction.UnLinkComponent(Self); Faction := Value; @@ -25501,332 +20784,82 @@ end; procedure TKOLMenuItem.LoadAction(R: TReader); begin -// FActionComponentName:=R.ReadString; + // FActionComponentName:=R.ReadString; end; procedure TKOLMenuItem.SaveAction(W: TWriter); begin -{ - if Faction <> nil then - W.WriteString(Faction.GetNamePath) - else - W.WriteString(''); -} -end; - -function TKOLMenuItem.P_SetupTemplate(SL: TStringList; DoAdd: Boolean): Integer; - procedure Add2SL( const S: String ); - begin - if DoAdd then SL.Add( S ); - // иначе только посчитать число строк, но не добавлять - на первом просмотре - end; -var S, U: String; - I: Integer; - MI: TKOLMenuItem; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMenuItem.P_SetupTemplate', 0 - @@e_signature: - end; - if Separator then - S := '-' - else - begin - U := Caption; - if (U = '') or (Faction <> nil) then - U := ' '; - S := ''; - if FradioGroup <> 0 then - begin - S := '!' + S; - if (FParent <> nil) and (FParent is TKOLMenuItem) then - begin - I := (FParent as TKOLMenuItem).FSubitems.IndexOf( Self ); - if I > 0 then - begin - MI := (FParent as TKOLMenuItem).FSubItems[ I - 1 ]; - if (MI.FradioGroup <> 0) and (MI.FradioGroup <> FradioGroup) then - S := '!' + S; - end; - end; - if not Checked then - S := '-' + S; - end; - if Checked and (Faction = nil) then - S := '+' + S; - end; - if Accelerator.Key <> vkNotPresent then - if MenuComponent.showshortcuts and (Faction = nil) then - U := U + #9 + Accelerator.AsText; - if S = '' then - begin - //if Faction = nil then - S := //P_PCharStringConstant( MenuComponent, Name, U ) - P_String2Pascal( U ) - //else - //S := '''' + U + '''' - ; - //Rpt( 'string item:' + S, RED ); - end - else - begin - //S := '''' + S + ''' + '; - //U := MenuComponent.P_StringConstant( Name, U ); - //if (U <> '') and (U[ 1 ] <> '''') then - //S := 'PChar( ' + S + U + ')' - S := P_String2Pascal( S + U ); - //else - // S := S + U; - end; - {if not FirstItem then - S := ', ' + S;} - if Count > 0 then - begin - Result := 3; - Add2SL( ''')'' #0' ); - for I := Count - 1 downto 0 do - begin - MI := FSubItems[ I ]; - Result := Result + MI.P_SetupTemplate( SL, DoAdd ); - end; - Add2SL( '''('' #0' ); - end - else Result := 1; - Add2SL( S ); -end; - -procedure TKOLMenuItem.P_SetupAttributes(SL: TStringList; - const MenuName: String); - procedure CallAssignEvents( const EventProcName: String ); - begin - {P}SL.Add( ' LoadSELF Load4 ####T' + EventProcName ); - {P}SL.Add( ' LoadStack L(0) xySwap L(' + IntToStr( ItemIndex ) + ')' ); - {P}SL.Add( ' C5 TMenu_.AssignEvents<3> DEL DEL' ); - end; -//const Breaks: array[ TMenuBreak ] of String = ( 'mbrNone', 'mbrBreak', 'mbrBarBreak' ); -var I: Integer; - SI: TKOLMenuItem; - RsrcName: String; - F: TForm; - FD: IFormDesigner; - Flg: DWORD; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLMenuItem.P_SetupAttributes', 0 - @@e_signature: - end; - if not Enabled and (Faction = nil) then - //SL.Add( ' ' + MenuName + '.ItemEnabled[ ' + IntToStr( ItemIndex ) + ' ] := False;' ); - {P}SL.Add( ' L(0) L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.SetItemEnabled<3>' ); - if not Visible and (Faction = nil) then - //SL.Add( ' ' + MenuName + '.ItemVisible[ ' + IntToStr( ItemIndex ) + ' ] := False;' ); - {P}SL.Add( ' L(0) L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.SetItemVisible<3>' ); - if (HelpContext <> 0) and (Faction = nil) then - //SL.Add( ' ' + MenuName + '.ItemHelpContext[ ' + IntToStr( ItemIndex ) + ' ] := ' + - // IntToStr( HelpContext ) + ';' ); - {P}SL.Add( ' L(' + IntToStr( HelpContext ) + ') L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.SetItemHelpContext<3>' ); - if (Bitmap <> nil) and (Bitmap.Width <> 0) and (Bitmap.Height <> 0) then - begin - RsrcName := MenuComponent.ParentForm.Name + '_' + Name + '_BMP'; - //SL.Add( ' ' + MenuName + '.ItemBitmap[ ' + IntToStr( ItemIndex ) + - // ' ] := LoadBmp( hInstance, ''' + UpperCase( RsrcName + '_BITMAP' ) + ''', ' + - // MenuName + ' );' ); - {P}SL.Add( ' DUP LoadStr ''' + UpperCase( RsrcName + '_BITMAP' ) + ''' #0' ); - {P}SL.Add( ' LoadHInstance' + - ' LoadBmp<3> RESULT ' + - ' L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.SetItemBitmap<3>' ); - SL.Add( ' {$R ' + RsrcName + '.res}' ); //todo: в П-компиляторе перенести все - // такие строки в компилируемую часть кода!!!!!! - GenerateBitmapResource( Bitmap, UPPERCASE( RsrcName + '_BITMAP' ), RsrcName, - MenuComponent.fUpdated, AllowBitmapCompression ); - end; - if (BitmapChecked <> nil) and (bitmapChecked.Width <> 0) and (bitmapChecked.Height <> 0) then - begin - RsrcName := MenuComponent.ParentForm.Name + '_' + Name + '_BMPCHECKED'; - //SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - // ' ].BitmapChecked := LoadBmp( hInstance, ''' + UpperCase( RsrcName + '_BITMAP' ) + ''', ' + - // MenuName + ' );' ); - {P}SL.Add( ' DUP LoadStr ''' + UpperCase( RsrcName + '_BITMAP' ) + ''' #0' ); - {P}SL.Add( ' LoadHInstance ' + - ' LoadBmp<3> RESULT' + - ' L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.GetItems<2> RESULT' + - ' TMenu_.SetbitmapChecked<2>' ); - SL.Add( ' {$R ' + RsrcName + '.res}' ); - GenerateBitmapResource( bitmapChecked, UPPERCASE( RsrcName ), RsrcName, - MenuComponent.fUpdated, AllowBitmapCompression ); - end; - if (BitmapItem <> nil) and (bitmapItem.Width <> 0) and (bitmapItem.Height <> 0) then - begin - RsrcName := MenuComponent.ParentForm.Name + '_' + Name + '_BMPITEM'; - //SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - // ' ].BitmapChecked := LoadBmp( hInstance, ''' + UpperCase( RsrcName + '_BITMAP' ) + ''', ' + - // MenuName + ' );' ); - {P}SL.Add( ' DUP LoadStr ''' + UpperCase( RsrcName + '_BITMAP' ) + ''' #0' ); - {P}SL.Add( ' LoadHInstance ' + - ' LoadBmp<3> RESULT' + - ' L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.GetItems<2> RESULT' + - ' TMenu_.SetbitmapItem<2>' ); - SL.Add( ' {$R ' + RsrcName + '.res}' ); - GenerateBitmapResource( bitmapItem, UPPERCASE( RsrcName ), RsrcName, - MenuComponent.fUpdated, AllowBitmapCompression ); - end; - (**************** -> P_SetupAttributesLast - if FownerDraw then - //SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - // ' ].OwnerDraw := TRUE;' ); - {P}SL.Add( ' L(1) L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.GetItems<2> RESULT' + - ' TMenu_.SetownerDraw<2>' ); *****************) - if Fdefault then - //SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - // ' ].DefaultItem := TRUE;' ); - {P}SL.Add( ' L(1) L(' + IntToStr( MFS_DEFAULT ) + ')' + - ' L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.GetItems<2> RESULT' + - ' TMenu_.SetItemState<3>' ); - if FmenuBreak <> mbrNone then - //SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - // ' ].MenuBreak := ' + Breaks[ FmenuBreak ] + ';' ); - {P}SL.Add( ' L(' + IntToStr( Integer( FmenuBreak ) ) + ')' + - ' L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.GetItems<2> RESULT' + - ' TMenu_.SetMenuBreak<2>' ); - if FOnMenuMethodName <> '' then - begin - F := MenuComponent.ParentForm; -////////////////////////////////////////////////////////////////////////////////// - {$IFDEF _D6orHigher} // - if (F <> nil) and (F.Designer <> nil) then // - begin // - F.Designer.QueryInterface( IDesigner, FD ); // - if FD <>nil then // - //if F.Designer.QueryInterface( IFormDesigner, FD ) = 0 then // - if FD.MethodExists( FOnMenuMethodName ) then - CallAssignEvents( MenuComponent.ParentKOLForm.FormName + '.' + FOnMenuMethodName ); - //SL.Add( ' ' + MenuName + '.AssignEvents( ' + IntToStr( ItemIndex ) + // - // ', [ Result.' + FOnMenuMethodName + ' ] );' ); // - end; // - {$ELSE} // -////////////////////////////////////////////////////////////////////////////////// - if (F <> nil) and (F.Designer <> nil) then - if QueryFormDesigner( F.Designer, FD ) then - //if F.Designer.QueryInterface( IFormDesigner, FD ) = 0 then - if FD.MethodExists( FOnMenuMethodName ) then - CallAssignEvents( MenuComponent.ParentKOLForm.FormName + '.' + FOnMenuMethodName ); - //SL.Add( ' ' + MenuName + '.AssignEvents( ' + IntToStr( ItemIndex ) + - // ', [ Result.' + FOnMenuMethodName + ' ] );' ); -////////////////////////////////////////////////////////////////////////////////// - {$ENDIF} // -////////////////////////////////////////////////////////////////////////////////// - end; - if (Accelerator.Key <> vkNotPresent) and (Faction = nil) then - begin - Flg := FVIRTKEY; - if kapShift in Accelerator.Prefix then Flg := Flg or FSHIFT; - if kapControl in Accelerator.Prefix then Flg := Flg or FCONTROL; - if kapAlt in Accelerator.Prefix then Flg := Flg or FALT; - if kapNoinvert in Accelerator.Prefix then Flg := Flg or FNOINVERT; - //SL.Add( ' ' + MenuName + '.ItemAccelerator[ ' + IntToStr( ItemIndex ) + - // ' ] := MakeAccelerator( ' + S + ', ' + VirtKeys[ Accelerator.Key ] + - // ' );' ); - {P}SL.Add( ' L(' + IntToStr( VrtKeyVals[ Accelerator.Key ] ) + ') L(' + IntToStr( Flg ) + ')' + - ' MakeAccelerator<2> RESULT' + - ' L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.SetItemAccelerator<3>' ); - end; - if Tag <> 0 then - //SL.Add( ' ' + MenuName + '.Items[' + IntToStr( ItemIndex ) + - // '].Tag := DWORD(' + IntToStr( Tag ) + ');' ); - {P}SL.Add( ' L(' + IntToStr( Tag ) + ') L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.GetItems<2> RESULT' + - ' AddByte_Store #TObj_.FTag' ); - for I := 0 to Count - 1 do - begin - SI := FSubItems[ I ]; - SI.P_SetupAttributes( SL, MenuName ); - end; + { + if Faction <> nil then + W.WriteString(Faction.GetNamePath) + else + W.WriteString(''); + } end; function TKOLMenuItem.CheckOnMenuMethodExists: Boolean; -var F: TForm; - D: IDesigner; - FD: IFormDesigner; - EvntName: String; +var + F: TForm; + D: IDesigner; + FD: IFormDesigner; + EvntName: string; begin - RptDetailed( '-> CheckOnMenuMethodExists for ' + Name, BLUE ); - Result := FALSE; - TRY + RptDetailed('-> CheckOnMenuMethodExists for ' + name, BLUE); + Result := False; + try EvntName := FOnMenuMethodName; - if (EvntName = 'nil') then Exit; - RptDetailed( 'EvntName = ' + EvntName, BLUE ); + if (EvntName = 'nil') then + Exit; + RptDetailed('EvntName = ' + EvntName, BLUE); F := MenuComponent.ParentForm; - if F = nil then Exit; - RptDetailed( 'ParentForm obtained OK', BLUE ); - //*/////////////////////////////////////////////////////// - {$IFDEF _D6orHigher} // - F.Designer.QueryInterface(IFormDesigner,D); // - {$ELSE} // - //*/////////////////////////////////////////////////////// - D := F.Designer; - //*/////////////////////////////////////////////////////// - {$ENDIF} // - //*/////////////////////////////////////////////////////// - if D = nil then Exit; - RptDetailed( 'Designer for form obtained OK', BLUE ); - if not QueryFormDesigner( D, FD ) then Exit; + if F = nil then + Exit; + RptDetailed('ParentForm obtained OK', BLUE); + //*/////////////////////////////////////////////////////// +{$IFDEF _D6orHigher} // + F.Designer.QueryInterface(IFormDesigner, D); // +{$ELSE} // + //*/////////////////////////////////////////////////////// + D := F.Designer; + //*/////////////////////////////////////////////////////// +{$ENDIF} // + //*/////////////////////////////////////////////////////// + if D = nil then + Exit; + RptDetailed('Designer for form obtained OK', BLUE); + if not QueryFormDesigner(D, FD) then + Exit; //if D.QueryInterface( IFormDesigner, FD ) <> 0 then Exit; if not FD.MethodExists(EvntName) then - EvntName := MenuComponent.ParentKOLForm.Name + Name + 'Menu'; - RptDetailed( 'EvntName = ' + EvntName, BLUE ); - if FD.MethodExists( EvntName ) then - begin + EvntName := MenuComponent.ParentKOLForm.name + name + 'Menu'; + RptDetailed('EvntName = ' + EvntName, BLUE); + if FD.MethodExists(EvntName) then begin //RptDetailed( 'Method ' + EvntName + // ' exists: generate AssignEvents', RED ); FOnMenuMethodName := EvntName; - Result := TRUE; + Result := True; end - else - begin - RptDetailed( 'Method ' + EvntName + ' not exists', BLUE ); + else begin + RptDetailed('Method ' + EvntName + ' not exists', BLUE); end; - FINALLY + finally if not Result then FOnMenuMethodName := ''; - END; + end; end; procedure TKOLMenuItem.SetupAttributesLast(SL: TStringList; - const MenuName: String); + const MenuName: string); begin if FownerDraw then - SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - ' ].OwnerDraw := TRUE;' ); -end; - -procedure TKOLMenuItem.P_SetupAttributesLast(SL: TStringList; - const MenuName: String); -begin - if FownerDraw then - //SL.Add( ' ' + MenuName + '.Items[ ' + IntToStr( ItemIndex ) + - // ' ].OwnerDraw := TRUE;' ); - {P}SL.Add( ' L(1) L(' + IntToStr( ItemIndex ) + ')' + - ' C2 TMenu_.GetItems<2> RESULT' + - ' TMenu_.SetownerDraw<2>' ); + SL.Add(' ' + MenuName + '.Items[ ' + IntToStr(itemindex) + + ' ].OwnerDraw := TRUE;'); end; procedure TKOLMenuItem.SetAllowBitmapCompression(const Value: Boolean); begin - if FAllowBitmapCompression = Value then Exit; + if FAllowBitmapCompression = Value then + Exit; FAllowBitmapCompression := Value; Change; end; @@ -25834,8 +20867,9 @@ end; { TKOLMenuEditor } procedure TKOLMenuEditor.Edit; -var M: TKOLMenu; - S: String; +var + M: TKOLMenu; + s: string; begin asm jmp @@e_signature @@ -25843,24 +20877,24 @@ begin DB 'TKOLMenuEditor.Edit', 0 @@e_signature: end; - if Component = nil then Exit; - if not(Component is TKOLMenu) then Exit; + if Component = nil then + Exit; + if not (Component is TKOLMenu) then + Exit; M := Component as TKOLMenu; - if M.ActiveDesign <> nil then - begin + if M.ActiveDesign <> nil then begin M.ActiveDesign.MenuComponent := M; //M.ActiveDesign.Designer := Designer; M.ActiveDesign.Visible := True; - SetForegroundWindow( M.ActiveDesign.Handle ); + SetForegroundWindow(M.ActiveDesign.Handle); M.ActiveDesign.MakeActive; end - else - begin - M.ActiveDesign := TKOLMenuDesign.Create( Application ); - S := M.Name; + else begin + M.ActiveDesign := TKOLMenuDesign.Create(Application); + s := M.name; if M.ParentKOLForm <> nil then - S := M.ParentKOLForm.FormName + '.' + S; - M.ActiveDesign.Caption := S; + s := M.ParentKOLForm.formName + '.' + s; + M.ActiveDesign.Caption := s; M.ActiveDesign.MenuComponent := M; end; if M.ParentForm <> nil then @@ -25911,20 +20945,21 @@ begin @@e_signature: end; - Log( '->TKOLMainMenu.Change' ); //dufa - try //dufa + Log('->TKOLMainMenu.Change'); + try inherited; RebuildMenubar; - LogOK; //dufa - finally //dufa - Log( '<-TKOLMainMenu.Change' ); //dufa + LogOK; + finally + Log('<-TKOLMainMenu.Change'); end; end; constructor TKOLMainMenu.Create(AOwner: TComponent); -var F: TForm; - I: Integer; - C: TComponent; +var + F: TForm; + I: Integer; + c: TComponent; begin asm jmp @@e_signature @@ -25933,41 +20968,43 @@ begin @@e_signature: end; - Log('->TKOLMainMenu.Create'); //dufa - try //dufa + Log('->TKOLMainMenu.Create'); + try inherited; F := ParentForm; - if F = nil then Exit; - for I := 0 to F.ComponentCount - 1 do - begin - C := F.Components[ I ]; - if C = Self then continue; - if C is TKOLMainMenu then - begin - ShowMessage( 'Another TKOLMainMenu component is already found on form ' + - F.Name + ' ( ' + C.Name + ' ). ' + - 'Remember, please, that only one instance of TKOLMainMenu ' + - 'should be placed on a form. Otherwise, code will be ' + - 'generated only for one of those.' ); + if F = nil then + Exit; + for I := 0 to F.ComponentCount - 1 do begin + c := F.Components[I]; + if c = Self then + Continue; + if c is TKOLMainMenu then begin + Showmessage('Another TKOLMainMenu component is already found on form ' + + F.name + ' ( ' + c.name + ' ). ' + + 'Remember, please, that only one instance of TKOLMainMenu ' + + 'should be placed on a form. Otherwise, code will be ' + + 'generated only for one of those.'); Exit; end; end; - LogOK; //dufa - finally //dufa - Log('<-TKOLMainMenu.Create'); //dufa - end; //dufa + LogOK; + finally + Log('<-TKOLMainMenu.Create'); + end; end; //dufa var CommonOldWndProc: Pointer; dufa -function WndProcDesignMenu( Wnd: HWnd; uMsg: DWORD; wParam, lParam: Integer ): Integer; stdcall; -var Id: Integer; - M: HMenu; - MII: TMenuItemInfo; - KMI: TKOLMenuItem; - C: TControl; - F: TForm; - I: Integer; - KMM: TKOLMainMenu; //dufa + +function WndProcDesignMenu(Wnd: HWnd; uMsg: DWORD; wParam, lParam: Integer): Integer; stdcall; +var + Id: Integer; + M: HMenu; + MII: TMenuItemInfo; + KMI: TKOLMenuItem; + c: TControl; + F: TForm; + I: Integer; + KMM: TKOLMainMenu; //dufa begin asm jmp @@e_signature @@ -25976,70 +21013,64 @@ begin @@e_signature: end; case uMsg of - WM_COMMAND: - begin - if (lParam = 0) and (HIWORD( wParam ) <= 1) then - begin - Id := LoWord( wParam ); - M := GetMenu( Wnd ); - if M <> 0 then - begin - Fillchar( MII, 44, 0 ); - MII.cbsize := 44; - MII.fMask := MIIM_DATA; - if GetMenuItemInfo( M, Id, False, MII ) then - begin - KMI := Pointer( MII.dwItemData ); - if KMI <> nil then - begin - try - if KMI is TKOLMenuItem then - begin - //Rpt( 'Click on ' + KMI.Caption ); - KMI.DesignTimeClick; - Result := 0; - Exit; - end; - except - on E: Exception do - begin - ShowMessage( 'Design-time click failed, exception: ' + E.Message ); + WM_COMMAND: begin + if (lParam = 0) and (HIWORD(wParam) <= 1) then begin + Id := LoWord(wParam); + M := GetMenu(Wnd); + if M <> 0 then begin + FillChar(MII, 44, 0); + MII.cbsize := 44; + MII.fMask := MIIM_DATA; + if GetMenuItemInfo(M, Id, False, MII) then begin + KMI := Pointer(MII.dwItemData); + if KMI <> nil then begin + try + if KMI is TKOLMenuItem then begin + //Rpt( 'Click on ' + KMI.Caption ); + KMI.DesignTimeClick; + Result := 0; + Exit; + end; + except + on E: Exception do begin + Showmessage('Design-time click failed, exception: ' + E.Message); + end; end; end; end; end; end; end; - end; - WM_DESTROY: - begin - M := GetMenu(Wnd); - SetMenu(Wnd, 0); - if (M <> 0) then begin - C := FindControl(Wnd); - if Assigned(C) and (C is TForm) then begin - F := (C as TForm); - for I := 0 to F.ComponentCount - 1 do begin - if (F.Components[I] is TKOLMainMenu) then begin - DestroyMenu(M); - KMM := (F.Components[I] as TKOLMainMenu); - KMM.RestoreWndProc(Wnd); - break; + WM_DESTROY: begin + M := GetMenu(Wnd); + SetMenu(Wnd, 0); + if (M <> 0) then begin + c := FindControl(Wnd); + if Assigned(c) and (c is TForm) then begin + F := (c as TForm); + for I := 0 to F.ComponentCount - 1 do begin + if (F.Components[I] is TKOLMainMenu) then begin + DestroyMenu(M); + KMM := (F.Components[I] as TKOLMainMenu); + KMM.RestoreWndProc(Wnd); + Break; + end; end; - end; - end else - DestroyMenu(M); + end + else + DestroyMenu(M); + end; end; - end; end; Result := CallWindowProc(Pointer(GetWindowLong(Wnd, GWL_USERDATA)), Wnd, uMsg, wParam, lParam); //dufa //dufa Result := CallWindowProc( CommonOldWndProc, Wnd, uMsg, wParam, lParam ); end; destructor TKOLMainMenu.Destroy; -var F: TForm; - KF: TKOLForm; - M: HMenu; +var + F: TForm; + KF: TKOLForm; + M: HMenu; begin asm jmp @@e_signature @@ -26048,35 +21079,32 @@ begin @@e_signature: end; - Log('->TKOLMainMenu.Destroy'); //dufa - try //dufa + Log('->TKOLMainMenu.Destroy'); + try F := ParentForm; KF := nil; - if F <> nil then - begin + if F <> nil then begin KF := ParentKOLForm; end; - if F <> nil then - begin + if F <> nil then begin M := 0; if F.HandleAllocated then - if F.Handle <> 0 then - begin - M := GetMenu( F.Handle ); - RestoreWndProc( F.Handle ); - SetMenu( F.Handle, 0 ); - end; + if F.Handle <> 0 then begin + M := GetMenu(F.Handle); + RestoreWndProc(F.Handle); + SetMenu(F.Handle, 0); + end; if M <> 0 then - DestroyMenu( M ); + DestroyMenu(M); end; inherited; if KF <> nil then - KF.AlignChildren( nil, FALSE ); + KF.AlignChildren(nil, False); - LogOK; //dufa - finally //dufa - Log('<-TKOLMainMenu.Destroy'); //dufa - end; //dufa + LogOK; + finally + Log('<-TKOLMainMenu.Destroy'); + end; end; procedure TKOLMainMenu.Loaded; @@ -26089,8 +21117,8 @@ begin @@e_signature: end; - Log( '->TKOLMainMenu.Loaded' ); //dufa - try //dufa + Log('->TKOLMainMenu.Loaded'); + try inherited; {KF := ParentKOLForm; if KF <> nil then @@ -26101,88 +21129,87 @@ begin end;} //UpdateDesign; RebuildMenubar; - LogOK; //dufa - finally //dufa - Log( '<-TKOLMainMenu.Loaded' ); //dufa + LogOK; + finally + Log('<-TKOLMainMenu.Loaded'); end; end; procedure TKOLMainMenu.RebuildMenubar; -var F: TForm; - M: HMenu; - KMI: TKOLMenuItem; - I: Integer; +var + F: TForm; + M: HMenu; + KMI: TKOLMenuItem; + I: Integer; - procedure BuildMenuItem( ParentMenu: HMenu; KMI: TKOLMenuItem ); - var MII: TMenuItemInfo; - S: String; - J: Integer; - begin - asm + procedure BuildMenuItem(ParentMenu: HMenu; KMI: TKOLMenuItem); + var + MII: TMenuItemInfo; + s: string; + j: Integer; + begin + asm jmp @@e_signature DB '#$signature$#', 0 DB 'TKOLMainMenu.RebuildMenubar.BuildMenuItem', 0 @@e_signature: - end; - FillChar( MII, 44, 0 ); + end; + FillChar(MII, 44, 0); - if KMI.Separator then - S := '-' - else - begin - S := KMI.Caption; - if S = '' then S := ' '; - if showshortcuts and (KMI.Accelerator.Key <> vkNotPresent) then - S := S + #9 + KMI.Accelerator.AsText; - end; - - MII.cbSize := 44; - MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE - or MIIM_CHECKMARKS; - MII.dwItemData := Integer(KMI); - if KMI.Separator then - begin - MII.fType := MFT_SEPARATOR; - MII.fState := MFS_GRAYED; - end - else - begin - MII.fType := MFT_STRING; - MII.dwTypeData := PChar( S ); - MII.cch := StrLen( PAnsiChar( AnsiString(S) ) ); // TODO: KOL_ANSI - if KMI.FradioGroup <> 0 then - begin - MII.fType := MII.fType or MFT_RADIOCHECK; - //MII.dwItemData := MII.dwItemData or MIDATA_RADIOITEM; - end; - if KMI.Checked then - begin - //if not KMI.RadioItem then - // MII.dwItemData := MII.dwItemData or MIDATA_CHECKITEM; - MII.fState := MII.fState or MFS_CHECKED; - end; - if not KMI.Enabled then - MII.fState := MFS_GRAYED; - if (KMI.Bitmap <> nil) and (KMI.Bitmap.Width * KMI.Bitmap.Height > 0) then - MII.hBmpUnchecked := KMI.Bitmap.Handle; - MII.wID := 100 + KMI.itemIndex; - if KMI.Count > 0 then - begin - MII.hSubmenu := CreatePopupMenu; - for J := 0 to KMI.Count - 1 do - BuildMenuItem( MII.hSubMenu, KMI.FSubItems[ J ] ); - end; - end; - InsertMenuItem( ParentMenu, Cardinal(-1), True, MII ); + if KMI.separator then + s := '-' + else begin + s := KMI.Caption; + if s = '' then + s := ' '; + if showShortcuts and (KMI.accelerator.Key <> vkNotPresent) then + s := s + #9 + KMI.accelerator.AsText; end; -var oldM: HMenu; - oldWndProc: Pointer; - KF: TKOLForm; -var bott: Integer; - C: TComponent; - K: TKOLCustomControl; - ListAnchoredBottomControls: TList; + MII.cbsize := 44; + MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE + or MIIM_CHECKMARKS; + MII.dwItemData := Integer(KMI); + if KMI.separator then begin + MII.fType := MFT_SEPARATOR; + MII.fState := MFS_GRAYED; + end + else begin + MII.fType := MFT_STRING; + MII.dwTypeData := PChar(s); + MII.cch := StrLen(PAnsiChar(AnsiString(s))); // TODO: KOL_ANSI + if KMI.FRadioGroup <> 0 then begin + MII.fType := MII.fType or MFT_RADIOCHECK; + //MII.dwItemData := MII.dwItemData or MIDATA_RADIOITEM; + end; + if KMI.checked then begin + //if not KMI.RadioItem then + // MII.dwItemData := MII.dwItemData or MIDATA_CHECKITEM; + MII.fState := MII.fState or MFS_CHECKED; + end; + if not KMI.Enabled then + MII.fState := MFS_GRAYED; + if (KMI.Bitmap <> nil) and (KMI.Bitmap.Width * KMI.Bitmap.Height > 0) then + MII.hBmpUnchecked := KMI.Bitmap.Handle; + MII.wID := 100 + KMI.itemindex; + if KMI.Count > 0 then begin + MII.hSubmenu := CreatePopupMenu; + for j := 0 to KMI.Count - 1 do + BuildMenuItem(MII.hSubmenu, KMI.FSubitems[j]); + end; + end; + InsertMenuItem(ParentMenu, Cardinal(-1), True, MII); + end; + +var + oldM: HMenu; + OldWndProc: Pointer; + KF: TKOLForm; +var + bott: Integer; + c: TComponent; + k: TKOLCustomControl; + ListAnchoredBottomControls: TList; begin asm jmp @@e_signature @@ -26190,96 +21217,88 @@ begin DB 'TKOLMainMenu.RebuildMenubar', 0 @@e_signature: end; - if (csDestroying in ComponentState) then Exit; - if FUpdateDisabled then - begin - FUpdateNeeded := TRUE; + if (csDestroying in ComponentState) then + Exit; + if FUpdateDisabled then begin + FUpdateNeeded := True; Exit; end; ListAnchoredBottomControls := nil; - if (Owner <> nil) and (Owner is TForm) then - begin - for i := 0 to (Owner as TForm).ComponentCount-1 do - begin - C := (Owner as TForm).Components[ i ]; - if C is TKOLCustomControl then - begin - K := C as TKOLCustomControl; - if K.FAnchorBottom and (K.Parent = Owner) then - begin + if (Owner <> nil) and (Owner is TForm) then begin + for I := 0 to (Owner as TForm).ComponentCount - 1 do begin + c := (Owner as TForm).Components[I]; + if c is TKOLCustomControl then begin + k := c as TKOLCustomControl; + if k.FAnchorBottom and (k.Parent = Owner) then begin if ListAnchoredBottomControls = nil then ListAnchoredBottomControls := TList.Create; - ListAnchoredBottomControls.Add( K ); - ListAnchoredBottomControls.Add( Pointer( K.Top + K.Height ) ); + ListAnchoredBottomControls.Add(k); + ListAnchoredBottomControls.Add(Pointer(k.Top + k.Height)); end; end; end; end; - TRY + try F := ParentForm; - if F = nil then Exit; - oldM := GetMenu( F.Handle ); + if F = nil then + Exit; + oldM := GetMenu(F.Handle); F.Menu := nil; M := CreateMenu; - for I := 0 to Count - 1 do - begin - KMI := FItems[ I ]; - BuildMenuItem( M, KMI ); + for I := 0 to Count - 1 do begin + KMI := FItems[I]; + BuildMenuItem(M, KMI); end; //F.Menu := M; // - Log('suka: ' + IntToStr(F.Handle) + ' | ' + IntToHex(Integer(Self), 8)); //dufa - i := GetWindowLong(F.Handle, GWL_STYLE) and not WS_CHILD; //dufa - SetWindowLong(F.Handle, GWL_STYLE, i); //dufa - // - SetMenu( F.Handle, M ); + Log('HandleSelf: ' + IntToStr(F.Handle) + ' | ' + IntToHex(Integer(Self), 8)); //dufa + I := GetWindowLong(F.Handle, GWL_STYLE) and not WS_CHILD; //dufa + SetWindowLong(F.Handle, GWL_STYLE, I); //dufa + // + SetMenu(F.Handle, M); if oldM <> 0 then - DestroyMenu( oldM ); - Integer(oldWndProc) := GetWindowLong( F.Handle, GWL_WNDPROC ); - if oldWndProc <> @WndProcDesignMenu then - begin - Rpt( 'Reset WndProc (old: ' + IntToStr( Integer(oldWndProc) ) + ' )', - WHITE ); + DestroyMenu(oldM); + Integer(OldWndProc) := GetWindowLong(F.Handle, GWL_WNDPROC); + if OldWndProc <> @WndProcDesignMenu then begin + Rpt('Reset WndProc (old: ' + IntToStr(Integer(OldWndProc)) + ' )', WHITE); //dufa CommonOldWndProc := oldWndProc; - FoldWndProc := oldWndProc; - SetWindowLong( F.Handle, GWL_USERDATA, Integer( oldWndProc ) ); //dufa - SetWindowLong( F.Handle, GWL_WNDPROC, Integer( @WndProcDesignMenu ) ); + FOldWndProc := OldWndProc; + SetWindowLong(F.Handle, GWL_USERDATA, Integer(OldWndProc)); //dufa + SetWindowLong(F.Handle, GWL_WNDPROC, Integer(@WndProcDesignMenu)); end; - FINALLY + finally KF := ParentKOLForm; - if KF <> nil then - begin - KF.AllowRealign := TRUE; + if KF <> nil then begin + KF.AllowRealign := True; if not (csLoading in KF.ComponentState) then - KF.AlignChildren( nil, FALSE ); + KF.AlignChildren(nil, False); end; - if ListAnchoredBottomControls <> nil then - begin - for i := 0 to ListAnchoredBottomControls.Count-2 do - if i mod 2 = 0 then - begin - K := ListAnchoredBottomControls[ i ]; - bott := Integer( ListAnchoredBottomControls[ i+1 ] ); - TRY - if K.FAnchorTop then - K.Height := bott - K.Top - else - K.Top := bott - K.Height; - EXCEPT - END; - end; - ListAnchoredBottomControls.Free; + if ListAnchoredBottomControls <> nil then begin + for I := 0 to ListAnchoredBottomControls.Count - 2 do + if I mod 2 = 0 then begin + k := ListAnchoredBottomControls[I]; + bott := Integer(ListAnchoredBottomControls[I + 1]); + try + if k.FAnchorTop then + k.Height := bott - k.Top + else + k.Top := bott - k.Height; + except + end; + end; + ListAnchoredBottomControls.free; //ListAnchoredBottomControls := nil; end; - END; + end; end; -procedure TKOLMainMenu.RestoreWndProc( Wnd: HWnd ); -var CurwndProc: Pointer; +procedure TKOLMainMenu.RestoreWndProc(Wnd: HWnd); +var + CurwndProc: Pointer; begin asm jmp @@e_signature @@ -26288,18 +21307,17 @@ begin @@e_signature: end; - Log('->TKOLMainMenu.RestoreWndProc'); //dufa - try //dufa - Integer(CurWndProc) := GetWindowLong( Wnd, GWL_WNDPROC ); - if CurWndProc = @WndProcDesignMenu then - begin + Log('->TKOLMainMenu.RestoreWndProc'); + try + Integer(CurwndProc) := GetWindowLong(Wnd, GWL_WNDPROC); + if CurwndProc = @WndProcDesignMenu then begin //dufa SetWindowLong( Wnd, GWL_WNDPROC, Integer( CommonOldWndProc ) ); - SetWindowLong( Wnd, GWL_WNDPROC, Integer( FOldWndProc ) ); //dufa + SetWindowLong(Wnd, GWL_WNDPROC, Integer(FOldWndProc)); //dufa end; - LogOK; //dufa - finally //dufa - Log('<-TKOLMainMenu.RestoreWndProc'); //dufa - end; //dufa + LogOK; + finally + Log('<-TKOLMainMenu.RestoreWndProc'); + end; end; procedure TKOLMainMenu.UpdateMenu; @@ -26317,7 +21335,7 @@ end; { TKOLPopupMenu } -procedure TKOLPopupMenu.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLPopupMenu.AssignEvents(SL: TStringList; const AName: string); begin asm jmp @@e_signature @@ -26327,57 +21345,13 @@ begin end; inherited; - DoAssignEvents( SL, AName, [ 'OnPopup' ], [ @ OnPopup ] ); -end; - -function TKOLPopupMenu.P_AssignEvents(SL: TStringList; const AName: String; CheckOnly: Boolean): Boolean; -begin - asm - jmp @@e_signature - DB '#$signature$#', 0 - DB 'TKOLPopupMenu.P_AssignEvents', 0 - @@e_signature: - end; - - Result := TRUE; - if P_DoAssignEvents( SL, AName, [ 'OnPopup' ], [ @ OnPopup ], [ FALSE ], CheckOnly ) and CheckOnly then - Exit; - Result := FALSE; -end; - -procedure TKOLPopupMenu.P_DoProvideFakeType(SL: TStringList); -begin - // prevent adding: TPopupMenu = object( KOL.TPopupMenu ) end; - P_ProvideFakeType( SL, 'type TPopupMenu_ = object(KOL.TMenu) end;' ); -end; - -procedure TKOLPopupMenu.P_SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); -var Flg: DWORD; -begin - inherited; - if Count = 0 then Exit; {+ecm} - if Flags <> [ ] then - begin - Flg := 0; - if tpmVertical in Flags then Flg := TPM_VERTICAL; - if tpmRightButton in Flags then Flg := Flg or TPM_RIGHTBUTTON; - if tpmCenterAlign in Flags then Flg := Flg or TPM_CENTERALIGN; - if tpmRightAlign in Flags then Flg := Flg or TPM_RIGHTALIGN; - if tpmVCenterAlign in Flags then Flg := Flg or TPM_VCENTERALIGN; - if tpmBottomAlign in Flags then Flg := Flg or TPM_BOTTOMALIGN; - if tpmHorPosAnimation in Flags then Flg := Flg or TPM_HORPOSANIMATION; - if tpmHorNegAnimation in Flags then Flg := Flg or TPM_HORNEGANIMATION; - if tpmVerPosAnimation in Flags then Flg := Flg or TPM_VERPOSANIMATION; - if tpmVerNegAnimation in Flags then Flg := Flg or TPM_VERNEGANIMATION; - if tpmNoAnimation in Flags then Flg := Flg or TPM_NOANIMATION; - if tpmReturnCmd in Flags then Flg := Flg or TPM_RETURNCMD; {+ecm} - {P}SL.Add( ' L(' + IntToStr( Flg ) + ') C1 AddByte_Store #TMenu_.FPopupFlags' ); - end; + DoAssignEvents(SL, AName, ['OnPopup'], [@OnPopup]); end; procedure TKOLPopupMenu.SetFlags(const Value: TPopupMenuFlags); begin - if FFlags = Value then Exit; + if FFlags = Value then + Exit; FFlags := Value; Change; end; @@ -26390,43 +21364,58 @@ begin DB 'TKOLPopupMenu.SetOnPopup', 0 @@e_signature: end; - if @ FOnPopup = @ Value then Exit; + if @FOnPopup = @Value then + Exit; FOnPopup := Value; Change; end; procedure TKOLPopupMenu.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -var S: String; + Prefix: string); +var + s: string; begin inherited; - if Count = 0 then Exit; {+ecm} - if Flags <> [ ] then - begin - if tpmVertical in Flags then S := S + 'TPM_VERTICAL or '; - if tpmRightButton in Flags then S := S + 'TPM_RIGHTBUTTON or '; - if tpmCenterAlign in Flags then S := S + 'TPM_CENTERALIGN or '; - if tpmRightAlign in Flags then S := S + 'TPM_RIGHTALIGN or '; - if tpmVCenterAlign in Flags then S := S + 'TPM_VCENTERALIGN or '; - if tpmBottomAlign in Flags then S := S + 'TPM_BOTTOMALIGN or '; - if tpmHorPosAnimation in Flags then S := S + 'TPM_HORPOSANIMATION or '; - if tpmHorNegAnimation in Flags then S := S + 'TPM_HORNEGANIMATION or '; - if tpmVerPosAnimation in Flags then S := S + 'TPM_VERPOSANIMATION or '; - if tpmVerNegAnimation in Flags then S := S + 'TPM_VERNEGANIMATION or '; - if tpmNoAnimation in Flags then S := S + 'TPM_NOANIMATION or '; - if tpmReturnCmd in Flags then S := S + 'TPM_RETURNCMD or '; {+ecm} - S := Copy(S,1,Length(S)-4); - SL.Add( Prefix + AName + '.Flags := ' + S + ';' ); + if Count = 0 then + Exit; {+ecm} + if Flags <> [] then begin + if tpmVertical in Flags then + s := s + 'TPM_VERTICAL or '; + if tpmRightButton in Flags then + s := s + 'TPM_RIGHTBUTTON or '; + if tpmCenterAlign in Flags then + s := s + 'TPM_CENTERALIGN or '; + if tpmRightAlign in Flags then + s := s + 'TPM_RIGHTALIGN or '; + if tpmVCenterAlign in Flags then + s := s + 'TPM_VCENTERALIGN or '; + if tpmBottomAlign in Flags then + s := s + 'TPM_BOTTOMALIGN or '; + if tpmHorPosAnimation in Flags then + s := s + 'TPM_HORPOSANIMATION or '; + if tpmHorNegAnimation in Flags then + s := s + 'TPM_HORNEGANIMATION or '; + if tpmVerPosAnimation in Flags then + s := s + 'TPM_VERPOSANIMATION or '; + if tpmVerNegAnimation in Flags then + s := s + 'TPM_VERNEGANIMATION or '; + if tpmNoAnimation in Flags then + s := s + 'TPM_NOANIMATION or '; + if tpmReturnCmd in Flags then + s := s + 'TPM_RETURNCMD or '; {+ecm} + s := Copy(s, 1, Length(s) - 4); + SL.Add(Prefix + AName + '.Flags := ' + s + ';'); end; end; { TKOLOnItemPropEditor } function TKOLOnItemPropEditor.GetValue: string; -var Comp: TPersistent; - F: TForm; - D: IDesigner; - FD: IFormDesigner; +var + Comp: TPersistent; + F: TForm; + D: IDesigner; + FD: IFormDesigner; begin asm jmp @@e_signature @@ -26435,66 +21424,65 @@ begin @@e_signature: end; Result := inherited GetValue; - if Result = '' then - begin - Comp := GetComponent( 0 ); + if Result = '' then begin + Comp := GetComponent(0); if Comp <> nil then - if Comp is TKOLMenuItem then - begin - Result := (Comp as TKOLMenuItem).FOnMenuMethodName; - { - if Result <> '' then - begin - Rpt( 'inherited OnMenu=NULL, but name is ' + Result + ', trying to restore correct value' ); - SetValue( Result ); - Result := inherited GetValue; - Rpt( '--------- OnMenu=' + Result ); + if Comp is TKOLMenuItem then begin + Result := (Comp as TKOLMenuItem).FOnMenuMethodName; + { + if Result <> '' then + begin + Rpt( 'inherited OnMenu=NULL, but name is ' + Result + ', trying to restore correct value' ); + SetValue( Result ); + Result := inherited GetValue; + Rpt( '--------- OnMenu=' + Result ); + end; + } end; - } + end; + try + + Comp := GetComponent(0); + if (Comp <> nil) and + (Comp is TKOLMenuItem) and + ((Comp as TKOLMenuItem).MenuComponent <> nil) then begin + F := ((Comp as TKOLMenuItem).MenuComponent as TKOLMenu).ParentForm; + if (F = nil) or (F.Designer = nil) then begin + Result := ''; + Exit; + end; + //*/////////////////////////////////////////////////////// +{$IFDEF _D6orHigher} // + F.Designer.QueryInterface(IFormDesigner, D); // +{$ELSE} // + //*/////////////////////////////////////////////////////// + D := F.Designer; + //*/////////////////////////////////////////////////////// +{$ENDIF} // + //*/////////////////////////////////////////////////////// + if QueryFormDesigner(D, FD) then + {//if D.QueryInterface( IFormDesigner, FD ) = 0 then} begin + if not FD.MethodExists(Result) then + Result := ''; + end + else + Result := ''; + end + else + Result := ''; + + except + on E: Exception do begin + Rpt('Exception while retrieving property OnMenu of TKOLMenuItem', RED); + Showmessage('Could not retrieve TKOLMenuItem.OnMenu, exception: ' + E.Message); end; end; - TRY - - Comp := GetComponent( 0 ); - if (Comp <> nil) and - (Comp is TKOLMenuItem) and - ((Comp as TKOLMenuItem).MenuComponent <> nil) then - begin - F := ((Comp as TKOLMenuItem).MenuComponent as TKOLMenu).ParentForm; - if (F = nil) or (F.Designer = nil) then - begin - Result := ''; Exit; - end; -//*/////////////////////////////////////////////////////// - {$IFDEF _D6orHigher} // - F.Designer.QueryInterface(IFormDesigner,D); // - {$ELSE} // -//*/////////////////////////////////////////////////////// - D := F.Designer; -//*/////////////////////////////////////////////////////// - {$ENDIF} // -//*/////////////////////////////////////////////////////// - if QueryFormDesigner( D, FD ) then - //if D.QueryInterface( IFormDesigner, FD ) = 0 then - begin - if not FD.MethodExists( Result ) then Result := ''; - end - else Result := ''; - end - else Result := ''; - - EXCEPT - on E: Exception do - begin - Rpt( 'Exception while retrieving property OnMenu of TKOLMenuItem', RED ); - ShowMessage( 'Could not retrieve TKOLMenuItem.OnMenu, exception: ' + E.Message ); - end; - END; end; procedure TKOLOnItemPropEditor.SetValue(const AValue: string); -var Comp: TPersistent; - I: Integer; +var + Comp: TPersistent; + I: Integer; begin asm jmp @@e_signature @@ -26503,22 +21491,21 @@ begin @@e_signature: end; inherited; - for I := 0 to PropCount - 1 do - begin - Comp := GetComponent( I ); + for I := 0 to PropCount - 1 do begin + Comp := GetComponent(I); if Comp <> nil then - if Comp is TKOLMenuItem then - begin - (Comp as TKOLMenuItem).FOnMenuMethodName := AValue; - (Comp as TKOLMenuItem).Change; - end; + if Comp is TKOLMenuItem then begin + (Comp as TKOLMenuItem).FOnMenuMethodName := AValue; + (Comp as TKOLMenuItem).Change; + end; end; end; { TKOLAccelerator } -function TKOLAccelerator.AsText: String; -var S: String; +function TKOLAccelerator.AsText: string; +var + s: string; begin asm jmp @@e_signature @@ -26526,7 +21513,7 @@ begin DB 'TKOLAccelerator.AsText', 0 @@e_signature: end; - Result:='';// {RA} + Result := ''; // {RA} if kapControl in Prefix then Result := 'Ctrl+'; if kapAlt in Prefix then @@ -26549,8 +21536,11 @@ begin S := CopyEnd( S, 4 ); end; end;} - S := VirtualKeyNames[Key]; // Maxim Pushkar - if S = '' then Result := '' else Result := Result + S; + s := VirtualKeyNames[Key]; // Maxim Pushkar + if s = '' then + Result := '' + else + Result := Result + s; end; procedure TKOLAccelerator.Change; @@ -26561,11 +21551,10 @@ begin DB 'TKOLAccelerator.Change', 0 @@e_signature: end; - if FOwner is TKOLMenuItem then - TKOLMenuItem(FOwner).Change - else - if FOwner is TKOLAction then - TKOLAction(FOwner).Change; + if fOwner is TKOLMenuItem then + TKOLMenuItem(fOwner).Change + else if fOwner is TKOLAction then + TKOLAction(fOwner).Change; end; procedure TKOLAccelerator.SetKey(const Value: TVirtualKey); @@ -26576,7 +21565,8 @@ begin DB 'TKOLAccelerator.SetKey', 0 @@e_signature: end; - if FKey = Value then Exit; + if FKey = Value then + Exit; FKey := Value; Change; end; @@ -26589,7 +21579,8 @@ begin DB 'TKOLAccelerator.SetPrefix', 0 @@e_signature: end; - if FPrefix = Value then Exit; + if FPrefix = Value then + Exit; FPrefix := Value; Change; end; @@ -26597,8 +21588,9 @@ end; { TKOLAccelearatorPropEditor } procedure TKOLAcceleratorPropEditor.Edit; -var CAE: TKOLAccEdit; - Comp: TPersistent; +var + CAE: TKOLAccEdit; + Comp: TPersistent; begin asm jmp @@e_signature @@ -26606,25 +21598,26 @@ begin DB 'TKOLAccelearatorPropEditor.Edit', 0 @@e_signature: end; - Comp := Getcomponent( 0 ); - if Comp = nil then Exit; - if not ( Comp is TKOLMenuItem ) and not ( Comp is TKOLAction ) then Exit; - CAE := TKOLAccEdit.Create( Application ); + Comp := GetComponent(0); + if Comp = nil then + Exit; + if not (Comp is TKOLMenuItem) and not (Comp is TKOLAction) then + Exit; + CAE := TKOLAccEdit.Create(Application); try if Comp is TKOLMenuItem then with TKOLMenuItem(Comp) do - CAE.Caption := CAE.Caption + MenuComponent.Name + '.' + Name - else - if Comp is TKOLAction then + CAE.Caption := CAE.Caption + MenuComponent.name + '.' + name + else if Comp is TKOLAction then with TKOLAction(Comp) do - CAE.Caption := CAE.Caption + ActionList.Name + '.' + Name; - + CAE.Caption := CAE.Caption + ActionList.name + '.' + name; + CAE.edAcc.Text := GetValue; CAE.ShowModal; if CAE.ModalResult = mrOK then - SetValue( CAE.edAcc.Text ); + SetValue(CAE.edAcc.Text); finally - CAE.Free; + CAE.free; end; end; @@ -26636,12 +21629,13 @@ begin DB 'TKOLAcceleratorPropEditor.GetAttributes', 0 @@e_signature: end; - Result := [ paDialog {, pasubProperties} ]; + Result := [paDialog {, pasubProperties}]; end; function TKOLAcceleratorPropEditor.GetValue: string; -var Comp: TPersistent; - MA: TKOLAccelerator; +var + Comp: TPersistent; + MA: TKOLAccelerator; begin asm jmp @@e_signature @@ -26649,12 +21643,11 @@ begin DB 'TKOLAcceleratorPropEditor.GetValue', 0 @@e_signature: end; - Comp := GetComponent( 0 ); + Comp := GetComponent(0); if Comp is TKOLMenuItem then - MA := (Comp as TKOLMenuItem).Accelerator - else - if Comp is TKOLAction then - MA := (Comp as TKOLAction).Accelerator + MA := (Comp as TKOLMenuItem).accelerator + else if Comp is TKOLAction then + MA := (Comp as TKOLAction).accelerator else MA := nil; if MA <> nil then @@ -26664,12 +21657,13 @@ begin end; procedure TKOLAcceleratorPropEditor.SetValue(const Value: string); -var Comp: TPersistent; - MA: TKOLAccelerator; - _Prefix: TKOLAccPrefix; - _Key, K: TVirtualKey; - S: String; - I: Integer; +var + Comp: TPersistent; + MA: TKOLAccelerator; + _Prefix: TKOLAccPrefix; + _Key, k: TVirtualKey; + s: string; + I: Integer; begin asm jmp @@e_signature @@ -26677,41 +21671,35 @@ begin DB 'TKOLAcceleratorPropEditor.SetValue', 0 @@e_signature: end; - Comp := GetComponent( 0 ); + Comp := GetComponent(0); if Comp is TKOLMenuItem then - MA := (Comp as TKOLMenuItem).Accelerator - else - if Comp is TKOLAction then - MA := (Comp as TKOLAction).Accelerator + MA := (Comp as TKOLMenuItem).accelerator + else if Comp is TKOLAction then + MA := (Comp as TKOLAction).accelerator else MA := nil; - if MA <> nil then - begin - _Prefix := [ ]; + if MA <> nil then begin + _Prefix := []; _Key := vkNotPresent; - S := Value; - for I := Length( S ) downto 1 do - if S[ I ] <= ' ' then - S := Copy( S, 1, I - 1 ) + Copy( S, I + 1, Length( S ) - I ); - while S <> '' do - begin - if UPPERCASE(Copy( S, 1, 6 )) = 'SHIFT+' then - begin - S := Copy( S, 7, Length(S)-6 ); - _Prefix := _Prefix + [ kapShift ]; - continue; + s := Value; + for I := Length(s) downto 1 do + if s[I] <= ' ' then + s := Copy(s, 1, I - 1) + Copy(s, I + 1, Length(s) - I); + while s <> '' do begin + if UpperCase(Copy(s, 1, 6)) = 'SHIFT+' then begin + s := Copy(s, 7, Length(s) - 6); + _Prefix := _Prefix + [kapShift]; + Continue; end; - if UPPERCASE(Copy( S, 1, 5 )) = 'CTRL+' then - begin - S := Copy( S, 6, Length(S)-5 ); - _Prefix := _Prefix + [ kapControl ]; - continue; + if UpperCase(Copy(s, 1, 5)) = 'CTRL+' then begin + s := Copy(s, 6, Length(s) - 5); + _Prefix := _Prefix + [kapControl]; + Continue; end; - if UPPERCASE(Copy( S, 1, 4 )) = 'ALT+' then - begin - S := Copy( S, 5, Length(S)-4 ); - _Prefix := _Prefix + [ kapAlt ]; - continue; + if UpperCase(Copy(s, 1, 4)) = 'ALT+' then begin + s := Copy(s, 5, Length(s) - 4); + _Prefix := _Prefix + [kapAlt]; + Continue; end; _Key := vkNotPresent; //---------------------- { Maxim Pushkar } ----------------------\ @@ -26740,33 +21728,32 @@ begin break; /| end; // end; // - end;} // + end;}// //++++++++++++++++++++++ Maxim Pushkar ++++++++++++++++++++++// - for K := Low(TVirtualKey) to High(TVirtualKey) do // - if UpperCase(S) = UpperCase(VirtualKeyNames[K]) then // - _Key := K; // + for k := Low(TVirtualKey) to High(TVirtualKey) do // + if UpperCase(s) = UpperCase(VirtualKeyNames[k]) then // + _Key := k; // //-------------------------------------------------------// - break; + Break; end; - if _Key = vkNotPresent then - begin + if _Key = vkNotPresent then begin MA.Key := _Key; - MA.Prefix := [ ]; + MA.Prefix := []; end - else - begin + else begin MA.Key := _Key; MA.Prefix := _Prefix; end; end - else + else Beep; end; { TKOLBrush } procedure TKOLBrush.Assign(Value: TPersistent); -var B: TKOLBrush; +var + B: TKOLBrush; begin asm jmp @@e_signature @@ -26775,27 +21762,26 @@ begin @@e_signature: end; //inherited; - if Value is TKOLBrush then - begin + if Value is TKOLBrush then begin B := Value as TKOLBrush; FColor := B.Color; FBrushStyle := B.BrushStyle; - if B.FBitmap <> nil then - begin + if B.FBitmap <> nil then begin if FBitmap = nil then FBitmap := TBitmap.Create; - FBitmap.Assign( B.FBitmap ) + FBitmap.Assign(B.FBitmap) end - else - begin - FBitmap.Free; FBitmap := nil; + else begin + FBitmap.free; + FBitmap := nil; end; Change; end; end; procedure TKOLBrush.Change; -var Form: TCustomForm; +var + Form: TCustomForm; begin asm jmp @@e_signature @@ -26803,279 +21789,115 @@ begin DB 'TKOLBrush.Change', 0 @@e_signature: end; - if fOwner = nil then Exit; - if fChangingNow then Exit; + if fOwner = nil then + Exit; + if fChangingNow then + Exit; try - if fOwner is TKOLForm then - begin - (fOwner as TKOLForm).Change( fOwner ); - if (fOwner as TKOLForm).Owner <> nil then - begin + if fOwner is TKOLForm then begin + (fOwner as TKOLForm).Change(fOwner); + if (fOwner as TKOLForm).Owner <> nil then begin Form := (fOwner as TKOLForm).Owner as TCustomForm; Form.Invalidate; end; end - else - if (fOwner is TKOLCustomControl) then - begin -{YS} - {$IFDEF _KOLCtrlWrapper_} + else if (fOwner is TKOLCustomControl) then begin + {YS} +{$IFDEF _KOLCtrlWrapper_} with (fOwner as TKOLCustomControl) do if Assigned(FKOLCtrl) then with FKOLCtrl^ do begin - Brush.Color:=Self.Color; - Brush.BrushStyle:=kol.TBrushStyle(BrushStyle); -// Brush.BrushBitmap:=Bitmap.Handle; + Brush.Color := Self.Color; + Brush.BrushStyle := KOL.TBrushStyle(BrushStyle); + // Brush.BrushBitmap:=Bitmap.Handle; end; - {$ENDIF} -{YS} +{$ENDIF} + {YS} (fOwner as TKOLCustomControl).Change; (fOwner as TKOLCustomControl).Invalidate; - end - else - if (fOwner is TKOLObj) then - (fOwner as TKOLObj).Change; + end + else if (fOwner is TKOLObj) then + (fOwner as TKOLObj).Change; finally - fChangingNow := FALSE; + fChangingNow := False; end; end; constructor TKOLBrush.Create(AOwner: TComponent); begin inherited Create; - FOwner := AOwner; + fOwner := AOwner; FBitmap := TBitmap.Create; FColor := clBtnFace; - FAllowBitmapCompression := TRUE; + FAllowBitmapCompression := True; end; destructor TKOLBrush.Destroy; begin - FBitmap.Free; + FBitmap.free; inherited; end; -procedure TKOLBrush.GenerateCode(SL: TStrings; const AName: String); +procedure TKOLBrush.GenerateCode(SL: TStrings; const AName: string); const - BrushStyles: array[ TBrushStyle ] of String = ( 'bsSolid', 'bsClear', 'bsHorizontal', 'bsVertical', - 'bsFDiagonal', 'bsBDiagonal', 'bsCross', 'bsDiagCross' ); -var RsrcName: String; - Updated: Boolean; - KF: TKOLForm; - i: Integer; - C: DWORD; + BrushStyles: array[TBrushStyle] of string = ('bsSolid', 'bsClear', 'bsHorizontal', 'bsVertical', + 'bsFDiagonal', 'bsBDiagonal', 'bsCross', 'bsDiagCross'); +var + RsrcName: string; + Updated: Boolean; + KF: TKOLForm; begin - if FOwner = nil then Exit; - if FOwner is TKOLForm then - begin - KF := FOwner as TKOLForm; - if Bitmap.Empty then - begin - case BrushStyle of - bsSolid: if KF.Color <> clBtnFace then - if KF.FormCompact then - begin - KF.FormAddCtlCommand( 'Form', 'FormSetColor', '' ); - C := KF.Color; - if C and $FF000000 = $FF000000 then - C := C and $FFFFFF or $80000000; - C := (C shl 1) or (C shr 31); - RptDetailed( 'Prepare FormSetColor parameter, src color =$' + - Int2Hex( KF.Color, 2 ) + ', coded color =$' + - Int2Hex( C, 2 ), CYAN ); - KF.FormAddNumParameter( C ); - end - else - SL.Add( ' ' + AName + '.Color := TColor(' + Color2Str( KF.Color ) + ');' ); - else if KF.FormCompact then - begin - KF.FormAddCtlCommand( 'Form', 'FormSetBrushStyle', '' ); - KF.FormAddNumParameter( Integer( BrushStyle ) ); - end - else - SL.Add( ' ' + AName + '.Brush.BrushStyle := ' + BrushStyles[ BrushStyle ] + ';' ); - end; - end - else - begin - RsrcName := (FOwner as TKOLForm).Owner.Name + '_' + - (FOwner as TKOLForm).Name + '_BRUSH_BMP'; - GenerateBitmapResource( Bitmap, UPPERCASE( RsrcName ), RsrcName, Updated, - AllowBitmapCompression ); - if KF.FormCompact then - begin - (SL as TFormStringList).OnAdd := nil; - SL.Add( ' {$R ' + RsrcName + '.res}' ); - (SL as TFormStringList).OnAdd := KF.DoFlushFormCompact; - KF.FormAddCtlCommand( 'Form', 'FormSetBrushBitmap', '' ); - KF.FormAddStrParameter( UpperCase( RsrcName ) ); - end - else - begin - SL.Add( ' {$R ' + RsrcName + '.res}' ); - SL.Add( ' ' + AName + '.Brush.BrushBitmap := ' + - 'LoadBmp( hInstance, ''' + UpperCase( RsrcName ) - + ''', Result );' ); - end; - end; - end - else - if FOwner is TKOLCustomControl then - begin - KF := (FOwner as TKOLCustomControl).ParentKOLForm; - if Bitmap.Empty then - begin + if fOwner = nil then + Exit; + if fOwner is TKOLForm then begin + KF := fOwner as TKOLForm; + if Bitmap.Empty then begin case BrushStyle of - bsSolid: if not (FOwner as TKOLCustomControl).ParentColor then - if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( (FOwner as TKOLCustomControl).Name, 'FormSetColor', '' ); - i := (FOwner as TKOLCustomControl).Color; - C := i; - if C and $FF000000 = $FF000000 then - C := C and $FFFFFF or $80000000; - C := (C shl 1) or (C shr 31); - RptDetailed( 'Prepare FormSetColor parameter, src color =$' + - Int2Hex( i, 2 ) + ', coded color =$' + - Int2Hex( C, 2 ), CYAN ); - KF.FormAddNumParameter( C ); - end - else - SL.Add( ' ' + AName + '.Color := TColor(' + Color2Str( (FOwner as TKOLCustomControl).Color ) + ');' ); - else if (KF <> nil) and KF.FormCompact then - begin - KF.FormAddCtlCommand( (FOwner as TKOLCustomControl).Name, 'FormSetBrushStyle', '' ); - KF.FormAddNumParameter( Integer( BrushStyle ) ); - end - else - SL.Add( ' ' + AName + '.Brush.BrushStyle := ' + BrushStyles[ BrushStyle ] + ';' ); + bsSolid: + if KF.Color <> clBtnFace then + SL.Add(' ' + AName + '.Color := TColor(' + Color2Str(KF.Color) + ');'); + else + SL.Add(' ' + AName + '.Brush.BrushStyle := ' + BrushStyles[BrushStyle] + ';'); end; end - else - begin - RsrcName := (FOwner as TKOLCustomControl).ParentForm.Name + '_' + - (FOwner as TKOLCustomControl).Name + '_BRUSH_BMP'; - GenerateBitmapResource( Bitmap, UPPERCASE( RsrcName ), RsrcName, Updated, - AllowBitmapCompression ); - if (KF <> nil) and KF.FormCompact then - begin - (SL as TFormStringList).OnAdd := nil; - SL.Add( ' {$R ' + RsrcName + '.res}' ); - (SL as TFormStringList).OnAdd := KF.DoFlushFormCompact; - KF.FormAddCtlCommand( (FOwner as TKOLCustomControl).Name, 'FormSetBrushBitmap', '' ); - KF.FormAddStrParameter( UpperCase( RsrcName ) ); - end - else - begin - SL.Add( ' {$R ' + RsrcName + '.res}' ); - SL.Add( ' ' + AName + '.Brush.BrushBitmap := LoadBmp( hInstance, ''' + - UpperCase( RsrcName ) + ''', Result );' ); - end; - end; - end; -end; - -procedure TKOLBrush.P_GenerateCode(SL: TStrings; const AName: String); -const - BrushStyles: array[ TBrushStyle ] of String = ( 'bsSolid', 'bsClear', 'bsHorizontal', 'bsVertical', - 'bsFDiagonal', 'bsBDiagonal', 'bsCross', 'bsDiagCross' ); -var RsrcName: String; - Updated: Boolean; - BrushInStack: Boolean; - procedure ProvideBrushInStack; - begin - if not BrushInStack then - begin - {P}SL.Add( ' DUP TControl.GetBrush<1> RESULT' ); - BrushInStack := TRUE; - end; - end; -begin - if FOwner = nil then Exit; - BrushInStack := FALSE; - if FOwner is TKOLForm then - begin - if Bitmap.Empty then - begin - case BrushStyle of - bsSolid: if (FOwner as TKOLForm).Color <> clBtnFace then - //SL.Add( ' ' + AName + '.Color := ' + Color2Str( (FOwner as TKOLForm).Color ) + ';' ); - begin - {P}SL.Add( ' L($' + - Int2Hex( (FOwner as TKOLForm).Color, 6 ) + ')' ); - {P}SL.Add( ' C1 TControl_.SetCtlColor<2>' ); - end; - else //SL.Add( ' ' + AName + '.Brush.BrushStyle := ' + BrushStyles[ BrushStyle ] + ';' ); - begin - ProvideBrushInStack; - {P}SL.Add( ' L(' + IntToStr( Integer( BrushStyle ) ) + ')' ); - {P}SL.Add( ' C1 TGraphTool_.SetBrushStyle<2>' ); - end; - end; - end - else - begin - RsrcName := (FOwner as TKOLForm).Owner.Name + '_' + - (FOwner as TKOLForm).Name + '_BRUSH_BMP'; - SL.Add( ' {$R ' + RsrcName + '.res}' ); - //todo: (PCompiler) copy {$R ...} from Pcode to asm as is! - GenerateBitmapResource( Bitmap, UPPERCASE( RsrcName ), RsrcName, Updated, - AllowBitmapCompression ); - //SL.Add( ' ' + AName + '.Brush.BrushBitmap := LoadBmp( hInstance, ''' + UpperCase( RsrcName ) - // + ''', Result );' ); - ProvideBrushInStack; - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( UpperCase( RsrcName ) ) ); - {P}SL.Add( ' C3 SWAP' ); - {P}SL.Add( ' Load_hInstance LoadBmp<3> RESULT' ); - {P}SL.Add( ' C2 TGraphTool.SetBrushBitmap<2>' ); - {P}SL.Add( ' DelAnsiStr' ); + else begin + RsrcName := (fOwner as TKOLForm).Owner.name + '_' + + (fOwner as TKOLForm).name + '_BRUSH_BMP'; + GenerateBitmapResource(Bitmap, UpperCase(RsrcName), RsrcName, Updated, + AllowBitmapCompression); + SL.Add(' {$R ' + RsrcName + '.res}'); + SL.Add(' ' + AName + '.Brush.BrushBitmap := ' + + 'LoadBmp( hInstance, ''' + UpperCase(RsrcName) + + ''', Result );'); end; end - else - if FOwner is TKOLCustomControl then - begin - if Bitmap.Empty then - begin + else if fOwner is TKOLCustomControl then begin + if Bitmap.Empty then begin case BrushStyle of - bsSolid: if not (FOwner as TKOLCustomControl).ParentColor then - //SL.Add( ' ' + AName + '.Color := ' + Color2Str( (FOwner as TKOLForm).Color ) + ';' ); - begin - {P}SL.Add( ' L($' + Int2Hex( (FOwner as TKOLCustomControl).Color, 6 ) + ')' ); - {P}SL.Add( ' C1 TControl_.SetCtlColor<2>' ); - end - else //SL.Add( ' ' + AName + '.Brush.BrushStyle := ' + BrushStyles[ BrushStyle ] + ';' ); - begin - ProvideBrushInStack; - {P}SL.Add( ' L(' + IntToStr( Integer( BrushStyle ) ) + ')' ); - {P}SL.Add( ' C1 TGraphTool_.SetBrushStyle<2>' ); - end; + bsSolid: if not (fOwner as TKOLCustomControl).parentColor then + SL.Add(' ' + AName + '.Color := TColor(' + Color2Str((fOwner as TKOLCustomControl).Color) + ');'); + else + SL.Add(' ' + AName + '.Brush.BrushStyle := ' + BrushStyles[BrushStyle] + ';'); end; end - else - begin - RsrcName := (FOwner as TKOLCustomControl).ParentForm.Name + '_' + - (FOwner as TKOLCustomControl).Name + '_BRUSH_BMP'; - SL.Add( ' {$R ' + RsrcName + '.res}' ); - GenerateBitmapResource( Bitmap, UPPERCASE( RsrcName ), RsrcName, Updated, - AllowBitmapCompression ); - //SL.Add( ' ' + AName + '.Brush.BrushBitmap := LoadBmp( hInstance, ''' + UpperCase( RsrcName ) - // + ''', Result );' ); - {P}SL.Add( ' LoadAnsiStr ' + P_String2Pascal( UpperCase( RsrcName ) ) ); - {P}SL.Add( ' C3 SWAP' ); - {P}SL.Add( ' Load_hInstance LoadBmp<3> RESULT' ); - {P}SL.Add( ' C1 TGraphTool.SetBrushBitmap<2>' ); - {P}SL.Add( ' DelAnsiStr' ); + else begin + RsrcName := (fOwner as TKOLCustomControl).ParentForm.name + '_' + + (fOwner as TKOLCustomControl).name + '_BRUSH_BMP'; + GenerateBitmapResource(Bitmap, UpperCase(RsrcName), RsrcName, Updated, + AllowBitmapCompression); + SL.Add(' {$R ' + RsrcName + '.res}'); + SL.Add(' ' + AName + '.Brush.BrushBitmap := LoadBmp( hInstance, ''' + + UpperCase(RsrcName) + ''', Result );'); end; end; - if BrushInStack then - {P}SL.Add( ' DEL // Brush ' ); end; procedure TKOLBrush.SetAllowBitmapCompression(const Value: Boolean); begin - if FAllowBitmapCompression = Value then Exit; + if FAllowBitmapCompression = Value then + Exit; FAllowBitmapCompression := Value; Change; end; @@ -27083,9 +21905,8 @@ end; procedure TKOLBrush.SetBitmap(const Value: TBitmap); begin FBitmap.Assign(Value); - if FOwner <> nil then - if FOwner is TKOLForm then - begin + if fOwner <> nil then + if fOwner is TKOLForm then begin {if (FOwner as TKOLForm).Owner <> nil then ((FOwner as TKOLForm).Owner as TCustomForm).Brush.Bitmap.Assign( Value );} end; @@ -27094,28 +21915,28 @@ end; procedure TKOLBrush.SetBrushStyle(const Value: TBrushStyle); begin - if FBrushStyle = Value then Exit; + if FBrushStyle = Value then + Exit; FBrushStyle := Value; - if FOwner <> nil then - if FOwner is TKOLForm then - begin - if (FOwner as TKOLForm).Owner <> nil then - ((Fowner as TKOLForm).Owner as TCustomForm).Brush.Style := - Graphics.TBrushStyle( Value ); + if fOwner <> nil then + if fOwner is TKOLForm then begin + if (fOwner as TKOLForm).Owner <> nil then + ((fOwner as TKOLForm).Owner as TCustomForm).Brush.Style := + Graphics.TBrushStyle(Value); end; Change; end; procedure TKOLBrush.SetColor(const Value: TColor); begin - if FColor = Value then Exit; + if FColor = Value then + Exit; FColor := Value; - if FOwner <> nil then - if FOwner is TKOLForm then - (FOwner as TKOLForm).Color := Value - else - if FOwner is TKOLCustomControl then - (FOwner as TKOLCustomControl).Color := Value; + if fOwner <> nil then + if fOwner is TKOLForm then + (fOwner as TKOLForm).Color := Value + else if fOwner is TKOLCustomControl then + (fOwner as TKOLCustomControl).Color := Value; Change; end; @@ -27123,13 +21944,12 @@ end; procedure TKOLAction.Assign(Source: TPersistent); begin - if Source is TKOLAction then - begin - FCaption := TKOLAction(Source).FCaption; + if Source is TKOLAction then begin + fCaption := TKOLAction(Source).fCaption; FHint := TKOLAction(Source).FHint; FChecked := TKOLAction(Source).FChecked; - FEnabled := TKOLAction(Source).FEnabled; - FVisible := TKOLAction(Source).FVisible; + fEnabled := TKOLAction(Source).fEnabled; + fVisible := TKOLAction(Source).fVisible; FHelpContext := TKOLAction(Source).FHelpContext; FOnExecute := TKOLAction(Source).FOnExecute; @@ -27141,12 +21961,12 @@ end; constructor TKOLAction.Create(AOwner: TComponent); begin inherited Create(AOwner); - FLinked:=TStringList.Create; - FAccelerator:=TKOLAccelerator.Create; - FAccelerator.FOwner:=Self; - FVisible:=True; - FEnabled:=True; - NeedFree:=False; + FLinked := TStringList.Create; + FAccelerator := TKOLAccelerator.Create; + FAccelerator.fOwner := Self; + fVisible := True; + fEnabled := True; + NeedFree := False; end; procedure TKOLAction.DefineProperties(Filer: TFiler); @@ -27160,8 +21980,8 @@ begin inherited; if FActionList <> nil then FActionList.List.Remove(Self); - FLinked.Free; - FAccelerator.Free; + FLinked.free; + FAccelerator.free; end; function TKOLAction.GetIndex: Integer; @@ -27192,8 +22012,7 @@ procedure TKOLAction.LinkComponent(const AComponent: TComponent); begin ResolveLinks; if (FLinked.IndexOfObject(AComponent) = -1) and - (FLinked.IndexOf(GetComponentFullPath(AComponent)) = -1) then - begin + (FLinked.IndexOf(GetComponentFullPath(AComponent)) = -1) then begin FLinked.AddObject('', AComponent); AComponent.FreeNotification(Self); // 1.87 +YS UpdateLinkedComponent(AComponent); @@ -27224,25 +22043,23 @@ end; procedure TKOLAction.ResolveLinks; var - i: integer; + I: Integer; s: string; c: TComponent; begin - for i:=0 to FLinked.Count - 1 do begin - s:=FLinked[i]; + for I := 0 to FLinked.Count - 1 do begin + s := FLinked[I]; if s <> '' then begin - c:=FindComponentByPath(s); + c := FindComponentByPath(s); if c <> nil then begin - FLinked[i]:=''; - FLinked.Objects[i]:=c; + FLinked[I] := ''; + FLinked.Objects[I] := c; if c is TKOLMenuItem then - TKOLMenuItem(c).action:=Self - else - if c is TKOLCustomControl then - TKOLCustomControl(c).action:=Self - else - if c is TKOLToolbarButton then - TKOLToolbarButton(c).action:=Self; + TKOLMenuItem(c).action := Self + else if c is TKOLCustomControl then + TKOLCustomControl(c).action := Self + else if c is TKOLToolbarButton then + TKOLToolbarButton(c).action := Self; c.FreeNotification(Self); // v1.87 YS UpdateLinkedComponent(c); end; @@ -27252,14 +22069,14 @@ end; procedure TKOLAction.SaveLinks(W: TWriter); var - i: integer; + I: Integer; s: string; begin W.WriteListBegin; - for i:=0 to FLinked.Count - 1 do begin - s:=FLinked[i]; - if (s = '') and (FLinked.Objects[i] <> nil) then - s:=GetComponentFullPath(TComponent(FLinked.Objects[i])); + for I := 0 to FLinked.Count - 1 do begin + s := FLinked[I]; + if (s = '') and (FLinked.Objects[I] <> nil) then + s := GetComponentFullPath(TComponent(FLinked.Objects[I])); if s <> '' then W.WriteString(s); end; @@ -27268,7 +22085,8 @@ end; procedure TKOLAction.SetActionList(const Value: TKOLActionList); begin - if FActionList = Value then exit; + if FActionList = Value then + Exit; FActionList := Value; if FActionList <> nil then FActionList.List.Add(Self); @@ -27276,31 +22094,35 @@ end; procedure TKOLAction.SetCaption(const Value: string); begin - if FCaption = Value then exit; - FCaption := Value; + if fCaption = Value then + Exit; + fCaption := Value; UpdateLinkedComponents; Change; end; -procedure TKOLAction.SetChecked(const Value: boolean); +procedure TKOLAction.SetChecked(const Value: Boolean); begin - if FChecked = Value then exit; + if FChecked = Value then + Exit; FChecked := Value; UpdateLinkedComponents; Change; end; -procedure TKOLAction.SetEnabled(const Value: boolean); +procedure TKOLAction.SetEnabled(const Value: Boolean); begin - if Enabled = Value then exit; - FEnabled := Value; + if Enabled = Value then + Exit; + fEnabled := Value; UpdateLinkedComponents; Change; end; -procedure TKOLAction.SetHelpContext(const Value: integer); +procedure TKOLAction.SetHelpContext(const Value: Integer); begin - if FHelpContext = Value then exit; + if FHelpContext = Value then + Exit; FHelpContext := Value; UpdateLinkedComponents; Change; @@ -27308,7 +22130,8 @@ end; procedure TKOLAction.SetHint(const Value: string); begin - if FHint = Value then exit; + if FHint = Value then + Exit; FHint := Value; UpdateLinkedComponents; Change; @@ -27319,13 +22142,13 @@ var CurIndex, Count: Integer; begin CurIndex := GetIndex; - if CurIndex >= 0 then - begin + if CurIndex >= 0 then begin Count := ActionList.FActions.Count; - if Value < 0 then Value := 0; - if Value >= Count then Value := Count - 1; - if Value <> CurIndex then - begin + if Value < 0 then + Value := 0; + if Value >= Count then + Value := Count - 1; + if Value <> CurIndex then begin ActionList.FActions.Delete(CurIndex); ActionList.FActions.Insert(Value, Self); end; @@ -27341,7 +22164,8 @@ end; procedure TKOLAction.SetOnExecute(const Value: TOnEvent); begin - if @FOnExecute = @Value then exit; + if @FOnExecute = @Value then + Exit; FOnExecute := Value; Change; end; @@ -27352,7 +22176,7 @@ begin ActionList := TKOLActionList(AParent); end; -procedure TKOLAction.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +procedure TKOLAction.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin (*if Name <> '' then begin @@ -27362,73 +22186,74 @@ begin end;*) end; -procedure TKOLAction.SetVisible(const Value: boolean); +procedure TKOLAction.SetVisible(const Value: Boolean); begin - if FVisible = Value then exit; - FVisible := Value; + if fVisible = Value then + Exit; + fVisible := Value; UpdateLinkedComponents; Change; end; procedure TKOLAction.UnLinkComponent(const AComponent: TComponent); var - i: integer; + I: Integer; begin ResolveLinks; while True do begin - i:=FLinked.IndexOfObject(AComponent); - if i <> -1 then - FLinked.Delete(i) + I := FLinked.IndexOfObject(AComponent); + if I <> -1 then + FLinked.Delete(I) else - break; + Break; end; end; function TKOLAction.FindComponentByPath(const Path: string): TComponent; var - i, j: integer; - p, n: string; + I, j: Integer; + P, N: string; begin - p:=Path; - Result:=nil; + P := Path; + Result := nil; repeat - i:=Pos('.', p); - if i = 0 then - i:=Length(p) + 1; - n:=Copy(p, 1, i - 1); - p:=Copy(p, i + 1, MaxInt); + I := Pos('.', P); + if I = 0 then + I := Length(P) + 1; + N := Copy(P, 1, I - 1); + P := Copy(P, I + 1, MaxInt); if Result = nil then begin - for j:=0 to Screen.FormCount - 1 do - if AnsiCompareText(Screen.Forms[j].Name, n) = 0 then begin - Result:=Screen.Forms[j]; - break; + for j := 0 to Screen.FormCount - 1 do + if AnsiCompareText(Screen.Forms[j].name, N) = 0 then begin + Result := Screen.Forms[j]; + Break; end; end else - Result:=Result.FindComponent(n); + Result := Result.FindComponent(N); -// if Result <> nil then -// Rpt('Found: ' + Result.Name); - until (p = '') or (Result = nil); + // if Result <> nil then + // Rpt('Found: ' + Result.Name); + until (P = '') or (Result = nil); end; function TKOLAction.GetComponentFullPath(AComponent: TComponent): string; begin - Result:=''; + Result := ''; while AComponent <> nil do begin if Result <> '' then - Result:='.' + Result; - Result:=AComponent.Name + Result; - AComponent:=AComponent.Owner; + Result := '.' + Result; + Result := AComponent.name + Result; + AComponent := AComponent.Owner; end; end; procedure TKOLAction.UpdateLinkedComponents; var - i: integer; + I: Integer; begin - for i:=0 to FLinked.Count - 1 do - UpdateLinkedComponent(TComponent(FLinked.Objects[i])); + for I := 0 to FLinked.Count - 1 do + UpdateLinkedComponent(TComponent(FLinked.Objects[I])); end; procedure TKOLAction.UpdateLinkedComponent(AComponent: TComponent); @@ -27436,43 +22261,40 @@ begin if AComponent is TKOLMenuItem then with TKOLMenuItem(AComponent) do begin if Self.FAccelerator.Key <> vkNotPresent then - FCaption:=Self.FCaption + #9 + Self.FAccelerator.AsText + fCaption := Self.fCaption + #9 + Self.FAccelerator.AsText else - FCaption:=Self.FCaption; - FVisible:=Self.FVisible; - FEnabled:=Self.FEnabled; - FChecked:=Self.FChecked; - FHelpContext:=Self.FHelpContext; + fCaption := Self.fCaption; + fVisible := Self.fVisible; + fEnabled := Self.fEnabled; + FChecked := Self.FChecked; + FHelpContext := Self.FHelpContext; Change; end - else - if AComponent is TKOLCustomControl then begin + else if AComponent is TKOLCustomControl then begin with TKOLCustomControl(AComponent) do begin - Caption:=Self.FCaption; - Visible:=Self.FVisible; - Enabled:=Self.FEnabled; - HelpContext:=Self.FHelpContext; + Caption := Self.fCaption; + Visible := Self.fVisible; + Enabled := Self.fEnabled; + HelpContext := Self.FHelpContext; Change; end; if AComponent is TKOLCheckBox then with TKOLCheckBox(AComponent) do begin - Checked:=Self.FChecked; + checked := Self.FChecked; end - else - if AComponent is TKOLRadioBox then + else if AComponent is TKOLRadioBox then with TKOLRadioBox(AComponent) do begin - Checked:=Self.FChecked; + checked := Self.FChecked; end; end - else - if AComponent is TKOLToolbarButton then + else if AComponent is TKOLToolbarButton then with TKOLToolbarButton(AComponent) do begin - Caption:=Self.FCaption; - Visible:=Self.FVisible; - Enabled:=Self.FEnabled; - Checked:=Self.FChecked; - HelpContext:=Self.FHelpContext; - tooltip:=Self.FHint; + Caption := Self.fCaption; + Visible := Self.fVisible; + Enabled := Self.fEnabled; + checked := Self.FChecked; + HelpContext := Self.FHelpContext; + tooltip := Self.FHint; Change; end else @@ -27487,42 +22309,36 @@ end; procedure TKOLAction.SetAccelerator(const Value: TKOLAccelerator); begin - if (FAccelerator.Prefix = Value.Prefix) and (FAccelerator.Key = Value.Key) then exit; + if (FAccelerator.Prefix = Value.Prefix) and (FAccelerator.Key = Value.Key) then + Exit; FAccelerator := Value; UpdateLinkedComponents; Change; end; -function TKOLAction.AdditionalUnits: String; +function TKOLAction.AdditionalUnits: string; begin Result := ', KOLadd'; end; -procedure TKOLAction.P_SetupName(SL: TStringList); -begin - if ActionList.FP_NameSetuped then - inherited; -end; - procedure TKOLAction.SetupName(SL: TStringList; const AName, AParent, - Prefix: String); + Prefix: string); begin - RptDetailed( 'SetupName for ' + AName, YELLOW ); - if FNameSetuppingInParent then - begin - RptDetailed( 'SetupName for ' + AName + ': call inherited', YELLOW ); + RptDetailed('SetupName for ' + AName, YELLOW); + if FNameSetuppingInParent then begin + RptDetailed('SetupName for ' + AName + ': call inherited', YELLOW); inherited; end; end; { TKOLActionList } -function TKOLActionList.AdditionalUnits: String; +function TKOLActionList.AdditionalUnits: string; begin Result := ', KOLadd'; end; -procedure TKOLActionList.AssignEvents(SL: TStringList; const AName: String); +procedure TKOLActionList.AssignEvents(SL: TStringList; const AName: string); begin inherited; DoAssignEvents(SL, AName, ['OnUpdateActions'], [@OnUpdateActions]); @@ -27531,36 +22347,35 @@ end; constructor TKOLActionList.Create(AOwner: TComponent); begin inherited; - FActions:=TList.Create; + FActions := TList.Create; end; destructor TKOLActionList.Destroy; begin - ActiveDesign.Free; - FActions.Free; + ActiveDesign.free; + FActions.free; inherited; end; procedure TKOLActionList.GetChildren(Proc: TGetChildProc; Root: TComponent); var I: Integer; - Action: TKOLAction; + action: TKOLAction; begin - for I := 0 to FActions.Count - 1 do - begin - Action := FActions[I]; - {if Action.Owner = Root then }Proc(Action); + for I := 0 to FActions.Count - 1 do begin + action := FActions[I]; + {if Action.Owner = Root then }Proc(action); end; end; -function TKOLActionList.GetCount: integer; +function TKOLActionList.GetCount: Integer; begin - Result:=FActions.Count; + Result := FActions.Count; end; function TKOLActionList.GetKOLAction(Index: Integer): TKOLAction; begin - Result:=FActions[Index]; + Result := FActions[Index]; end; procedure TKOLActionList.SetChildOrder(Component: TComponent; @@ -27577,136 +22392,134 @@ end; procedure TKOLActionList.SetOnUpdateActions(const Value: TOnEvent); begin - if @FOnUpdateActions = @Value then exit; - FOnUpdateActions:=Value; + if @FOnUpdateActions = @Value then + Exit; + FOnUpdateActions := Value; Change; end; -procedure TKOLActionList.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); +procedure TKOLActionList.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); begin - SL.Add( Prefix + AName + ' := NewActionList( ' + AParent + ' );' ); - SetupName( SL, AName, AParent, Prefix ); - GenerateTag( SL, AName, Prefix ); + SL.Add(Prefix + AName + ' := NewActionList( ' + AParent + ' );'); + SetupName(SL, AName, AParent, Prefix); + GenerateTag(SL, AName, Prefix); end; -procedure TKOLActionList.SetupLast(SL: TStringList; const AName, AParent, Prefix: String); +procedure TKOLActionList.SetupLast(SL: TStringList; const AName, AParent, Prefix: string); var - i, j: integer; - s, ss, n, p, pf: string; + I, j: Integer; + s, ss, N, P, PF: string; c: TComponent; begin SL.Add(''); - n:=Prefix + AName; - p:=AName; - i:=Pos('.', AName); - if i <> 0 then - pf:=Copy(AName, 1, i - 1) + N := Prefix + AName; + P := AName; + I := Pos('.', AName); + if I <> 0 then + PF := Copy(AName, 1, I - 1) else - pf:=AName; - p:=Prefix + pf; + PF := AName; + P := Prefix + PF; - for i:=0 to FActions.Count - 1 do - //with Actions[i] do - begin - Actions[i].ResolveLinks; - if @Actions[i].FOnExecute <> nil then - s:=pf + '.' + ParentForm.MethodName(@Actions[i].FOnExecute) - else - s:='nil'; + for I := 0 to FActions.Count - 1 do + {//with Actions[i] do} begin + Actions[I].ResolveLinks; + if @Actions[I].FOnExecute <> nil then + s := PF + '.' + ParentForm.MethodName(@Actions[I].FOnExecute) + else + s := 'nil'; - ss:=Actions[i].Caption; - //---------------------------------------- remove by YS 7 Aug 2004 -| - //if Accelerator.Key <> vkNotPresent then | - // ss:=ss + #9 + Accelerator.AsText; | - //------------------------------------------------------------------| - SL.Add(Format('%s.%s := %s.Add( %s, %s, %s );', - [p, Actions[i].Name, AName, Actions[i].StringConstant('Caption', ss), - Actions[i].StringConstant('Hint', Actions[i].Hint), s])); - SL.Add( '//---->' ); - Actions[i].FNameSetuppingInParent := TRUE; - RptDetailed( 'Before calling SetupName for ' + Actions[i].Name, YELLOW ); - Actions[i].SetupName( SL, AName, AParent, Prefix ); - Actions[i].FNameSetuppingInParent := FALSE; - SL.Add( '//<----' ); + ss := Actions[I].Caption; + //---------------------------------------- remove by YS 7 Aug 2004 -| + //if Accelerator.Key <> vkNotPresent then | + // ss:=ss + #9 + Accelerator.AsText; | + //------------------------------------------------------------------| + SL.Add(Format('%s.%s := %s.Add( %s, %s, %s );', + [P, Actions[I].name, AName, Actions[I].StringConstant('Caption', ss), + Actions[I].StringConstant('Hint', Actions[I].Hint), s])); + SL.Add('//---->'); + Actions[I].FNameSetuppingInParent := True; + RptDetailed('Before calling SetupName for ' + Actions[I].name, YELLOW); + Actions[I].SetupName(SL, AName, AParent, Prefix); + Actions[I].FNameSetuppingInParent := False; + SL.Add('//<----'); - for j:=0 to Actions[i].FLinked.Count - 1 do begin - c:=TComponent(Actions[i].FLinked.Objects[j]); - if c = nil then - SL.Add( Format('%s// WARNING: Linked component %s can not be found. ' + - 'Possibly it is located at form that not currently loaded.', - [Prefix, Actions[i].FLinked[j]])) - else - if c is TKOLMenuItem then begin - with TKOLMenuItem(c) do - SL.Add( Format('%s.%s.LinkMenuItem( %s.%s, %d );', - [p, Actions[i].Name, pf, MenuComponent.Name, itemindex])) - end - else - if c is TKOLCustomControl then - with TKOLCustomControl(c) do - SL.Add( Format('%s.%s.LinkControl( %s.%s );', - [p, Actions[i].Name, pf, Name])) - else - if c is TKOLToolbarButton then - with TKOLToolbarButton(c) do - SL.Add( Format('%s.%s.LinkToolbarButton( %s.%s, %d );', - [p, Actions[i].Name, pf, ToolbarComponent.Name, - ToolbarComponent.Items.IndexOf(c)])) - end; - - if Actions[i].Checked then - SL.Add( Format('%s.%s.Checked := True;', - [p, Actions[i].Name])); - if not Actions[i].Visible then - SL.Add( Format('%s.%s.Visible := False;', - [p, Actions[i].Name])); - if not Actions[i].Enabled then - SL.Add( Format('%s.%s.Enabled := False;', - [p, Actions[i].Name])); - if Actions[i].HelpContext <> 0 then - SL.Add( Format('%s.%s.HelpContext := %d;', - [p, Actions[i].Name, Actions[i].HelpContext])); - if Actions[i].Tag <> 0 then - SL.Add(Format('%s.%s.Tag := %d;', [p, Actions[i].Name,Actions[i].Tag])); - - if Actions[i].Accelerator.Key <> vkNotPresent then - begin - S := 'FVIRTKEY'; - if kapShift in Actions[i].Accelerator.Prefix then - S := S + ' or FSHIFT'; - if kapControl in Actions[i].Accelerator.Prefix then - S := S + ' or FCONTROL'; - if kapAlt in Actions[i].Accelerator.Prefix then - S := S + ' or FALT'; - if kapNoinvert in Actions[i].Accelerator.Prefix then - S := S + ' or FNOINVERT'; - SL.Add( Format('%s.%s.Accelerator := MakeAccelerator(%s, %s);', - [p, Actions[i].Name, S, VirtKeys[ Actions[i].Accelerator.Key ]])); - end; - - - SL.Add(''); + for j := 0 to Actions[I].FLinked.Count - 1 do begin + c := TComponent(Actions[I].FLinked.Objects[j]); + if c = nil then + SL.Add(Format('%s// WARNING: Linked component %s can not be found. ' + + 'Possibly it is located at form that not currently loaded.', + [Prefix, Actions[I].FLinked[j]])) + else if c is TKOLMenuItem then begin + with TKOLMenuItem(c) do + SL.Add(Format('%s.%s.LinkMenuItem( %s.%s, %d );', + [P, Actions[I].name, PF, MenuComponent.name, itemindex])) + end + else if c is TKOLCustomControl then + with TKOLCustomControl(c) do + SL.Add(Format('%s.%s.LinkControl( %s.%s );', + [P, Actions[I].name, PF, name])) + else if c is TKOLToolbarButton then + with TKOLToolbarButton(c) do + SL.Add(Format('%s.%s.LinkToolbarButton( %s.%s, %d );', + [P, Actions[I].name, PF, ToolbarComponent.name, + ToolbarComponent.Items.IndexOf(c)])) end; + + if Actions[I].checked then + SL.Add(Format('%s.%s.Checked := True;', + [P, Actions[I].name])); + if not Actions[I].Visible then + SL.Add(Format('%s.%s.Visible := False;', + [P, Actions[I].name])); + if not Actions[I].Enabled then + SL.Add(Format('%s.%s.Enabled := False;', + [P, Actions[I].name])); + if Actions[I].HelpContext <> 0 then + SL.Add(Format('%s.%s.HelpContext := %d;', + [P, Actions[I].name, Actions[I].HelpContext])); + if Actions[I].Tag <> 0 then + SL.Add(Format('%s.%s.Tag := %d;', [P, Actions[I].name, Actions[I].Tag])); + + if Actions[I].accelerator.Key <> vkNotPresent then begin + s := 'FVIRTKEY'; + if kapShift in Actions[I].accelerator.Prefix then + s := s + ' or FSHIFT'; + if kapControl in Actions[I].accelerator.Prefix then + s := s + ' or FCONTROL'; + if kapAlt in Actions[I].accelerator.Prefix then + s := s + ' or FALT'; + if kapNoinvert in Actions[I].accelerator.Prefix then + s := s + ' or FNOINVERT'; + SL.Add(Format('%s.%s.Accelerator := MakeAccelerator(%s, %s);', + [P, Actions[I].name, s, VirtKeys[Actions[I].accelerator.Key]])); + end; + + SL.Add(''); + end; end; { TKOLActionListEditor } procedure TKOLActionListEditor.Edit; -var AL: TKOLActionList; +var + AL: TKOLActionList; begin - if Component = nil then Exit; - if not(Component is TKOLActionList) then Exit; + if Component = nil then + Exit; + if not (Component is TKOLActionList) then + Exit; AL := Component as TKOLActionList; if AL.ActiveDesign = nil then - AL.ActiveDesign := TfmActionListEditor.Create( Application ); + AL.ActiveDesign := TfmActionListEditor.Create(Application); AL.ActiveDesign.ActionList := AL; AL.ActiveDesign.Visible := True; - SetForegroundWindow( AL.ActiveDesign.Handle ); - AL.ActiveDesign.MakeActive( TRUE ); -{ - if AL.ParentForm <> nil then - AL.ParentForm.Invalidate; -} + SetForegroundWindow(AL.ActiveDesign.Handle); + AL.ActiveDesign.MakeActive(True); + { + if AL.ParentForm <> nil then + AL.ParentForm.Invalidate; + } end; procedure TKOLActionListEditor.ExecuteVerb(Index: Integer); @@ -27729,29 +22542,27 @@ end; procedure TKOLControl.Change; begin //Log( '->TKOLControl.Change' ); - TRY + try inherited; - //LogOK; - FINALLY + //LogOK; + finally //Log( '<-TKOLControl.Change' ); - END; + end; end; -function TKOLControl.Generate_SetSize: String; +function TKOLControl.Generate_SetSize: string; begin Result := inherited Generate_SetSize; end; - { TFormStringList } -function TFormStringList.Add(const s: String): Integer; +function TFormStringList.Add(const s: string): Integer; begin - if not FCallingOnAdd and Assigned( OnAdd ) then - begin - FCallingOnAdd := TRUE; - OnAdd( Self ); - FCallingOnAdd := FALSE; + if not FCallingOnAdd and Assigned(OnAdd) then begin + FCallingOnAdd := True; + OnAdd(Self); + FCallingOnAdd := False; end; Result := inherited Add(s); end; @@ -27762,24 +22573,25 @@ begin end; initialization - Log( 'I n i t i a l i z a t i o n' ); - {$IFDEF DEBUG_MCK} + Log('I n i t i a l i z a t i o n'); +{$IFDEF DEBUG_MCK} mck_Log := Log; - mck_Log( 'mck_Log assigned' ); - {$ENDIF} + mck_Log('mck_Log assigned'); +{$ENDIF} finalization - {$IFDEF MCKLOG} - Log( '->F i n a l i z a t i o n' ); - FormsList.Free; - FormsList := nil; - LogOK; - Log( '<-F i n a l i z a t i o n' ); - {$IFDEF MCKLOGBUFFERED} - if (LogBuffer <> nil) and (LogBuffer.Count > 0) then - LogFileOutput( 'C:\MCK.log', LogBuffer.Text ); - FreeAndNil( LogBuffer ); - {$ENDIF} - {$ENDIF} +{$IFDEF MCKLOG} + Log('->F i n a l i z a t i o n'); + FormsList.free; + FormsList := nil; + LogOK; + Log('<-F i n a l i z a t i o n'); +{$IFDEF MCKLOGBUFFERED} + if (LogBuffer <> nil) and (LogBuffer.Count > 0) then + LogFileOutput('C:\MCK.log', LogBuffer.Text); + FreeAndNil(LogBuffer); +{$ENDIF} +{$ENDIF} end. + diff --git a/whatsnew.txt b/whatsnew.txt index a2b49b5..8d929d5 100644 --- a/whatsnew.txt +++ b/whatsnew.txt @@ -1,3 +1,26 @@ +------------------------------------------------------------------- +05.03.21 +------------------------------------------------------------------- +Changes after last svn: + +* MCK: ux visual style mode updated +- MCK: remove pcode / collapse +- MCK: remove FormCompact +- MCK: source formatting: mckObjs.pas, mckCtrls.pas (by cnpack) +- KOL: remove codegeneration for MCK FormCompact +* KOL: move some defines from KOL.pas to KOLDEF.inc +* KOL: some refactoring\cleaning +* KOL: remove unused defines (SAFE_CODE, USE_CMOV, COMMANDACTIONS_OBJ, USE_AUTOFREE4CONTROLS, USE_AUTOFREE4CHILDREN, NEW_ALIGN, PROVIDE_EXITCODE - always on; OLD_REFCOUNT, SMALLEST_CODE*, SPEED_FASTER, USE_PROP, UMERIC_APPICON, CUSTOM_APPICON, TEST_INDEXOFCHARS_COMPAT, _FPC, REDEFINE_ABS, OLD_*, NOT_FIX_MODAL, NOT_UNLOAD_RICHEDITLIB, ANCHORS_WM_SIZE, COMMANDACTIONS_RECORD - always off; OLD_FREE and etc..) +* KOL: fix WStrRScan - affected: ExtractFileNeme, ExtractFileExt, ExtractFilePath and "Create new mck project" in XE 10.2 and maybe other high versions (by Hubert Bannwarth) +* KOL: fix "Create new mck project" in XE 10.2/3 and maybe other versions +* KOL: remove some old\commented\broken\asm code and defines like "*ASM_NO_VERSION*" +* KOLadd: remove some old\commented\broken\asm code and defines like "*ASM_NO_VERSION*" +* and some else.. + +Tested on: + Delphi 2006 x32(ansi\unicode) + Delphi XE 10.3 x32(unicode), x64(unicode) + ------------------------------------------------------------------- 3.12.14 -------------------------------------------------------------------